[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.21 and 1.64

version 1.21, Tue Oct 18 15:51:21 1994 UTC version 1.64, Fri Feb 14 20:47:26 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:  
 \  \
 \ forth name    stack effect    category        [pronounciation]  \
   \ This file contains primitive specifications in the following format:
   \
   \ forth name    stack effect    category        [pronunciation]
 \ [""glossary entry""]  \ [""glossary entry""]
 \ C code  \ C code
 \ [:  \ [:
 \ Forth code]  \ Forth code]
 \  \
 \ The pronounciataion 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 automagically translated into C-code for the  \
 \ interpreter and into some other files. The forth name of a word is  \ These specifications are automatically translated into C-code for the
 \ automatically turned into upper case. 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
 \ compilers, so they will need to compile only the important words.  \ compilers, so they will need to compile only the important words.
Line 28 
Line 54 
 \ stack. Use different names on both sides of the '--', if you change a  \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).  \ value (some stores to the stack are optimized away).
 \  \
   \
   \
 \ The stack variables have the following types:  \ The stack variables have the following types:
   \
 \ name matches  type  \ name matches  type
 \ f.*           Bool  \ f.*           Bool
 \ c.*           Char  \ c.*           Char
Line 46 
Line 75 
 \ wid.*         WID  \ wid.*         WID
 \ f83name.*     F83Name *  \ f83name.*     F83Name *
 \  \
   \
   \
 \ In addition the following names can be used:  \ In addition the following names can be used:
 \ ip    the instruction pointer  \ ip    the instruction pointer
 \ sp    the data stack pointer  \ sp    the data stack pointer
 \ rp    the parameter stack pointer  \ rp    the parameter stack pointer
   \ lp    the locals stack pointer
 \ NEXT  executes NEXT  \ NEXT  executes NEXT
 \ cfa  \ cfa
 \ NEXT1 executes NEXT1  \ NEXT1 executes NEXT1
 \ FLAG(x)       makes a Forth flag from a C flag  \ FLAG(x)       makes a Forth flag from a C flag
 \  \
   \
   \
 \ Percentages in comments are from Koopmans book: average/maximum use  \ Percentages in comments are from Koopmans book: average/maximum use
 \ (taken from four, not very representattive benchmarks)  \ (taken from four, not very representative benchmarks)
   \
   \
 \  \
 \ To do:  \ To do:
 \ make sensible error returns for file words  
 \  \
 \ throw execute, cfa and NEXT1 out?  \ throw execute, cfa and NEXT1 out?
 \ macroize *ip, ip++, *ip++ (pipelining)?  \ macroize *ip, ip++, *ip++ (pipelining)?
