[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.37 and 1.61

version 1.37, Fri Apr 14 18:56:58 1995 UTC version 1.61, Thu Feb 6 21:23:05 1997 UTC
Line 1 
Line 1 
 \ Copyright 1992 by the ANSI figForth Development Group  \ Gforth primitives
 \  
   \ Copyright (C) 1995,1996 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
 \ don't collide with m4's (e.g. by undefining them).  \ don't collide with m4's (e.g. by undefining them).
 \  \
 \  \
 \  \
 \ This file contains instructions in the following format:  \ This file contains primitive specifications in the following format:
 \  \
 \ forth name    stack effect    category        [pronunciation]  \ forth name    stack effect    category        [pronunciation]
 \ [""glossary entry""]  \ [""glossary entry""]
Line 13 
Line 32 
 \ [:  \ [:
 \ Forth code]  \ Forth code]
 \  \
 \ The pronunciation is also used for forming C names.  \ prims2x is pedantic about tabs vs. blanks. The fields of the first
   \ line of a primitive are separated by tabs, the stack items in a
   \ stack effect by blanks.
 \  \
   \ Both pronounciation and stack items (in the stack effect) must
   \ conform to the C name syntax or the C compiler will complain.
 \  \
 \  \
 \ These informations are automatically translated into C-code for the  \ These specifications are automatically translated into C-code for the
 \ interpreter and into some other files. I hope that your C compiler has  \ interpreter and into some other files. I hope that your C compiler has
 \ decent optimization, otherwise the automatically generated code will  \ decent optimization, otherwise the automatically generated code will
 \ be somewhat slow. The Forth version of the code is included for manual  \ be somewhat slow. The Forth version of the code is included for manual
Line 80 
Line 103 
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   
 noop    --              fig  noop    --              gforth
 ;  ;
 :  :
  ;   ;
   
 lit     -- w            fig  lit     -- w            gforth
 w = (Cell)NEXT_INST;  w = (Cell)NEXT_INST;
 INC_IP(1);  INC_IP(1);
   :
    r> dup @ swap cell+ >r ;
   
 execute         xt --           core,fig  execute         xt --           core
 ip=IP;  ip=IP;
 cfa = xt;  
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 NEXT1;  EXEC(xt);
   
   perform         a_addr --       gforth
   ""equivalent to @code{@ execute}""
   /* and pfe */
   ip=IP;
   IF_TOS(TOS = sp[0]);
   EXEC(*(Xt *)a_addr);
   :
    @ execute ;
   
   \+has-locals [IF]
   
 branch-lp+!#    --      new     branch_lp_plus_store_number  branch-lp+!#    --      gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  branch_adjust_lp:
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 branch  --              fig  \+[THEN]
   
   branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
 NEXT_P0;  NEXT_P0;
 :  :
  r> dup @ + >r ;   r> dup @ + >r ;
   
 \ condbranch(forthname,restline,code)  \ condbranch(forthname,restline,code,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1      $2  $1      $2
Line 118 
Line 155 
 }  }
 else  else
     INC_IP(1);      INC_IP(1);
   $4
   
   \+has-locals [IF]
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    goto branch_adjust_lp;
Line 125 
Line 165 
 else  else
     INC_IP(2);      INC_IP(2);
   
   \+[THEN]
 )  )
   
 condbranch(?branch,f --         f83     question_branch,  condbranch(?branch,f --         f83     question_branch,
 if (f==0) {  if (f==0) {
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,)
   
   \ we don't need an lp_plus_store version of the ?dup-stuff, because it
   \ is only used in if's (yet)
   
   ?dup-?branch    f -- f  new     question_dupe_question_branch
   ""The run-time procedure compiled by @code{?DUP-IF}.""
   if (f==0) {
     sp++;
     IF_TOS(TOS = sp[0]);
     ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
     NEXT_P0;
     NEXT;
   }
   else
     INC_IP(1);
   
   ?dup-0=-?branch f --    new     question_dupe_zero_equals_question_branch
   ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
   /* the approach taken here of declaring the word as having the stack
   effect ( f -- ) and correcting for it in the branch-taken case costs a
   few cycles in that case, but is easy to convert to a CONDBRANCH
   invocation */
   if (f!=0) {
     sp--;
     ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
     NEXT_P0;
     NEXT;
   }
   else
     INC_IP(1);
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
 )  ,:
    r> r> dup 1- >r
    IF dup @ + >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),--            fig     paren_loop,  condbranch((loop),--            gforth  paren_loop,
 Cell index = *rp+1;  Cell index = *rp+1;
 Cell limit = rp[1];  Cell limit = rp[1];
 if (index != limit) {  if (index != limit) {
     *rp = index;      *rp = index;
 )  ,:
    r> r> 1+ r> 2dup =
    IF >r 1- >r cell+ >r
    ELSE >r >r dup @ + >r THEN ;)
   
 condbranch((+loop),n --         fig     paren_plus_loop,  condbranch((+loop),n --         gforth  paren_plus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
 Cell index = *rp;  Cell index = *rp;
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = index-rp[1];  Cell olddiff = index-rp[1];
 #ifndef undefined  
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 #else  
 #ifndef MAXINT  
 #define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1)  
 #endif  
 if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {  
 #endif  
 #ifdef i386  #ifdef i386
     *rp += n;      *rp += n;
 #else  #else
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,:
    r> swap
    r> r> 2dup - >r
    2 pick r@ + r@ xor 0< 0=
    3 pick r> xor 0< 0= or
    IF    >r + >r dup @ + >r
    ELSE  >r >r drop cell+ >r THEN ;)
   
   condbranch((-loop),u --         gforth  paren_minus_loop,
   /* !! check this thoroughly */
   Cell index = *rp;
   UCell olddiff = index-rp[1];
   if (olddiff>u) {
   #ifdef i386
       *rp -= u;
   #else
       *rp = index - u;
   #endif
       IF_TOS(TOS = sp[0]);
   ,)
   
 condbranch((s+loop),n --                new     paren_symmetric_plus_loop,  condbranch((s+loop),n --                gforth  paren_symmetric_plus_loop,
 ""The run-time procedure compiled by S+LOOP. It loops until the index  ""The run-time procedure compiled by S+LOOP. It loops until the index
 crosses the boundary between limit and limit-sign(n). I.e. a symmetric  crosses the boundary between limit and limit-sign(n). I.e. a symmetric
 version of (+LOOP).""  version of (+LOOP).""
Line 185 
Line 273 
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,)
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
Line 199 
Line 287 
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    nlimit nstart --                fig             paren_do  (do)    nlimit nstart --                gforth          paren_do
 /* or do it in high-level? 0.09/0.23% */  /* or do it in high-level? 0.09/0.23% */
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 :  :
  r> -rot swap >r >r >r ;   r> -rot swap >r >r >r ;
   
 (?do)   nlimit nstart --        core-ext        paren_question_do  (?do)   nlimit nstart --        gforth  paren_question_do
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 if (nstart == nlimit) {  if (nstart == nlimit) {
Line 216 
Line 304 
 else {  else {
     INC_IP(1);      INC_IP(1);
 }  }
   :
    swap 2dup
    r> swap >r swap >r
    =
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
 i       -- n            core,fig  (+do)   nlimit nstart --        gforth  paren_plus_do
   *--rp = nlimit;
   *--rp = nstart;
   if (nstart >= nlimit) {
       IF_TOS(TOS = sp[0]);
       goto branch;
       }
   else {
       INC_IP(1);
   }
   :
    swap 2dup
    r> swap >r swap >r
    >=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
   (u+do)  ulimit ustart --        gforth  paren_u_plus_do
   *--rp = ulimit;
   *--rp = ustart;
   if (ustart >= ulimit) {
       IF_TOS(TOS = sp[0]);
       goto branch;
       }
   else {
       INC_IP(1);
   }
   :
    swap 2dup
    r> swap >r swap >r
    u>=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
   (-do)   nlimit nstart --        gforth  paren_minus_do
   *--rp = nlimit;
   *--rp = nstart;
   if (nstart <= nlimit) {
       IF_TOS(TOS = sp[0]);
       goto branch;
       }
   else {
       INC_IP(1);
   }
   :
    swap 2dup
    r> swap >r swap >r
    <=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
   (u-do)  ulimit ustart --        gforth  paren_u_minus_do
   *--rp = ulimit;
   *--rp = ustart;
   if (ustart <= ulimit) {
       IF_TOS(TOS = sp[0]);
       goto branch;
       }
   else {
       INC_IP(1);
   }
   :
    swap 2dup
    r> swap >r swap >r
    u<=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
   i       -- n            core
 n = *rp;  n = *rp;
   :
    rp@ cell+ @ ;
   
   i'      -- w            gforth          i_tick
   ""loop end value""
   w = rp[1];
   :
    rp@ cell+ cell+ @ ;
   
 j       -- n            core  j       -- n            core
 n = rp[2];  n = rp[2];
   :
    rp@ cell+ cell+ cell+ @ ;
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 (emit)  c --            fig     paren_emit  (key)   -- n            gforth  paren_key
 putchar(c);  
 emitcounter++;  
   
 (type)  c_addr n --     fig     paren_type  
 fwrite(c_addr,sizeof(Char),n,stdout);  
 emitcounter += n;  
   
 (key)   -- n            fig     paren_key  
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  /* !! noecho */
 n = key();  n = key();
   
 key?    -- n            fig     key_q  key?    -- n            facility        key_q
 fflush(stdout);  fflush(stdout);
 n = key_query;  n = key_query;
   
 cr      --              fig  form    -- urows ucols  gforth
 puts("");  ""The number of lines and columns in the terminal. These numbers may change
 :  with the window size.""
  $0A emit ;  /* we could block SIGWINCH here to get a consistent size, but I don't
    think this is necessary or always beneficial */
   urows=rows;
   ucols=cols;
   
 move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
Line 306 
Line 488 
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
  ELSE  c@ I c@ - unloop  THEN  -text-flag ;   ELSE  c@ I c@ - unloop  THEN  -text-flag ;
 : -text-flag ( n -- -1/0/1 )  : -text-flag ( n -- -1/0/1 )
  dup 0< IF  drop -1  ELSE  0>  IF  1  ELSE  0  THEN  THEN  ;   dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;
   
   toupper c1 -- c2        gforth
   c2 = toupper(c1);
   :
    dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
   
 capscomp        c_addr1 u c_addr2 -- n  new  capscomp        c_addr1 u c_addr2 -- n  new
 Char c1, c2;  n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
 for (;; u--, c_addr1++, c_addr2++) {  if (n<0)
   if (u == 0) {  
     n = 0;  
     break;  
   }  
   c1 = toupper(*c_addr1);  
   c2 = toupper(*c_addr2);  
   if (c1 != c2) {  
     if (c1 < c2)  
       n = -1;        n = -1;
     else  else if (n>0)
       n = 1;        n = 1;
     break;  
   }  
 }  
 :  :
  swap bounds   swap bounds
  ?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ <>
        IF  dup c@ toupper I c@ toupper =
        ELSE  true  THEN  WHILE  1+  LOOP  drop 0
  ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;   ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;
   
 -trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       c_addr u1 -- c_addr u2          string  dash_trailing
Line 344 
Line 522 
 :  :
  tuck - >r + r> dup 0< IF  - 0  THEN ;   tuck - >r + r> dup 0< IF  - 0  THEN ;
   
 +       n1 n2 -- n              core,fig        plus  +       n1 n2 -- n              core    plus
 n = n1+n2;  n = n1+n2;
   
 -       n1 n2 -- n              core,fig        minus  \ PFE-0.9.14 has it differently, but the next release will have it as follows
   under+  n1 n2 n3 -- n n2        gforth  under_plus
   ""add @var{n3} to @var{n1} (giving @var{n})""
   n = n1+n3;
   :
    rot + swap ;
   
   -       n1 n2 -- n              core    minus
 n = n1-n2;  n = n1-n2;
 :  :
  negate + ;   negate + ;
   
 negate  n1 -- n2                core,fig  negate  n1 -- n2                core
 /* use minus as alias */  /* use minus as alias */
 n2 = -n1;  n2 = -n1;
 :  :
Line 392 
Line 577 
 :  :
  dup 0< IF negate THEN ;   dup 0< IF negate THEN ;
   
 *       n1 n2 -- n              core,fig        star  *       n1 n2 -- n              core    star
 n = n1*n2;  n = n1*n2;
 :  :
  um* drop ;   um* drop ;
   
 /       n1 n2 -- n              core,fig        slash  /       n1 n2 -- n              core    slash
 n = n1/n2;  n = n1/n2;
 :  :
  /mod nip ;   /mod nip ;
Line 424 
Line 609 
   
 fm/mod  d1 n1 -- n2 n3          core            f_m_slash_mod  fm/mod  d1 n1 -- n2 n3          core            f_m_slash_mod
 ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""  ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
   #ifdef BUGGY_LONG_LONG
   DCell r = fmdiv(d1,n1);
   n2=r.hi;
   n3=r.lo;
   #else
 /* assumes that the processor uses either floored or symmetric division */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
Line 432 
Line 622 
   n3--;    n3--;
   n2+=n1;    n2+=n1;
 }  }
   #endif
   :
    dup >r dup 0< IF  negate >r dnegate r>  THEN
    over       0< IF  tuck + swap  THEN
    um/mod
    r> 0< IF  swap negate swap  THEN ;
   
 sm/rem  d1 n1 -- n2 n3          core            s_m_slash_rem  sm/rem  d1 n1 -- n2 n3          core            s_m_slash_rem
 ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""  ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
   #ifdef BUGGY_LONG_LONG
   DCell r = smdiv(d1,n1);
   n2=r.hi;
   n3=r.lo;
   #else
 /* assumes that the processor uses either floored or symmetric division */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
Line 443 
Line 644 
   n3++;    n3++;
   n2-=n1;    n2-=n1;
 }  }
   #endif
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
  dabs rot um/mod   dabs rot um/mod
  r> 0< IF       negate       THEN   r> r@ xor 0< IF       negate       THEN
  r> 0< IF  swap negate swap  THEN ;   r> 0< IF  swap negate swap  THEN ;
   
 m*      n1 n2 -- d              core    m_star  m*      n1 n2 -- d              core    m_star
   #ifdef BUGGY_LONG_LONG
   d = mmul(n1,n2);
   #else
 d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
   #endif
 :  :
  2dup      0< and >r   2dup      0< and >r
  2dup swap 0< and >r   2dup swap 0< and >r
Line 458 
Line 664 
   
 um*     u1 u2 -- ud             core    u_m_star  um*     u1 u2 -- ud             core    u_m_star
 /* use u* as alias */  /* use u* as alias */
   #ifdef BUGGY_LONG_LONG
   ud = ummul(u1,u2);
   #else
 ud = (UDCell)u1 * (UDCell)u2;  ud = (UDCell)u1 * (UDCell)u2;
   #endif
   :
      >r >r 0 0 r> r> [ 8 cells ] literal 0
      DO
          over >r dup >r 0< and d2*+ drop
          r> 2* r> swap
      LOOP 2drop ;
   : d2*+ ( ud n -- ud+n c )
          over U-HIGHBIT
          and >r >r 2dup d+ swap r> + swap r> ;
   
 um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
   #ifdef BUGGY_LONG_LONG
   UDCell r = umdiv(ud,u1);
   u2=r.hi;
   u3=r.lo;
   #else
 u3 = ud/u1;  u3 = ud/u1;
 u2 = ud%u1;  u2 = ud%u1;
   #endif
 :  :
   dup IF  0 (um/mod)  THEN  nip ;     0 swap [ 8 cells 1 + ] literal 0
 : (um/mod)  ( ud ud--ud u)     ?DO >r /modstep r>
   2dup >r >r  dup 0<     LOOP drop swap 1 rshift or swap ;
   IF    2drop 0  : /modstep ( ud c R: u -- ud-?u c R: u )
   ELSE  2dup d+  (um/mod)  2*  THEN     over I' u< 0= or IF I' - 1 ELSE 0 THEN  d2*+ ;
   -rot  r> r> 2over 2over  du<  
   IF    2drop rot  
   ELSE  dnegate  d+  rot 1+  THEN ;  
   
 m+      d1 n -- d2              double          m_plus  m+      d1 n -- d2              double          m_plus
   #ifdef BUGGY_LONG_LONG
   d2.lo = d1.lo+n;
   d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
   #else
 d2 = d1+n;  d2 = d1+n;
   #endif
 :  :
  s>d d+ ;   s>d d+ ;
   
 d+      d1 d2 -- d              double,fig      d_plus  d+      d1 d2 -- d              double  d_plus
   #ifdef BUGGY_LONG_LONG
   d.lo = d1.lo+d2.lo;
   d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
   #else
 d = d1+d2;  d = d1+d2;
   #endif
 :  :
  >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/   rot + >r tuck + swap over u> r> swap - ;
  r> + >r + r> 0< r> r> + swap - ;  
   
 d-      d1 d2 -- d              double          d_minus  d-      d1 d2 -- d              double          d_minus
   #ifdef BUGGY_LONG_LONG
   d.lo = d1.lo - d2.lo;
   d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
   #else
 d = d1-d2;  d = d1-d2;
   #endif
 :  :
  dnegate d+ ;   dnegate d+ ;
   
 dnegate d1 -- d2                double  dnegate d1 -- d2                double
 /* use dminus as alias */  /* use dminus as alias */
   #ifdef BUGGY_LONG_LONG
   d2 = dnegate(d1);
   #else
 d2 = -d1;  d2 = -d1;
   #endif
 :  :
  invert swap negate tuck 0= - ;   invert swap negate tuck 0= - ;
   
 dmax    d1 d2 -- d      double  
 if (d1<d2)  
   d = d2;  
 else  
   d = d1;  
 :  
  2over 2over d> IF  2swap  THEN 2drop ;  
   
 dmin    d1 d2 -- d      double  
 if (d1<d2)  
   d = d1;  
 else  
   d = d2;  
 :  
  2over 2over d< IF  2swap  THEN 2drop ;  
   
 dabs    d1 -- d2        double  
 if (d1<0)  
   d2 = -d1;  
 else  
   d2 = d1;  
 :  
  dup 0< IF dnegate THEN ;  
   
 d2*     d1 -- d2                double          d_two_star  d2*     d1 -- d2                double          d_two_star
   #ifdef BUGGY_LONG_LONG
   d2.lo = d1.lo<<1;
   d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
   #else
 d2 = 2*d1;  d2 = 2*d1;
   #endif
 :  :
  2dup d+ ;   2dup d+ ;
   
 d2/     d1 -- d2                double          d_two_slash  d2/     d1 -- d2                double          d_two_slash
 /* !! is this still correct? */  #ifdef BUGGY_LONG_LONG
   d2.hi = d1.hi>>1;
   d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
   #else
 d2 = d1>>1;  d2 = d1>>1;
   #endif
 :  :
  dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and   dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
  r> IF  [ 1 8 cells 1- lshift ] Literal + THEN  swap ;   r> IF  [ 1 8 cells 1- lshift ] Literal + THEN  swap ;
   
 d>s     d -- n                  double          d_to_s  and     w1 w2 -- w              core
 /* make this an alias for drop? */  
 n = d;  
 :  
  drop ;  
   
 and     w1 w2 -- w              core,fig  
 w = w1&w2;  w = w1&w2;
   
 or      w1 w2 -- w              core,fig  or      w1 w2 -- w              core
 w = w1|w2;  w = w1|w2;
   
 xor     w1 w2 -- w              core,fig  xor     w1 w2 -- w              core
 w = w1^w2;  w = w1^w2;
   
 invert  w1 -- w2                core  invert  w1 -- w2                core
Line 563 
Line 782 
 f = FLAG($4==$5);  f = FLAG($4==$5);
   
 $1<>    $2 -- f         $7      $3different  $1<>    $2 -- f         $7      $3different
 /* use != as alias ? */  
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
   
 $1<     $2 -- f         $8      $3less  $1<     $2 -- f         $8      $3less
Line 572 
Line 790 
 $1>     $2 -- f         $9      $3greater  $1>     $2 -- f         $9      $3greater
 f = FLAG($4>$5);  f = FLAG($4>$5);
   
 $1<=    $2 -- f         new     $3less_or_equal  $1<=    $2 -- f         gforth  $3less_or_equal
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
   
 $1>=    $2 -- f         new     $3greater_or_equal  $1>=    $2 -- f         gforth  $3greater_or_equal
 f = FLAG($4>=$5);  f = FLAG($4>=$5);
   
 )  )
   
 comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)  comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
 comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)  comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
 comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext)  comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
 comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)  
 comparisons(d0, d, d_zero_, d, 0, double, new, double, new)  \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)  define(dcomparisons,
   $1=     $2 -- f         $6      $3equals
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
   #else
   f = FLAG($4==$5);
   #endif
   
   $1<>    $2 -- f         $7      $3different
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
   #else
   f = FLAG($4!=$5);
   #endif
   
   $1<     $2 -- f         $8      $3less
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
   #else
   f = FLAG($4<$5);
   #endif
   
   $1>     $2 -- f         $9      $3greater
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
   #else
   f = FLAG($4>$5);
   #endif
   
   $1<=    $2 -- f         gforth  $3less_or_equal
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
   #else
   f = FLAG($4<=$5);
   #endif
   
   $1>=    $2 -- f         gforth  $3greater_or_equal
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
   #else
   f = FLAG($4>=$5);
   #endif
   
   )
   
   dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
   dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
   dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
   
 within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
 sp@     -- a_addr               fig             spat  sp@     -- a_addr               gforth          spat
 a_addr = sp+1;  a_addr = sp+1;
   
 sp!     a_addr --               fig             spstore  sp!     a_addr --               gforth          spstore
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without TOS caching */
   
 rp@     -- a_addr               fig             rpat  rp@     -- a_addr               gforth          rpat
 a_addr = rp;  a_addr = rp;
   
 rp!     a_addr --               fig             rpstore  rp!     a_addr --               gforth          rpstore
 rp = a_addr;  rp = a_addr;
   
 fp@     -- f_addr       new     fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
   
 fp!     f_addr --       new     fp_store  fp!     f_addr --       gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 ;s      --              fig     semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
 NEXT_P0;  NEXT_P0;
   
 >r      w --            core,fig        to_r  >r      w --            core    to_r
 *--rp = w;  *--rp = w;
   
 r>      -- w            core,fig        r_from  r>      -- w            core    r_from
 w = *rp++;  w = *rp++;
   
 r@      -- w            core,fig        r_fetch  rdrop   --              gforth
 /* use r as alias */  
 /* make r@ an alias for i */  
 w = *rp;  
   
 rdrop   --              fig  
 rp++;  rp++;
   :
 i'      -- w            fig             i_tick   r> r> drop >r ;
 w=rp[1];  
   
 2>r     w1 w2 --        core-ext        two_to_r  2>r     w1 w2 --        core-ext        two_to_r
 *--rp = w1;  *--rp = w1;
 *--rp = w2;  *--rp = w2;
   :
    swap r> swap >r swap >r >r ;
   
 2r>     -- w1 w2        core-ext        two_r_from  2r>     -- w1 w2        core-ext        two_r_from
 w2 = *rp++;  w2 = *rp++;
 w1 = *rp++;  w1 = *rp++;
   :
    r> r> swap r> swap >r swap ;
   
 2r@     -- w1 w2        core-ext        two_r_fetch  2r@     -- w1 w2        core-ext        two_r_fetch
 w2 = rp[0];  w2 = rp[0];
 w1 = rp[1];  w1 = rp[1];
   :
    i' j ;
   
 2rdrop  --              new     two_r_drop  2rdrop  --              gforth  two_r_drop
 rp+=2;  rp+=2;
   :
    r> r> drop r> drop >r ;
   
 over    w1 w2 -- w1 w2 w1               core,fig  over    w1 w2 -- w1 w2 w1               core
   :
    sp@ cell+ @ ;
   
 drop    w --            core,fig  drop    w --            core
   :
    IF THEN ;
   
 swap    w1 w2 -- w2 w1          core,fig  swap    w1 w2 -- w2 w1          core
   :
    >r (swap) ! r> (swap) @ ;
   Variable (swap)
   
 dup     w -- w w                core,fig  dup     w -- w w                core
   :
    sp@ @ ;
   
 rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     w1 w2 w3 -- w2 w3 w1    core    rote
   :
    (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
   Variable (rot)
   
 -rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote  -rot    w1 w2 w3 -- w3 w1 w2    gforth  not_rote
 :  :
  rot rot ;   rot rot ;
   
 nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
 :  :
  swap drop ;   >r drop r> ;
   
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
 :  :
Line 698 
Line 977 
   
 2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap  2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap
 :  :
  >r -rot r> -rot ;   rot >r rot r> ;
   
 2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote  2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double-ext      two_rote
 :  :
  >r >r 2swap r> r> 2swap ;   >r >r 2swap r> r> 2swap ;
   
   2nip    w1 w2 w3 w4 -- w3 w4    gforth  two_nip
   :
    2swap 2drop ;
   
   2tuck   w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4        gforth  two_tuck
   :
    2swap 2over ;
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
 @       a_addr -- w             fig     fetch  @       a_addr -- w             core    fetch
 w = *a_addr;  w = *a_addr;
   
 !       w a_addr --             core,fig        store  !       w a_addr --             core    store
 *a_addr = w;  *a_addr = w;
   
 +!      n a_addr --             core,fig        plus_store  +!      n a_addr --             core    plus_store
 *a_addr += n;  *a_addr += n;
   :
    tuck @ + swap ! ;
   
 c@      c_addr -- c             fig     cfetch  c@      c_addr -- c             core    cfetch
 c = *c_addr;  c = *c_addr;
   
 c!      c c_addr --             fig     cstore  c!      c c_addr --             core    cstore
 *c_addr = c;  *c_addr = c;
   
 2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
Line 733 
Line 1022 
 :  :
  dup cell+ @ swap @ ;   dup cell+ @ swap @ ;
   
 d!      d a_addr --             double  d_store  
 /* !! alignment problems on some machines */  
 *(DCell *)a_addr = d;  
   
 d@      a_addr -- d             double  d_fetch  
 d = *(DCell *)a_addr;  
   
 cell+   a_addr1 -- a_addr2      core    cell_plus  cell+   a_addr1 -- a_addr2      core    cell_plus
 a_addr2 = a_addr1+1;  a_addr2 = a_addr1+1;
 :  :
Line 771 
Line 1053 
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (bye)   n --    toolkit-ext     paren_bye  
 return (Label *)n;  
   
 system  c_addr u -- n   own  
 n=system(cstr(c_addr,u,1));  
   
 getenv  c_addr1 u1 -- c_addr2 u2        new  
 c_addr2 = getenv(cstr(c_addr1,u1,1));  
 u2=strlen(c_addr2);  
   
 popen   c_addr u n -- wfileid   own  
 static char* mode[2]={"r","w"};  
 wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);  
   
 pclose  wfileid -- wior own  
 wior=pclose((FILE *)wfileid); /* !! what to do with the result */  
   
 time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date  
 struct timeval time1;  
 struct timezone zone1;  
 struct tm *ltime;  
 gettimeofday(&time1,&zone1);  
 ltime=localtime(&time1.tv_sec);  
 nyear =ltime->tm_year+1900;  
 nmonth=ltime->tm_mon+1;  
 nday  =ltime->tm_mday;  
 nhour =ltime->tm_hour;  
 nmin  =ltime->tm_min;  
 nsec  =ltime->tm_sec;  
   
 ms      n --    facility-ext  
 struct timeval timeout;  
 timeout.tv_sec=n/1000;  
 timeout.tv_usec=1000*(n%1000);  
 (void)select(0,0,0,0,&timeout);  
   
 allocate        u -- a_addr wior        memory  
 a_addr = (Cell *)malloc(u);  
 wior = IOR(a_addr==NULL);  
   
 free            a_addr -- wior          memory  
 free(a_addr);  
 wior = 0;  
   
 resize          a_addr1 u -- a_addr2 wior       memory  
 ""Change the size of the allocated area at @i{a_addr1} to @i{u}  
 address units, possibly moving the contents to a different  
 area. @i{a_addr2} is the address of the resulting area. If  
 @code{a_addr2} is 0, gforth's (but not the standard) @code{resize}  
 @code{allocate}s @i{u} address units.""  
 /* the following check is not necessary on most OSs, but it is needed  
    on SunOS 4.1.2. */  
 if (a_addr1==NULL)  
   a_addr2 = (Cell *)malloc(u);  
 else  
   a_addr2 = (Cell *)realloc(a_addr1, u);  
 wior = IOR(a_addr2==NULL);      /* !! Define a return code */  
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = f83name1->next)
   if (F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
       strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
 f83name2=f83name1;  f83name2=f83name1;
 :  :
Line 850 
Line 1074 
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if (F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
      {       {
         f83name2=f83name1;          f83name2=f83name1;
         break;          break;
Line 865 
Line 1089 
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (hashkey)       c_addr u1 -- u2         new     paren_hashkey  (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind
   ""A case-sensitive variant of @code{(hashfind)}""
   F83Name *f83name1;
   f83name2=NULL;
   while(a_addr != NULL)
   {
      f83name1=(F83Name *)(a_addr[1]);
      a_addr=(Cell *)(a_addr[0]);
      if ((UCell)F83NAME_COUNT(f83name1)==u &&
          memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
        {
           f83name2=f83name1;
           break;
        }
   }
   :
    BEGIN  dup  WHILE
           2@ >r >r dup r@ cell+ c@ $1F and =
           IF  2dup r@ cell+ char+ -text 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
   (hashkey)       c_addr u1 -- u2         gforth  paren_hashkey
 u2=0;  u2=0;
 while(u1--)  while(u1--)
    u2+=(Cell)toupper(*c_addr++);     u2+=(Cell)toupper(*c_addr++);
 :  :
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;   0 -rot bounds ?DO  I c@ toupper +  LOOP ;
   
 (hashkey1)      c_addr u ubits -- ukey          new     paren_hashkey1  (hashkey1)      c_addr u ubits -- ukey          gforth  paren_hashkey1
 ""ukey is the hash key for the string c_addr u fitting in ubits bits""  ""ukey is the hash key for the string c_addr u fitting in ubits bits""
 /* this hash function rotates the key at every step by rot bits within  /* this hash function rotates the key at every step by rot bits within
    ubits bits and xors it with the character. This function does ok in     ubits bits and xors it with the character. This function does ok in
Line 899 
Line 1146 
   7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,    7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
   7 c, 5 c, 5 c,    7 c, 5 c, 5 c,
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        new     paren_parse_white  (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white
 /* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
 Char *endp = c_addr1+u1;  Char *endp = c_addr1+u1;
 while (c_addr1<endp && isspace(*c_addr1))  while (c_addr1<endp && isspace(*c_addr1))
Line 919 
Line 1166 
  BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string   BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string
  REPEAT  THEN  nip - ;   REPEAT  THEN  nip - ;
   
   aligned         c_addr -- a_addr        core
   a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
   :
    [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   
   faligned        c_addr -- f_addr        float   f_aligned
   f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
   :
    [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
   >body           xt -- a_addr    core    to_body
   a_addr = PFA(xt);
   :
       2 cells + ;
   
   >code-address           xt -- c_addr            gforth  to_code_address
   ""c_addr is the code address of the word xt""
   /* !! This behaves installation-dependently for DOES-words */
   c_addr = CODE_ADDRESS(xt);
   :
       @ ;
   
   >does-code      xt -- a_addr            gforth  to_does_code
   ""If xt ist the execution token of a defining-word-defined word,
   a_addr is the start of the Forth code after the DOES>;
   Otherwise a_addr is 0.""
   a_addr = (Cell *)DOES_CODE(xt);
   :
       cell+ @ ;
   
   code-address!           c_addr xt --            gforth  code_address_store
   ""Creates a code field with code address c_addr at xt""
   MAKE_CF(xt, c_addr);
   CACHE_FLUSH(xt,PFA(0));
   :
       ! ;
   
   does-code!      a_addr xt --            gforth  does_code_store
   ""creates a code field at xt for a defining-word-defined word; a_addr
   is the start of the Forth code after DOES>""
   MAKE_DOES_CF(xt, a_addr);
   CACHE_FLUSH(xt,PFA(0));
   :
       dodoes: over ! cell+ ! ;
   
   does-handler!   a_addr --       gforth  does_handler_store
   ""creates a DOES>-handler at address a_addr. a_addr usually points
   just behind a DOES>.""
   MAKE_DOES_HANDLER(a_addr);
   CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
   :
       drop ;
   
   /does-handler   -- n    gforth  slash_does_handler
   ""the size of a does-handler (includes possible padding)""
   /* !! a constant or environmental query might be better */
   n = DOES_HANDLER_SIZE;
   :
       2 cells ;
   
   threading-method        -- n    gforth  threading_method
   ""0 if the engine is direct threaded.""
   #if defined(DIRECT_THREADED)
   n=0;
   #else
   n=1;
   #endif
   :
    1 ;
   
   \+has-os [IF]
   
   flush-icache    c_addr u --     gforth  flush_icache
   ""Make sure that the instruction cache of the processor (if there is
   one) does not contain stale data at @var{c_addr} and @var{u} bytes
   afterwards. @code{END-CODE} performs a @code{flush-icache}
   automatically. Caveat: @code{flush-icache} might not work on your
   installation; this is usually the case if direct threading is not
   supported on your machine (take a look at your @file{machine.h}) and
   your machine has a separate instruction cache. In such cases,
   @code{flush-icache} does nothing instead of flushing the instruction
   cache.""
   FLUSH_ICACHE(c_addr,u);
   
   (bye)   n --    gforth  paren_bye
   return (Label *)n;
   
   (system)        c_addr u -- wretval wior        gforth  peren_system
   int old_tp=terminal_prepped;
   deprep_terminal();
   wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
   wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
   if (old_tp)
     prep_terminal();
   
   getenv  c_addr1 u1 -- c_addr2 u2        gforth
   c_addr2 = getenv(cstr(c_addr1,u1,1));
   u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
   open-pipe       c_addr u ntype -- wfileid wior  gforth  open_pipe
   wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
   wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
   close-pipe      wfileid -- wretval wior         gforth  close_pipe
   wretval = pclose((FILE *)wfileid);
   wior = IOR(wretval==-1);
   
   time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
   struct timeval time1;
   struct timezone zone1;
   struct tm *ltime;
   gettimeofday(&time1,&zone1);
   ltime=localtime((time_t *)&time1.tv_sec);
   nyear =ltime->tm_year+1900;
   nmonth=ltime->tm_mon+1;
   nday  =ltime->tm_mday;
   nhour =ltime->tm_hour;
   nmin  =ltime->tm_min;
   nsec  =ltime->tm_sec;
   
   ms      n --    facility-ext
   struct timeval timeout;
   timeout.tv_sec=n/1000;
   timeout.tv_usec=1000*(n%1000);
   (void)select(0,0,0,0,&timeout);
   
   allocate        u -- a_addr wior        memory
   a_addr = (Cell *)malloc(u?u:1);
   wior = IOR(a_addr==NULL);
   
   free            a_addr -- wior          memory
   free(a_addr);
   wior = 0;
   
   resize          a_addr1 u -- a_addr2 wior       memory
   ""Change the size of the allocated area at @i{a_addr1} to @i{u}
   address units, possibly moving the contents to a different
   area. @i{a_addr2} is the address of the resulting area. If
   @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}
   @code{allocate}s @i{u} address units.""
   /* the following check is not necessary on most OSs, but it is needed
      on SunOS 4.1.2. */
   if (a_addr1==NULL)
     a_addr2 = (Cell *)malloc(u);
   else
     a_addr2 = (Cell *)realloc(a_addr1, u);
   wior = IOR(a_addr2==NULL);      /* !! Define a return code */
   
   strerror        n -- c_addr u   gforth
   c_addr = strerror(n);
   u = strlen(c_addr);
   
   strsignal       n -- c_addr u   gforth
   c_addr = strsignal(n);
   u = strlen(c_addr);
   
   call-c  w --    gforth  call_c
   ""Call the C function pointed to by @i{w}. The C function has to
   access the stack itself. The stack pointers are exported in the global
   variables @code{SP} and @code{FP}.""
   /* This is a first attempt at support for calls to C. This may change in
      the future */
   IF_FTOS(fp[0]=FTOS);
   FP=fp;
   SP=sp;
   ((void (*)())w)();
   sp=SP;
   fp=FP;
   IF_TOS(TOS=sp[0]);
   IF_FTOS(FTOS=fp[0]);
   
   \+[THEN] ( has-os ) has-files [IF]
   
 close-file      wfileid -- wior         file    close_file  close-file      wfileid -- wior         file    close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
   
 open-file       c_addr u ntype -- w2 wior       file    open_file  open-file       c_addr u ntype -- w2 wior       file    open_file
 w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);  w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
 wior =  IOR(w2 == NULL);  wior =  IOR(w2 == 0);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
 Cell    fd;  Cell    fd;
 fd = open(cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);  fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
 if (fd != -1) {  if (fd != -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
   wior = IOR(w2==NULL);    wior = IOR(w2 == 0);
 } else {  } else {
   w2 = 0;    w2 = 0;
   wior = IOR(1);    wior = IOR(1);
 }  }
   
 delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file
 wior = IOR(unlink(cstr(c_addr, u, 1))==-1);  wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
 char *s1=cstr(c_addr2, u2, 1);  char *s1=tilde_cstr(c_addr2, u2, 1);
 wior = IOR(rename(cstr(c_addr1, u1, 0), s1)==-1);  wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
   
 file-position   wfileid -- ud wior      file    file_position  file-position   wfileid -- ud wior      file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
 ud = ftell((FILE *)wfileid);  ud = LONG2UD(ftell((FILE *)wfileid));
 wior = IOR(ud==-1);  wior = IOR(UD2LONG(ud)==-1);
   
 reposition-file ud wfileid -- wior      file    reposition_file  reposition-file ud wfileid -- wior      file    reposition_file
 wior = IOR(fseek((FILE *)wfileid, (long)ud, SEEK_SET)==-1);  wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
   
 file-size       wfileid -- ud wior      file    file_size  file-size       wfileid -- ud wior      file    file_size
 struct stat buf;  struct stat buf;
 wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);  wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 ud = buf.st_size;  ud = LONG2UD(buf.st_size);
   
 resize-file     ud wfileid -- wior      file    resize_file  resize-file     ud wfileid -- wior      file    resize_file
 wior = IOR(ftruncate(fileno((FILE *)wfileid), (Cell)ud)==-1);  wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1);
   
 read-file       c_addr u1 wfileid -- u2 wior    file    read_file  read-file       c_addr u1 wfileid -- u2 wior    file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
Line 1000 
Line 1420 
 write-file      c_addr u1 wfileid -- wior       file    write_file  write-file      c_addr u1 wfileid -- wior       file    write_file
 /* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
 {  {
   Cell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);    UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));    wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
   if (wior)    if (wior)
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
 }  }
   
   emit-file       c wfileid -- wior       gforth  emit_file
   wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
   if (wior)
     clearerr((FILE *)wfileid);
   
 flush-file      wfileid -- wior         file-ext        flush_file  flush-file      wfileid -- wior         file-ext        flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)  file-status     c_addr u -- ntype wior  file-ext        file_status
 comparisons(f0, r, f_zero_, r, 0., float, new, float, new)  char *filename=tilde_cstr(c_addr, u, 1);
   if (access (filename, F_OK) != 0) {
     ntype=0;
     wior=IOR(1);
   }
   else if (access (filename, R_OK | W_OK) == 0) {
     ntype=2; /* r/w */
     wior=0;
   }
   else if (access (filename, R_OK) == 0) {
     ntype=0; /* r/o */
     wior=0;
   }
   else if (access (filename, W_OK) == 0) {
     ntype=4; /* w/o */
     wior=0;
   }
   else {
     ntype=1; /* well, we cannot access the file, but better deliver a legal
               access mode (r/o bin), so we get a decent error later upon open. */
     wior=0;
   }
   
   stdout  -- wfileid      gforth
   wfileid = (Cell)stdout;
   
   stderr  -- wfileid      gforth
   wfileid = (Cell)stderr;
   
   \+[THEN] ( has-files ) has-floats [IF]
   
   comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
   comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
   
 d>f             d -- r          float   d_to_f  d>f             d -- r          float   d_to_f
   #ifdef BUGGY_LONG_LONG
   extern double ldexp(double x, int exp);
   r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
   #else
 r = d;  r = d;
   #endif
   
 f>d             r -- d          float   f_to_d  f>d             r -- d          float   f_to_d
 /* !! basis 15 is not very specific */  #ifdef BUGGY_LONG_LONG
   d.hi = ldexp(r,-CELL_BITS) - (r<0);
   d.lo = r-ldexp((Float)d.hi,CELL_BITS);
   #else
 d = r;  d = r;
   #endif
   
 f!              r f_addr --     float   f_store  f!              r f_addr --     float   f_store
 *f_addr = r;  *f_addr = r;
Line 1082 
Line 1548 
   
 frot            r1 r2 r3 -- r2 r3 r1    float  frot            r1 r2 r3 -- r2 r3 r1    float
   
   fnip            r1 r2 -- r2     gforth
   
   ftuck           r1 r2 -- r2 r1 r2       gforth
   
 float+          f_addr1 -- f_addr2      float   float_plus  float+          f_addr1 -- f_addr2      float   float_plus
 f_addr2 = f_addr1+1;  f_addr2 = f_addr1+1;
   
Line 1119 
Line 1589 
 char *sig;  char *sig;
 Cell flag;  Cell flag;
 Cell decpt;  Cell decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, (int *)&decpt, (int *)&flag);
 n=(r==0 ? 1 : decpt);  n=(r==0 ? 1 : decpt);
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);  f2=FLAG(isdigit(sig[0])!=0);
Line 1259 
Line 1729 
  fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/   fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
  r> IF  fnegate  THEN ;   r> IF  fnegate  THEN ;
   
 \ The following words access machine/OS/installation-dependent ANSI  sfloats         n1 -- n2        float-ext       s_floats
 \   figForth internals  n2 = n1*sizeof(SFloat);
 \ !! how about environmental queries DIRECT-THREADED,  
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  
   
 >body           xt -- a_addr    core    to_body  
 a_addr = PFA(xt);  
   
 >code-address           xt -- c_addr            new     to_code_address  
 ""c_addr is the code address of the word xt""  
 /* !! This behaves installation-dependently for DOES-words */  
 c_addr = CODE_ADDRESS(xt);  
   
 >does-code      xt -- a_addr            new     to_does_code  
 ""If xt ist the execution token of a defining-word-defined word,  
 a_addr is the start of the Forth code after the DOES>; Otherwise the  
 behaviour is undefined""  
 /* !! there is currently no way to determine whether a word is  
 defining-word-defined */  
 a_addr = (Cell *)DOES_CODE(xt);  
   
 code-address!           n xt -- new     code_address_store  
 ""Creates a code field with code address c_addr at xt""  
 MAKE_CF(xt, symbols[CF(n)]);  
 CACHE_FLUSH(xt,PFA(0));  
   
 does-code!      a_addr xt --            new     does_code_store  dfloats         n1 -- n2        float-ext       d_floats
 ""creates a code field at xt for a defining-word-defined word; a_addr  n2 = n1*sizeof(DFloat);
 is the start of the Forth code after DOES>""  
 MAKE_DOES_CF(xt, a_addr);  
 CACHE_FLUSH(xt,PFA(0));  
   
 does-handler!   a_addr --       new     does_jump_store  sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned
 ""creates a DOES>-handler at address a_addr. a_addr usually points  sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
 just behind a DOES>.""  :
 MAKE_DOES_HANDLER(a_addr);   [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  
   
 /does-handler   -- n    new     slash_does_handler  dfaligned       c_addr -- df_addr       float-ext       d_f_aligned
 ""the size of a does-handler (includes possible padding)""  df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
 /* !! a constant or environmental query might be better */  :
 n = DOES_HANDLER_SIZE;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
 toupper c1 -- c2        new  \ The following words access machine/OS/installation-dependent
 c2 = toupper(c1);  \   Gforth internals
   \ !! how about environmental queries DIRECT-THREADED,
   \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 @local#         -- w    new     fetch_local_number  \+[THEN] ( has-floats ) has-locals [IF]
   
   @local#         -- w    gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
   
Line 1322 
Line 1769 
 @local3 -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = *(Cell *)(lp+3*sizeof(Cell));
   
 f@local#        -- r    new     f_fetch_local_number  \+has-floats [IF]
   
   f@local#        -- r    gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
   
Line 1332 
Line 1781 
 f@local1        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  r = *(Float *)(lp+1*sizeof(Float));
   
 laddr#          -- c_addr       new     laddr_number  \+[THEN]
   
   laddr#          -- c_addr       gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(Cell)NEXT_INST);  c_addr = (Char *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
   
 lp+!#   --      new     lp_plus_store_number  lp+!#   --      gforth  lp_plus_store_number
 ""used with negative immediate values it allocates memory on the  ""used with negative immediate values it allocates memory on the
 local stack, a positive immediate argument drops memory from the local  local stack, a positive immediate argument drops memory from the local
 stack""  stack""
Line 1353 
Line 1804 
 lp+2    --      new     sixteen_lp_plus_store  lp+2    --      new     sixteen_lp_plus_store
 lp += 2*sizeof(Float);  lp += 2*sizeof(Float);
   
 lp!     c_addr --       new     lp_store  lp!     c_addr --       gforth  lp_store
 lp = (Address)c_addr;  lp = (Address)c_addr;
   
 >l      w --    new     to_l  >l      w --    gforth  to_l
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 f>l     r --    new     f_to_l  \+has-floats [IF]
   
   f>l     r --    gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 up!     a_addr --       new     up_store  \+[THEN]  [THEN] \ has-locals
 up0=up=(char *)a_addr;  
   
 call-c  w --    new     call_c  up!     a_addr --       gforth  up_store
 ""Call the C function pointed to by @i{w}. The C function has to  up0=up=(char *)a_addr;
 access the stack itself. The stack pointers are exported in the gloabl  :
 variables @code{SP} and @code{FP}.""   up ! ;
 /* This is a first attempt at support for calls to C. This may change in  
    the future */  
 IF_FTOS(fp[0]=FTOS);  
 FP=fp;  
 SP=sp;  
 ((void (*)())w)();  
 sp=SP;  
 fp=FP;  
 IF_TOS(TOS=sp[0]);  
 IF_FTOS(FTOS=fp[0]);  
   
 strerror        n -- c_addr u   new  
 c_addr = strerror(n);  
 u = strlen(c_addr);  

Generate output suitable for use with a patch program
Legend:
Removed from v.1.37  
changed lines
  Added in v.1.61
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help