[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.39 and 1.54

version 1.39, Wed Jun 7 10:05:10 1995 UTC version 1.54, Fri May 3 13:05:06 1996 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);
   
 execute         xt --           core,fig  execute         xt --           core
   ip=IP;
   IF_TOS(TOS = sp[0]);
   EXEC(xt);
   
   perform         a_addr --       gforth
   ""equivalent to @code{@ execute}""
   /* and pfe */
 ip=IP;  ip=IP;
 cfa = xt;  
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 NEXT1;  EXEC(*(Xt *)a_addr);
   :
    @ execute ;
   
 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  branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
 NEXT_P0;  NEXT_P0;
Line 132 
Line 163 
     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)--) {
 )  )
   
 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;
 )  )
   
 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) */
Line 166 
Line 227 
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  )
   
 condbranch((s+loop),n --                new     paren_symmetric_plus_loop,  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 --                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 199 
Line 273 
 :  :
  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 217 
Line 291 
     INC_IP(1);      INC_IP(1);
 }  }
   
 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);
   }
   
   (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);
   }
   
   (-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);
   }
   
   (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);
   }
   
   i       -- n            core
 n = *rp;  n = *rp;
   
 j       -- n            core  j       -- n            core
Line 225 
Line 343 
   
 \ 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 344 
Line 457 
 :  :
  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 has it differently, so let's better not define it
   \ under+        n1 n2 n3 -- n n2        gforth  under_plus
   \ ""add @var{n3} to @var{n1} (giving @var{n})""
   \ /* and pfe */
   \ 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 513 
 :  :
  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 545 
   
 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 558 
   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 580 
   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 600 
   
 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
   
 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 ;    dup IF  0 (um/mod)  THEN  nip ;
 : (um/mod)  ( ud ud--ud u)  : (um/mod)  ( ud ud--ud u)
Line 474 
Line 626 
   ELSE  dnegate  d+  rot 1+  THEN ;    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 712 
 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 720 
 $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  r@      -- w            core    r_fetch
 /* use r as alias */  /* use r as alias */
 /* make r@ an alias for i */  /* make r@ an alias for i */
 w = *rp;  w = *rp;
   
 rdrop   --              fig  rdrop   --              gforth
 rp++;  rp++;
   
 i'      -- w            fig             i_tick  i'      -- w            gforth          i_tick
 w=rp[1];  w=rp[1];
   
 2>r     w1 w2 --        core-ext        two_to_r  2>r     w1 w2 --        core-ext        two_to_r
Line 644 
Line 839 
 w2 = rp[0];  w2 = rp[0];
 w1 = rp[1];  w1 = rp[1];
   
 2rdrop  --              new     two_r_drop  2rdrop  --              gforth  two_r_drop
 rp+=2;  rp+=2;
   
 over    w1 w2 -- w1 w2 w1               core,fig  over    w1 w2 -- w1 w2 w1               core
   
 drop    w --            core,fig  drop    w --            core
   
 swap    w1 w2 -- w2 w1          core,fig  swap    w1 w2 -- w2 w1          core
   
 dup     w -- w w                core,fig  dup     w -- w w                core
   
 rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     w1 w2 w3 -- w2 w3 w1    core    rote
   
 -rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote  -rot    w1 w2 w3 -- w3 w1 w2    gforth  not_rote
 :  :
  rot rot ;   rot rot ;
   
Line 700 
Line 895 
 :  :
  >r -rot r> -rot ;   >r -rot r> -rot ;
   
 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;
   
 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 936 
 :  :
  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 967 
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (bye)   n --    toolkit-ext     paren_bye  (bye)   n --    gforth  paren_bye
 return (Label *)n;  return (Label *)n;
   
 system  c_addr u -- n   own  system  c_addr u -- n   gforth
   int old_tp=terminal_prepped;
   deprep_terminal();
 n=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  n=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
   if (old_tp)
     prep_terminal();
   
 getenv  c_addr1 u1 -- c_addr2 u2        new  getenv  c_addr1 u1 -- c_addr2 u2        gforth
 c_addr2 = getenv(cstr(c_addr1,u1,1));  c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2=strlen(c_addr2);  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 popen   c_addr u n -- wfileid   own  open-pipe       c_addr u ntype -- wfileid wior  gforth  open_pipe
 static char* mode[2]={"r","w"}; /* !! should we use FAM here? */  wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
 wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]); /* ~ expansion of 1st arg? */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 pclose  wfileid -- wior         own  close-pipe      wfileid -- wior         gforth  close_pipe
 wior=pclose((FILE *)wfileid); /* !! what to do with the result */  wior = IOR(pclose((FILE *)wfileid)==-1);
   
 time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
 struct timeval time1;  struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
 gettimeofday(&time1,&zone1);  gettimeofday(&time1,&zone1);
 ltime=localtime(&time1.tv_sec);  ltime=localtime((time_t *)&time1.tv_sec);
 nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
 nmonth=ltime->tm_mon+1;  nmonth=ltime->tm_mon+1;
 nday  =ltime->tm_mday;  nday  =ltime->tm_mday;
Line 808 
Line 1008 
 (void)select(0,0,0,0,&timeout);  (void)select(0,0,0,0,&timeout);
   
 allocate        u -- a_addr wior        memory  allocate        u -- a_addr wior        memory
 a_addr = (Cell *)malloc(u);  a_addr = (Cell *)malloc(u?u:1);
 wior = IOR(a_addr==NULL);  wior = IOR(a_addr==NULL);
   
 free            a_addr -- wior          memory  free            a_addr -- wior          memory