Line 68 
Line 103 
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   
 noop    --              fig  noop    --              gforth
 ;  ;
 :  :
  ;   ;
   
 lit     -- w            fig  lit     -- w            gforth
 w = (Cell)*ip++;  w = (Cell)NEXT_INST;
   INC_IP(1);
   :
    r> dup @ swap cell+ >r ;
   
   execute         xt --           core
   ip=IP;
   IF_TOS(TOS = sp[0]);
   EXEC(xt);
   
 execute         xt --           core,fig  perform         a_addr --       gforth
 cfa = xt;  ""equivalent to @code{@ execute}""
   /* and pfe */
   ip=IP;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 NEXT1;  EXEC(*(Xt *)a_addr);
   :
    @ execute ;
   
 branch-lp+!#    --      new     branch_lp_plus_store_number  \+has-locals [IF]
   
   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 += (int)(ip[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 branch  --              fig  \+[THEN]
   
   branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((int)ip)+(int)*ip);  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
   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 close 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
 $3    goto branch;  $3      ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
           NEXT_P0;
           NEXT;
 }  }
 else  else
     ip++;      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;
 }  }
 else  else
     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)
   
   \+has-xconds [IF]
   
   ?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);
   
   \+[THEN]
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
 )  ,:
    r> r> dup 1- >r
 condbranch((loop),--            fig     paren_loop,   IF dup @ + >r ELSE cell+ >r THEN ;)
 int index = *rp+1;  
 int limit = rp[1];  condbranch((loop),--            gforth  paren_loop,
   Cell index = *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 */
 int 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 */
 int olddiff = index-rp[1];  Cell olddiff = index-rp[1];
 #ifdef 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 ((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 ;)
   
   \+has-xconds [IF]
   
   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).""
 /* !! check this thoroughly */  /* !! check this thoroughly */
 int index = *rp;  Cell index = *rp;
 int diff = index-rp[1];  Cell diff = index-rp[1];
 int newdiff = diff+n;  Cell newdiff = diff+n;
 if (n<0) {  if (n<0) {
     diff = -diff;      diff = -diff;
     newdiff = -newdiff;      newdiff = -newdiff;
Line 168 
Line 279 
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,)
   
   \+[THEN]
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
Line 182 
Line 295 
 :  :
  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> swap rot >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 197 
Line 310 
     goto branch;      goto branch;
     }      }
 else {  else {
     ip++;      INC_IP(1);
 }  }
   :
     2dup =
     IF   r> swap rot >r >r
          dup @ + >r
     ELSE r> swap rot >r >r
          cell+ >r
     THEN ;                                \ --> CORE-EXT
   
 i       -- n            core,fig  \+has-xconds [IF]
 n = *rp;  
   
 j       -- n            core  (+do)   nlimit nstart --        gforth  paren_plus_do
 n = rp[2];  *--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 ;
   
 \ digit is high-level: 0/0%  (-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 ;
   
 (emit)  c --            fig     paren_emit  \+[THEN]
 putchar(c);  
 emitcounter++;  
   
 (type)  c_addr n --     fig     paren_type  
 fwrite(c_addr,sizeof(Char),n,stdout);  
 emitcounter += n;  
   
 (key)   -- n            fig     paren_key  i       -- n            core
 fflush(stdout);  n = *rp;
 /* !! noecho */  :
 n = key();   rp@ cell+ @ ;
   
 key?    -- n            fig     key_q  i'      -- w            gforth          i_tick
 fflush(stdout);  ""loop end value""
 n = key_query;  w = rp[1];
   :
    rp@ cell+ cell+ @ ;
   
 cr      --              fig  j       -- n            core
 puts("");  n = rp[2];
 :  :
  $0A emit ;   rp@ cell+ cell+ cell+ @ ;
   
   \ digit is high-level: 0/0%
   
 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 257 
Line 449 
  ?DO  dup I c!  LOOP  drop ;   ?DO  dup I c!  LOOP  drop ;
   
 compare         c_addr1 u1 c_addr2 u2 -- n      string  compare         c_addr1 u1 c_addr2 u2 -- n      string
   ""Compare the strings lexicographically. If they are equal, n is 0; if
   the first string is smaller, n is -1; if the first string is larger, n
   is 1. Currently this is based on the machine's character
   comparison. In the future, this may change to considering the current
   locale and its collation order.""
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
 if (n==0)  if (n==0)
   n = u1-u2;    n = u1-u2;
Line 284 
Line 481 
  ?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 322 
Line 515 
 :  :
  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 370 
Line 570 
 :  :
  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 399 
Line 599 
 2/      n1 -- n2                core            two_slash  2/      n1 -- n2                core            two_slash
 /* !! is this still correct? */  /* !! is this still correct? */
 n2 = n1>>1;  n2 = n1>>1;
   :
    dup U-HIGHBIT and IF 1 ELSE 0 THEN
    [ bits/byte cell * 1- ] literal
    0 DO 2* swap dup 2* >r U-HIGHBIT and
        IF 1 ELSE 0 THEN or r> swap
    LOOP nip ;
   
 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 410 
Line 621 
   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 421 
Line 643 
   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 436 
Line 663 
   
 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 MINI
      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<  : d2*+ ( ud n -- ud+n c )
   IF    2drop rot     over MINI
   ELSE  dnegate  d+  rot 1+  THEN ;     and >r >r 2dup d+ swap r> + swap r> ;
   
 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;
   :
    invert swap invert and invert ;
   
 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
 w2 = ~w1;  w2 = ~w1;
 :  :
  -1 xor ;   MAXU xor ;
   
 rshift  u1 n -- u2              core  rshift  u1 n -- u2              core
   u2 = u1>>n;    u2 = u1>>n;
   :
       0 ?DO 2/ MAXI and LOOP ;
   
 lshift  u1 n -- u2              core  lshift  u1 n -- u2              core
   u2 = u1<<n;    u2 = u1<<n;
   :
       0 ?DO 2* LOOP ;
   
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,  define(comparisons,
 $1=     $2 -- f         $6      $3equals  $1=     $2 -- f         $6      $3equals
 f = FLAG($4==$5);  f = FLAG($4==$5);
   :
       [ char $1x char 0 = [IF]
           ] IF false ELSE true THEN [
       [ELSE]
           ] xor 0= [
       [THEN] ] ;
   
 $1<>    $2 -- f         $7      $3different  $1<>    $2 -- f         $7      $3different
 /* use != as alias ? */  
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
   :
       [ char $1x char 0 = [IF]
           ] IF true ELSE false THEN [
       [ELSE]
           ] xor 0<> [
       [THEN] ] ;
   
 $1<     $2 -- f         $8      $3less  $1<     $2 -- f         $8      $3less
 f = FLAG($4<$5);  f = FLAG($4<$5);
   :
       [ char $1x char 0 = [IF]
           ] MINI and 0<> [
       [ELSE] char $1x char u = [IF]
           ]   2dup xor 0<  IF nip ELSE - THEN 0<  [
           [ELSE]
               ] MINI xor >r MINI xor r> u< [
           [THEN]
       [THEN] ] ;
   
 $1>     $2 -- f         $9      $3greater  $1>     $2 -- f         $9      $3greater
 f = FLAG($4>$5);  f = FLAG($4>$5);
   :
       [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
       $1< ;
   
 $1<=    $2 -- f         new     $3less_or_equal  $1<=    $2 -- f         gforth  $3less_or_equal
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
   :
       $1> 0= ;
   
 $1>=    $2 -- f         new     $3greater_or_equal  $1>=    $2 -- f         gforth  $3greater_or_equal
 f = FLAG($4>=$5);  f = FLAG($4>=$5);
   :
       [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
       $1<= ;
   
 )  )
   
 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
   
   )
   
   \+has-dcomps [IF]
   
   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)
   
   \+[THEN]
   
 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  \+has-floats [IF]
   
   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      --              core    exit  \+[THEN]
   
   ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
   NEXT_P0;
   
 >r      w --            core,fig        to_r  >r      w --            core    to_r
 *--rp = w;  *--rp = w;
   :
    (>r) ;
   : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
   
 r>      -- w            core,fig        r_from  r>      -- w            core    r_from
 w = *rp++;  w = *rp++;
   :
    rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
   Create (rdrop) ' ;s A,
   
 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
   :
   [ defined? (swap) [IF] ]
       (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
   Variable (rot)
   [ELSE] ]
       >r swap r> swap ;
   [THEN]
   
 -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 675 
Line 1032 
   
 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;
   :
   [ bigendian [IF] ]
       [ cell>bit 4 = [IF] ]
           dup [ 0 cell - ] Literal and @ swap 1 and
           IF  $FF and  ELSE  8>>  THEN  ;
       [ [ELSE] ]
           dup [ cell 1- ] literal and
           tuck - @ swap [ cell 1- ] literal xor
           0 ?DO 8>> LOOP $FF and
       [ [THEN] ]
   [ [ELSE] ]
       [ cell>bit 4 = [IF] ]
           dup [ 0 cell - ] Literal and @ swap 1 and
           IF  8>>  ELSE  $FF and  THEN
       [ [ELSE] ]
           dup [ cell  1- ] literal and
           tuck - @ swap
           0 ?DO 8>> LOOP 255 and
       [ [THEN] ]
   [ [THEN] ]
   ;
   : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
   
 c!      c c_addr --             fig     cstore  c!      c c_addr --             core    cstore
 *c_addr = c;  *c_addr = c;
   :
   [ bigendian [IF] ]
       [ cell>bit 4 = [IF] ]
           tuck 1 and IF  $FF and  ELSE  8<<  THEN >r
           dup -2 and @ over 1 and cells masks + @ and
           r> or swap -2 and ! ;
           Create masks $00FF , $FF00 ,
       [ELSE] ]
           dup [ cell 1- ] literal and dup
           [ cell 1- ] literal xor >r
           - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
           rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
       [THEN]
   [ELSE] ]
       [ cell>bit 4 = [IF] ]
           tuck 1 and IF  8<<  ELSE  $FF and  THEN >r
           dup -2 and @ over 1 and cells masks + @ and
           r> or swap -2 and ! ;
           Create masks $FF00 , $00FF ,
       [ELSE] ]
           dup [ cell 1- ] literal and dup >r
           - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
           rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
       [THEN]
   [THEN]
   : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;
   
 2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
 a_addr[0] = w2;  a_addr[0] = w2;