Line 819 
Line 1019 
 ""Change the size of the allocated area at @i{a_addr1} to @i{u}  ""Change the size of the allocated area at @i{a_addr1} to @i{u}
 address units, possibly moving the contents to a different  address units, possibly moving the contents to a different
 area. @i{a_addr2} is the address of the resulting area. If  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{a_addr2} is 0, Gforth's (but not the standard) @code{resize}
 @code{allocate}s @i{u} address units.""  @code{allocate}s @i{u} address units.""
 /* the following check is not necessary on most OSs, but it is needed  /* the following check is not necessary on most OSs, but it is needed
    on SunOS 4.1.2. */     on SunOS 4.1.2. */
Line 865 
Line 1065 
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (hashkey)       c_addr u1 -- u2         new     paren_hashkey  (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 1099 
   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 924 
Line 1124 
   
 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(tilde_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(tilde_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);
Line 946 
Line 1146 
   
 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 1006 
Line 1206 
     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);
   
Line 1033 
Line 1238 
   wior=0;    wior=0;
 }  }
   
 comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)  stdout  -- wfileid      gforth
 comparisons(f0, r, f_zero_, r, 0., float, new, float, new)  wfileid = (Cell)stdout;
   
   stderr  -- wfileid      gforth
   wfileid = (Cell)stderr;
   
   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 1106 
Line 1326 
   
 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 1143 
Line 1367 
 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 1283 
Line 1507 
  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);
   
   dfloats         n1 -- n2        float-ext       d_floats
   n2 = n1*sizeof(DFloat);
   
   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 ;
   
   sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned
   sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
   :
    [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
   
   dfaligned       c_addr -- df_addr       float-ext       d_f_aligned
   df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
   :
    [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
   \ The following words access machine/OS/installation-dependent
   \   Gforth internals
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 >body           xt -- a_addr    core    to_body  >body           xt -- a_addr    core    to_body
 a_addr = PFA(xt);  a_addr = PFA(xt);
   
 >code-address           xt -- c_addr            new     to_code_address  >code-address           xt -- c_addr            gforth  to_code_address
 ""c_addr is the code address of the word xt""  ""c_addr is the code address of the word xt""
 /* !! This behaves installation-dependently for DOES-words */  /* !! This behaves installation-dependently for DOES-words */
 c_addr = CODE_ADDRESS(xt);  c_addr = CODE_ADDRESS(xt);
   
 >does-code      xt -- a_addr            new     to_does_code  >does-code      xt -- a_addr            gforth  to_does_code
 ""If xt ist the execution token of a defining-word-defined word,  ""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  a_addr is the start of the Forth code after the DOES>; Otherwise the
 behaviour is undefined""  behaviour is undefined""
Line 1304 
Line 1554 
 defining-word-defined */  defining-word-defined */
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
   
 code-address!           n xt -- new     code_address_store  code-address!           c_addr xt --            gforth  code_address_store
 ""Creates a code field with code address c_addr at xt""  ""Creates a code field with code address c_addr at xt""
 MAKE_CF(xt, symbols[CF(n)]);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,PFA(0));  CACHE_FLUSH(xt,PFA(0));
   
 does-code!      a_addr xt --            new     does_code_store  does-code!      a_addr xt --            gforth  does_code_store
 ""creates a code field at xt for a defining-word-defined word; a_addr  ""creates a code field at xt for a defining-word-defined word; a_addr
 is the start of the Forth code after DOES>""  is the start of the Forth code after DOES>""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,PFA(0));  CACHE_FLUSH(xt,PFA(0));
   
 does-handler!   a_addr --       new     does_jump_store  does-handler!   a_addr --       gforth  does_handler_store
 ""creates a DOES>-handler at address a_addr. a_addr usually points  ""creates a DOES>-handler at address a_addr. a_addr usually points
 just behind a DOES>.""  just behind a DOES>.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
   
 /does-handler   -- n    new     slash_does_handler  /does-handler   -- n    gforth  slash_does_handler
 ""the size of a does-handler (includes possible padding)""  ""the size of a does-handler (includes possible padding)""
 /* !! a constant or environmental query might be better */  /* !! a constant or environmental query might be better */
 n = DOES_HANDLER_SIZE;  n = DOES_HANDLER_SIZE;
   
 toupper c1 -- c2        new  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);
   
   toupper c1 -- c2        gforth
 c2 = toupper(c1);  c2 = toupper(c1);
   
 \ local variable implementation primitives  \ local variable implementation primitives
 @local#         -- w    new     fetch_local_number  @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 1346 
Line 1608 
 @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  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 1356 
Line 1618 
 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  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 1377 
Line 1639 
 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  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  up!     a_addr --       gforth  up_store
 up0=up=(char *)a_addr;  up0=up=(char *)a_addr;
   
 call-c  w --    new     call_c  call-c  w --    gforth  call_c
 ""Call the C function pointed to by @i{w}. The C function has to  ""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 gloabl  access the stack itself. The stack pointers are exported in the gloabl
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{FP}.""
Line 1406 
Line 1668 
 IF_TOS(TOS=sp[0]);  IF_TOS(TOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_FTOS(FTOS=fp[0]);
   
 strerror        n -- c_addr u   new  strerror        n -- c_addr u   gforth
 c_addr = strerror(n);  c_addr = strerror(n);
 u = strlen(c_addr);  u = strlen(c_addr);
   
   strsignal       n -- c_addr u   gforth
   c_addr = strsignal(n);
   u = strlen(c_addr);

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help