Line 710 
Line 1125 
 :  :
  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;
 :  :
  [ cell ] Literal + ;   cell + ;
   
 cells   n1 -- n2                core  cells   n1 -- n2                core
 n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
 :  :
  [ cell ]   [ cell
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ drop ] ;   drop ] ;
   
 char+   c_addr1 -- c_addr2      core    care_plus  char+   c_addr1 -- c_addr2      core    care_plus
 c_addr2 = c_addr1 + 1;  c_addr2 = c_addr1 + 1;
 :  :
  1+ ;   1+ ;
   
 chars   n1 -- n2                core    cares  (chars)         n1 -- n2        gforth  paren_cares
 n2 = n1 * sizeof(Char);  n2 = n1 * sizeof(Char);
 :  :
  ;   ;
Line 748 
Line 1156 
 :  :
  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);  
   
 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 = a_addr==NULL;    /* !! Define a return code */  
   
 free            a_addr -- wior          memory  
 free(a_addr);  
 wior = 0;  
   
 resize          a_addr1 u -- a_addr2 wior       memory  
 a_addr2 = realloc(a_addr1, u);  
 wior = 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;
 :  :
  BEGIN  dup  WHILE      BEGIN  dup WHILE  (find-samelen)  dup  WHILE
         >r dup r@ cell+ c@ $1F and =          >r 2dup r@ cell+ char+ capscomp  0=
         IF  2dup r@ cell+ char+ capscomp  0=          IF  2drop r>  EXIT  THEN
             IF  2drop r>  EXIT  THEN  THEN  
         r> @          r> @
  REPEAT  nip nip ;      REPEAT  THEN  nip nip ;
   : (find-samelen) ( u f83name1 -- u f83name2/0 )
       BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
   
   \+has-hash [IF]
   
 (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind  (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
 F83Name *f83name1;  F83Name *f83name1;
Line 817 
Line 1180 
 {  {
    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 832 
Line 1195 
         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+=(int)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 866 
Line 1252 
   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  \+[THEN]
   
   (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 886 
Line 1274 
  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]
   
   (key)   -- n            gforth  paren_key
   fflush(stdout);
   /* !! noecho */
   n = key();
   
   key?    -- n            facility        key_q
   fflush(stdout);
   n = key_query;
   
   stdout  -- wfileid      gforth
   wfileid = (Cell)stdout;
   
   stderr  -- wfileid      gforth
   wfileid = (Cell)stderr;
   
   form    -- urows ucols  gforth
   ""The number of lines and columns in the terminal. These numbers may change
   with the window size.""
   /* 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;
   
   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 = FILEIO(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 =  FILEEXIST(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
 int     fd;  Cell    fd;
 fd = creat(cstr(c_addr, u, 1), 0644);  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]);
   assert(w2 != NULL);    wior = IOR(w2 == 0);
   wior = 0;  
 } else {  } else {
   assert(fd == -1);  
   wior = FILEIO(fd);  
   w2 = 0;    w2 = 0;
     wior = IOR(1);
 }  }
   
 delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file
 wior = FILEEXIST(unlink(cstr(c_addr, u, 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 = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));  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 = 0; /* !! or wior = FLAG(ud<0) */  wior = IOR(UD2LONG(ud)==-1);
   
 reposition-file ud wfileid -- wior      file    reposition_file  reposition-file ud wfileid -- wior      file    reposition_file
 wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));  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 = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));  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 = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));  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 */
 u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);  u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
 wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));  wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
 /* !! who performs clearerr((FILE *)wfileid); ? */  /* !! is the value of ferror errno-compatible? */
   if (wior)
     clearerr((FILE *)wfileid);
   
 read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line  read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line
 /*  /*
Line 953 
Line 1537 
 */  */
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  if ((flag=FLAG(!feof((FILE *)wfileid) &&
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {                 fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
   wior=FILEIO(ferror((FILE *)wfileid));    wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */
     if (wior)
       clearerr((FILE *)wfileid);
   u2 = strlen(c_addr);    u2 = strlen(c_addr);
   u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));    u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
 }  }
Line 962 
Line 1548 
   u2=0;    u2=0;
 }  }
   
   \+[THEN]  has-files [IF] -1 [ELSE] has-os [THEN] [IF]
   
 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 */
 {  {
   int 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)
       clearerr((FILE *)wfileid);
 }  }
   
   emit-file       c wfileid -- wior       gforth  emit_file
   wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
   if (wior)
     clearerr((FILE *)wfileid);
   
   \+[THEN]  has-files [IF]
   
 flush-file      wfileid -- wior         file-ext        flush_file  flush-file      wfileid -- wior         file-ext        flush_file
 wior = FILEIO(fflush((FILE *) wfileid));  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;
   }
   
   \+[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 1029 
Line 1661 
 r3 = r1/r2;  r3 = r1/r2;
   
 f**             r1 r2 -- r3     float-ext       f_star_star  f**             r1 r2 -- r3     float-ext       f_star_star
   ""@i{r3} is @i{r1} raised to the @i{r2}th power""
 r3 = pow(r1,r2);  r3 = pow(r1,r2);
   
 fnegate         r1 -- r2        float  fnegate         r1 -- r2        float
Line 1044 
Line 1677 
   
 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 1051 
Line 1688 
 n2 = n1*sizeof(Float);  n2 = n1*sizeof(Float);
   
 floor           r1 -- r2        float  floor           r1 -- r2        float
   ""round towards the next smaller integral value, i.e., round toward negative infinity""
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround          r1 -- r2        float  fround          r1 -- r2        float
   ""round to the nearest integral value""
 /* !! unclear wording */  /* !! unclear wording */
   #ifdef HAVE_RINT
 r2 = rint(r1);  r2 = rint(r1);
   #else
   r2 = floor(r1+0.5);
   /* !! This is not quite true to the rounding rules given in the standard */
   #endif
   
 fmax            r1 r2 -- r3     float  fmax            r1 r2 -- r3     float
 if (r1<r2)  if (r1<r2)
Line 1072 
Line 1716 
   
 represent               r c_addr u -- n f1 f2   float  represent               r c_addr u -- n f1 f2   float
 char *sig;  char *sig;
 int flag;  Cell flag;
 int decpt;  Cell decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, (int *)&decpt, (int *)&flag);
 n=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);
 memmove(c_addr,sig,u);  memmove(c_addr,sig,u);
Line 1085 
Line 1729 
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  char *number=cstr(c_addr, u, 1);
 char *endconv;  char *endconv;
   while(isspace(number[--u]) && u>0);
   switch(number[u])
   {
      case 'd':
      case 'D':
      case 'e':
      case 'E':  break;
      default :  u++; break;
   }
   number[u]='\0';
 r=strtod(number,&endconv);  r=strtod(number,&endconv);
 if((flag=FLAG(!(int)*endconv)))  if((flag=FLAG(!(Cell)*endconv)))
 {  {
         IF_FTOS(fp[0] = FTOS);          IF_FTOS(fp[0] = FTOS);
         fp += -1;          fp += -1;
Line 1096 
Line 1750 
 {  {
         *endconv='E';          *endconv='E';
         r=strtod(number,&endconv);          r=strtod(number,&endconv);
         if((flag=FLAG(!(int)*endconv)))     if((flag=FLAG(!(Cell)*endconv)))
         {          {
                 IF_FTOS(fp[0] = FTOS);                  IF_FTOS(fp[0] = FTOS);
                 fp += -1;                  fp += -1;
Line 1117 
Line 1771 
 r2 = atan(r1);  r2 = atan(r1);
   
 fatan2          r1 r2 -- r3     float-ext  fatan2          r1 r2 -- r3     float-ext
   ""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably
   intends this to be the inverse of @code{fsincos}. In gforth it is.""
 r3 = atan2(r1,r2);  r3 = atan2(r1,r2);
   
 fcos            r1 -- r2        float-ext  fcos            r1 -- r2        float-ext
Line 1126 
Line 1782 
 r2 = exp(r1);  r2 = exp(r1);
   
 fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
 r2 =  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 #ifdef HAS_EXPM1  #ifdef HAVE_EXPM1
         expm1(r1);  extern double expm1(double);
   r2 = expm1(r1);
 #else  #else
         exp(r1)-1;  r2 = exp(r1)-1.;
 #endif  #endif
   
 fln             r1 -- r2        float-ext  fln             r1 -- r2        float-ext
 r2 = log(r1);  r2 = log(r1);
   
 flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
 r2 =  ""@i{r2}=ln(@i{r1}+1)""
 #ifdef HAS_LOG1P  #ifdef HAVE_LOG1P
         log1p(r1);  extern double log1p(double);
   r2 = log1p(r1);
 #else  #else
 log(r1+1);  r2 = log(r1+1.);
 #endif  #endif
   
 flog            r1 -- r2        float-ext  flog            r1 -- r2        float-ext
   ""the decimal logarithm""
 r2 = log10(r1);  r2 = log10(r1);
   
   falog           r1 -- r2        float-ext
   ""@i{r2}=10**@i{r1}""
   extern double pow10(double);
   r2 = pow10(r1);
   
 fsin            r1 -- r2        float-ext  fsin            r1 -- r2        float-ext
 r2 = sin(r1);  r2 = sin(r1);
   
 fsincos         r1 -- r2 r3     float-ext  fsincos         r1 -- r2 r3     float-ext
   ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
 r2 = sin(r1);  r2 = sin(r1);
 r3 = cos(r1);  r3 = cos(r1);
   
Line 1159 
Line 1824 
   
 ftan            r1 -- r2        float-ext  ftan            r1 -- r2        float-ext
 r2 = tan(r1);  r2 = tan(r1);
   :
    fsincos f/ ;
   
 \ The following words access machine/OS/installation-dependent ANSI  fsinh           r1 -- r2        float-ext
 \   figForth internals  r2 = sinh(r1);
 \ !! how about environmental queries DIRECT-THREADED,  :
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */   fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
   
 >body           xt -- a_addr    core    to_body  fcosh           r1 -- r2        float-ext
 a_addr = PFA(xt);  r2 = cosh(r1);
   :
    fexp fdup 1/f f+ f2/ ;
   
 >code-address           xt -- c_addr            new     to_code_address  ftanh           r1 -- r2        float-ext
 ""c_addr is the code address of the word xt""  r2 = tanh(r1);
 /* !! This behaves installation-dependently for DOES-words */  :
 c_addr = CODE_ADDRESS(xt);   f2* fexpm1 fdup 2. d>f f+ f/ ;
   
 >does-code      xt -- a_addr            new     to_does_code  fasinh          r1 -- r2        float-ext
 ""If xt ist the execution token of a defining-word-defined word,  r2 = asinh(r1);
 a_addr is the start of the Forth code after the DOES>; Otherwise the  :
 behaviour is uundefined""   fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
 /* !! 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  facosh          r1 -- r2        float-ext
 ""Creates a code field with code address c_addr at xt""  r2 = acosh(r1);
 MAKE_CF(xt, symbols[CF(n)]);  :
 CACHE_FLUSH(xt,PFA(0));   fdup fdup f* 1. d>f f- fsqrt f+ fln ;
   
 does-code!      a_addr xt --            new     does_code_store  fatanh          r1 -- r2        float-ext
 ""creates a code field at xt for a defining-word-defined word; a_addr  r2 = atanh(r1);
 is the start of the Forth code after DOES>""  :
 MAKE_DOES_CF(xt, a_addr);   fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
 CACHE_FLUSH(xt,PFA(0));   r> IF  fnegate  THEN ;
   
 does-handler!   a_addr --       new     does_jump_store  sfloats         n1 -- n2        float-ext       s_floats
 ""creates a DOES>-handler at address a_addr. a_addr usually points  n2 = n1*sizeof(SFloat);
 just behind a DOES>.""  
 MAKE_DOES_HANDLER(a_addr);  
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  
   
 /does-handler   -- n    new     slash_does_handler  dfloats         n1 -- n2        float-ext       d_floats
 ""the size of a does-handler (includes possible padding)""  n2 = n1*sizeof(DFloat);
 /* !! a constant or environmental query might be better */  
 n = DOES_HANDLER_SIZE;  
   
 toupper c1 -- c2        new  sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned
 c2 = toupper(c1);  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,
   \   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]
 w = *(Cell *)(lp+(int)(*ip++));  
   @local#         -- w    gforth  fetch_local_number
   w = *(Cell *)(lp+(Cell)NEXT_INST);
   INC_IP(1);
   
 @local0 -- w    new     fetch_local_zero  @local0 -- w    new     fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));  w = *(Cell *)(lp+0*sizeof(Cell));
Line 1222 
Line 1898 
 @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]
 r = *(Float *)(lp+(int)(*ip++));  
   f@local#        -- r    gforth  f_fetch_local_number
   r = *(Float *)(lp+(Cell)NEXT_INST);
   INC_IP(1);
   
 f@local0        -- r    new     f_fetch_local_zero  f@local0        -- r    new     f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));  r = *(Float *)(lp+0*sizeof(Float));
Line 1231 
Line 1910 
 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+(int)(*ip++));  c_addr = (Char *)(lp+(Cell)NEXT_INST);
   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""
 lp += (int)(*ip++);  lp += (Cell)NEXT_INST;
   INC_IP(1);
   
 lp-     --      new     minus_four_lp_plus_store  lp-     --      new     minus_four_lp_plus_store
 lp += -sizeof(Cell);  lp += -sizeof(Cell);
Line 1250 
Line 1933 
 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
   
   up!     a_addr --       gforth  up_store
 up0=up=(char *)a_addr;  up0=up=(char *)a_addr;
   :
    up ! ;
   Variable UP

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help