Diff for /gforth/prim between versions 1.13 and 1.87

version 1.13, 1998/10/25 23:15:46 version 1.87, 2001/12/25 16:55:10
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 Line 16
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
Line 26 Line 26
 \   \ 
 \ This file contains primitive specifications 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""]
 \ C code  \ C code
 \ [:  \ [:
 \ Forth code]  \ Forth code]
 \   \ 
 \ prims2x is pedantic about tabs vs. blanks. The fields of the first  \ Note: Fields in brackets are optional.  Word specifications have to
 \ line of a primitive are separated by tabs, the stack items in a  \ be separated by at least one empty line
 \ stack effect by blanks.  
 \  \
 \ Both pronounciation and stack items (in the stack effect) must  \ Both pronounciation and stack items (in the stack effect) must
 \ conform to the C name syntax or the C compiler will complain.  \ conform to the C identifier syntax or the C compiler will complain.
 \   \ If you don't have a pronounciation field, the Forth name is used,
   \ and has to conform to the C identifier syntax.
 \   \ 
 \ These specifications 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
Line 72 Line 72
 \ df_.*         DFloat *  \ df_.*         DFloat *
 \ sf_.*         SFloat *  \ sf_.*         SFloat *
 \ xt.*          XT  \ xt.*          XT
 \ wid.*         WID  
 \ f83name.*     F83Name *  \ f83name.*     F83Name *
   
   \E stack data-stack   sp Cell
   \E stack fp-stack     fp Float
   \E stack return-stack rp Cell
   \E
   \E get-current prefixes set-current
   \E 
   \E s" Bool"             single data-stack type-prefix f
   \E s" Char"             single data-stack type-prefix c
   \E s" Cell"             single data-stack type-prefix n
   \E s" Cell"             single data-stack type-prefix w
   \E s" UCell"            single data-stack type-prefix u
   \E s" DCell"            double data-stack type-prefix d
   \E s" UDCell"           double data-stack type-prefix ud
   \E s" Float"            single fp-stack   type-prefix r
   \E s" Cell *"           single data-stack type-prefix a_
   \E s" Char *"           single data-stack type-prefix c_
   \E s" Float *"          single data-stack type-prefix f_
   \E s" DFloat *"         single data-stack type-prefix df_
   \E s" SFloat *"         single data-stack type-prefix sf_
   \E s" Xt"               single data-stack type-prefix xt
   \E s" struct F83Name *" single data-stack type-prefix f83name
   \E s" struct Longname *" single data-stack type-prefix longname
   \E 
   \E return-stack stack-prefix R:
   \E inst-stream  stack-prefix #
   \E 
   \E set-current
   
 \   \ 
 \   \ 
 \   \ 
Line 102 Line 130
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   undefine(`symbols')
   
 noop    --              gforth  \g control
 ;  
   noop    ( -- )          gforth
 :  :
  ;   ;
   
 lit     -- w            gforth  lit     ( #w -- w )             gforth
 w = (Cell)NEXT_INST;  
 INC_IP(1);  
 :  :
  r> dup @ swap cell+ >r ;   r> dup @ swap cell+ >r ;
   
 execute         xt --           core  execute ( xt -- )               core
   ""Perform the semantics represented by the execution token, @i{xt}.""
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(xt);  EXEC(xt);
   
 perform         a_addr --       gforth  perform ( a_addr -- )   gforth
 ""equivalent to @code{@ execute}""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
   
 \+has? glocals [IF]  \fhas? skipbranchprims 0= [IF]
   \+glocals
   
 branch-lp+!#    --      gforth  branch_lp_plus_store_number  branch-lp+!#    ( #ndisp #nlocals -- )  gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  lp += nlocals;
 lp += (Cell)(IP[1]);  SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
 goto branch;  
   \+
 \+[THEN]  
   branch  ( #ndisp -- )           gforth
 branch  --              gforth  SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
 branch:  
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  
 NEXT_P0;  
 :  :
  r> dup @ + >r ;   r> dup @ + >r ;
   
 \ condbranch(forthname,restline,code,forthcode)  \ condbranch(forthname,stackeffect,restline,code,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1      $2  $1 ( `#'ndisp $2 ) $3
 $3      ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  $4      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
         NEXT_P0;  TAIL;
         NEXT;  
 }  }
 else  SUPER_CONTINUE;
     INC_IP(1);  $5
 $4  
   
 \+has? glocals [IF]  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number
 $3    goto branch_adjust_lp;  $4    lp += nlocals;
   SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
   TAIL;
 }  }
 else  SUPER_CONTINUE;
     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]);  
 ,:  ,:
  0= dup     \ !f !f   0= dup     \ !f !f
  r> dup @   \ !f !f IP branchoffset   r> dup @   \ !f !f IP branchoffset
Line 181  if (f==0) { Line 208  if (f==0) {
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  \ we don't need an lp_plus_store version of the ?dup-stuff, because it
 \ is only used in if's (yet)  \ is only used in if's (yet)
   
 \+has? xconds [IF]  \+xconds
   
 ?dup-?branch    f -- f  new     question_dupe_question_branch  ?dup-?branch    ( #ndisp f -- f )       new     question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""  ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {  if (f==0) {
   sp++;    sp++;
   IF_TOS(TOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT_P0;    TAIL;
   NEXT;  
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 ?dup-0=-?branch f --    new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #ndisp f -- ) new     question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
 /* the approach taken here of declaring the word as having the stack  /* 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  effect ( f -- ) and correcting for it in the branch-taken case costs a
Line 203  few cycles in that case, but is easy to Line 228  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT_P0;  
   NEXT;    NEXT;
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 \+[THEN]  
   
 condbranch((next),--            cmFORTH paren_next,  \+
 if ((*rp)--) {  \f[THEN]
   \fhas? skiploopprims 0= [IF]
   
   condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,
   n2=n1-1;
   if (n1) {
 ,:  ,:
  r> r> dup 1- >r   r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)   IF dup @ + >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),--            gforth  paren_loop,  condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
 Cell index = *rp+1;  n2=n1+1;
 Cell limit = rp[1];  if (n2 != nlimit) {
 if (index != limit) {  
     *rp = index;  
 ,:  ,:
  r> r> 1+ r> 2dup =   r> r> 1+ r> 2dup =
  IF >r 1- >r cell+ >r   IF >r 1- >r cell+ >r
  ELSE >r >r dup @ + >r THEN ;)   ELSE >r >r dup @ + >r THEN ;)
   
 condbranch((+loop),n --         gforth  paren_plus_loop,  condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
 Cell index = *rp;  
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = index-rp[1];  Cell olddiff = n1-nlimit;
   n2=n1+n;        
 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 */) {
 #ifdef i386  
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
Line 250  if ((olddiff^(olddiff+n))>=0   /* the li Line 268  if ((olddiff^(olddiff+n))>=0   /* the li
  IF    >r + >r dup @ + >r   IF    >r + >r dup @ + >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+has? xconds [IF]  \+xconds
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
 /* !! check this thoroughly */  UCell olddiff = n1-nlimit;
 Cell index = *rp;  n2=n1-u;
 UCell olddiff = index-rp[1];  
 if (olddiff>u) {  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,  condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,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 */
 Cell index = *rp;  Cell diff = n1-nlimit;
 Cell diff = index-rp[1];  
 Cell newdiff = diff+n;  Cell newdiff = diff+n;
 if (n<0) {  if (n<0) {
     diff = -diff;      diff = -diff;
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
   n2=n1+n;
 if (diff>=0 || newdiff<0) {  if (diff>=0 || newdiff<0) {
 #ifdef i386  
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,)  ,)
   
 \+[THEN]  \+
   
 unloop          --      core  unloop  ( R:w1 R:w2 -- )        core
 rp += 2;  /* !! alias for 2rdrop */
 :  :
  r> rdrop rdrop >r ;   r> rdrop rdrop >r ;
   
 (for)   ncount --               cmFORTH         paren_for  (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 *--rp = 0;  nlimit=0;
 *--rp = ncount;  
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    nlimit nstart --                gforth          paren_do  (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do
 /* or do it in high-level? 0.09/0.23% */  
 *--rp = nlimit;  
 *--rp = nstart;  
 :  :
  r> swap rot >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   nlimit nstart --        gforth  paren_question_do  (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart == nlimit) {  if (nstart == nlimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
Line 325  else { Line 322  else {
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+has? xconds [IF]  \+xconds
   
 (+do)   nlimit nstart --        gforth  paren_plus_do  (+do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_plus_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 347  else { Line 340  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u+do)  ulimit ustart --        gforth  paren_u_plus_do  (u+do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_plus_do
 *--rp = ulimit;  
 *--rp = ustart;  
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 367  else { Line 356  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (-do)   nlimit nstart --        gforth  paren_minus_do  (-do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_minus_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 387  else { Line 372  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u-do)  ulimit ustart --        gforth  paren_u_minus_do  (u-do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_minus_do
 *--rp = ulimit;  
 *--rp = ustart;  
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 407  else { Line 388  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 \+[THEN]  \+
   
 \ don't make any assumptions where the return stack is!!  \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!  \ implement this in machine code if it should run quickly!
   
 i       -- n            core  i       ( R:n -- R:n n )                core
 n = *rp;  
 :  :
 \ rp@ cell+ @ ;  \ rp@ cell+ @ ;
   r> r> tuck >r >r ;    r> r> tuck >r >r ;
   
 i'      -- w            gforth          i_tick  i'      ( R:w R:w2 -- R:w R:w2 w )              gforth          i_tick
 ""loop end value""  
 w = rp[1];  
 :  :
 \ rp@ cell+ cell+ @ ;  \ rp@ cell+ cell+ @ ;
   r> r> r> dup itmp ! >r >r >r itmp @ ;    r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp  variable itmp
   
 j       -- n            core  j       ( R:n R:d1 -- n R:n R:d1 )              core
 n = rp[2];  
 :  :
 \ rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;    r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [IFUNDEF] itmp variable itmp [THEN]
   
 k       -- n            gforth  k       ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )            gforth
 n = rp[4];  
 :  :
 \ rp@ [ 5 cells ] Literal + @ ;  \ rp@ [ 5 cells ] Literal + @ ;
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;    r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [IFUNDEF] itmp variable itmp [THEN]
   
   \f[THEN]
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 move    c_from c_to ucount --           core  \g strings
   
   move    ( c_from c_to ucount -- )               core
   ""Copy the contents of @i{ucount} aus at @i{c-from} to
   @i{c-to}. @code{move} works correctly even if the two areas overlap.""
   /* !! note that the standard specifies addr, not c-addr */
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
 /* make an Ifdef for bsd and others? */  /* make an Ifdef for bsd and others? */
 :  :
  >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;   >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
   
 cmove   c_from c_to u --        string  cmove   ( c_from c_to u -- )    string  c_move
   ""Copy the contents of @i{ucount} characters from data space at
   @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
   from low address to high address; i.e., for overlapping areas it is
   safe if @i{c-to}=<@i{c-from}.""
 while (u-- > 0)  while (u-- > 0)
   *c_to++ = *c_from++;    *c_to++ = *c_from++;
 :  :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
 cmove>  c_from c_to u --        string  c_move_up  cmove>  ( c_from c_to u -- )    string  c_move_up
   ""Copy the contents of @i{ucount} characters from data space at
   @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
   from high address to low address; i.e., for overlapping areas it is
   safe if @i{c-to}>=@i{c-from}.""
 while (u-- > 0)  while (u-- > 0)
   c_to[u] = c_from[u];    c_to[u] = c_from[u];
 :  :
Line 462  while (u-- > 0) Line 453  while (u-- > 0)
  rot over + -rot bounds swap 1-   rot over + -rot bounds swap 1-
  DO  1- dup c@ I c!  -1 +LOOP  drop ;   DO  1- dup c@ I c!  -1 +LOOP  drop ;
   
 fill    c_addr u c --   core  fill    ( c_addr u c -- )       core
   ""Store @i{c} in @i{u} chars starting at @i{c-addr}.""
 memset(c_addr,c,u);  memset(c_addr,c,u);
 :  :
  -rot bounds   -rot bounds
  ?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  ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
 the first string is smaller, n is -1; if the first string is larger, n  the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
 is 1. Currently this is based on the machine's character  is 1. Currently this is based on the machine's character
 comparison. In the future, this may change to considering the current  comparison. In the future, this may change to consider the current
 locale and its collation order.""  locale and its collation order.""
   /* close ' to keep fontify happy */ 
 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 482  if (n<0) Line 475  if (n<0)
 else if (n>0)  else if (n>0)
   n = 1;    n = 1;
 :  :
  rot 2dup - >r min swap -text dup   rot 2dup swap - >r min swap -text dup
  IF    rdrop   IF  rdrop  ELSE  drop r> sgn  THEN ;
  ELSE  drop r@ 0>  : sgn ( n -- -1/0/1 )
        IF    rdrop -1   dup 0= IF EXIT THEN  0< 2* 1+ ;
        ELSE  r> 1 and  
        THEN  
  THEN ;  
   
 -text           c_addr1 u c_addr2 -- n  new     dash_text  -text   ( c_addr1 u c_addr2 -- n )      new     dash_text
 n = memcmp(c_addr1, c_addr2, u);  n = memcmp(c_addr1, c_addr2, u);
 if (n<0)  if (n<0)
   n = -1;    n = -1;
Line 499  else if (n>0) Line 489  else if (n>0)
 :  :
  swap bounds   swap bounds
  ?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  sgn ;
 : -text-flag ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
  dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 toupper c1 -- c2        gforth  toupper ( c1 -- c2 )    gforth
   ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
   is the equivalent upper-case character. All other characters are unchanged.""
 c2 = toupper(c1);  c2 = toupper(c1);
 :  :
  dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;   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
 n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */  n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
 if (n<0)  if (n<0)
   n = -1;    n = -1;
Line 519  else if (n>0) Line 511  else if (n>0)
  ?DO  dup c@ I c@ <>   ?DO  dup c@ I c@ <>
      IF  dup c@ toupper I c@ toupper =       IF  dup c@ toupper I c@ toupper =
      ELSE  true  THEN  WHILE  1+  LOOP  drop 0       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  sgn ;
   
 -trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       ( c_addr u1 -- c_addr u2 )              string  dash_trailing
   ""Adjust the string specified by @i{c-addr, u1} to remove all trailing
   spaces. @i{u2} is the length of the modified string.""
 u2 = u1;  u2 = u1;
 while (u2>0 && c_addr[u2-1] == ' ')  while (u2>0 && c_addr[u2-1] == ' ')
   u2--;    u2--;
Line 529  while (u2>0 && c_addr[u2-1] == ' ') Line 523  while (u2>0 && c_addr[u2-1] == ' ')
  BEGIN  1- 2dup + c@ bl =  WHILE   BEGIN  1- 2dup + c@ bl =  WHILE
         dup  0= UNTIL  ELSE  1+  THEN ;          dup  0= UNTIL  ELSE  1+  THEN ;
   
 /string         c_addr1 u1 n -- c_addr2 u2      string  slash_string  /string ( c_addr1 u1 n -- c_addr2 u2 )  string  slash_string
   ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
   characters from the start of the string.""
 c_addr2 = c_addr1+n;  c_addr2 = c_addr1+n;
 u2 = u1-n;  u2 = u1-n;
 :  :
  tuck - >r + r> dup 0< IF  - 0  THEN ;   tuck - >r + r> dup 0< IF  - 0  THEN ;
   
 +       n1 n2 -- n              core    plus  \g arith
   
   +       ( n1 n2 -- n )          core    plus
 n = n1+n2;  n = n1+n2;
   
 \ PFE-0.9.14 has it differently, but the next release will have it as follows  \ 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  under+  ( n1 n2 n3 -- n n2 )    gforth  under_plus
 ""add @var{n3} to @var{n1} (giving @var{n})""  ""add @i{n3} to @i{n1} (giving @i{n})""
 n = n1+n3;  n = n1+n3;
 :  :
  rot + swap ;   rot + swap ;
   
 -       n1 n2 -- n              core    minus  -       ( n1 n2 -- n )          core    minus
 n = n1-n2;  n = n1-n2;
 :  :
  negate + ;   negate + ;
   
 negate  n1 -- n2                core  negate  ( n1 -- n2 )            core
 /* use minus as alias */  /* use minus as alias */
 n2 = -n1;  n2 = -n1;
 :  :
  invert 1+ ;   invert 1+ ;
   
 1+      n1 -- n2                core            one_plus  1+      ( n1 -- n2 )            core            one_plus
 n2 = n1+1;  n2 = n1+1;
 :  :
  1 + ;   1 + ;
   
 1-      n1 -- n2                core            one_minus  1-      ( n1 -- n2 )            core            one_minus
 n2 = n1-1;  n2 = n1-1;
 :  :
  1 - ;   1 - ;
   
 max     n1 n2 -- n      core  max     ( n1 n2 -- n )  core
 if (n1<n2)  if (n1<n2)
   n = n2;    n = n2;
 else  else
Line 574  else Line 572  else
 :  :
  2dup < IF swap THEN drop ;   2dup < IF swap THEN drop ;
   
 min     n1 n2 -- n      core  min     ( n1 n2 -- n )  core
 if (n1<n2)  if (n1<n2)
   n = n1;    n = n1;
 else  else
Line 582  else Line 580  else
 :  :
  2dup > IF swap THEN drop ;   2dup > IF swap THEN drop ;
   
 abs     n1 -- n2        core  abs     ( n -- u )      core
 if (n1<0)  if (n<0)
   n2 = -n1;    u = -n;
 else  else
   n2 = n1;    u = n;
 :  :
  dup 0< IF negate THEN ;   dup 0< IF negate THEN ;
   
 *       n1 n2 -- n              core    star  *       ( n1 n2 -- n )          core    star
 n = n1*n2;  n = n1*n2;
 :  :
  um* drop ;   um* drop ;
   
 /       n1 n2 -- n              core    slash  /       ( n1 n2 -- n )          core    slash
 n = n1/n2;  n = n1/n2;
 :  :
  /mod nip ;   /mod nip ;
   
 mod     n1 n2 -- n              core  mod     ( n1 n2 -- n )          core
 n = n1%n2;  n = n1%n2;
 :  :
  /mod drop ;   /mod drop ;
   
 /mod    n1 n2 -- n3 n4          core            slash_mod  /mod    ( n1 n2 -- n3 n4 )              core            slash_mod
 n4 = n1/n2;  n4 = n1/n2;
 n3 = n1%n2; /* !! is this correct? look into C standard! */  n3 = n1%n2; /* !! is this correct? look into C standard! */
 :  :
  >r s>d r> fm/mod ;   >r s>d r> fm/mod ;
   
 2*      n1 -- n2                core            two_star  2*      ( n1 -- n2 )            core            two_star
   ""Shift left by 1; also works on unsigned numbers""
 n2 = 2*n1;  n2 = 2*n1;
 :  :
  dup + ;   dup + ;
   
 2/      n1 -- n2                core            two_slash  2/      ( n1 -- n2 )            core            two_slash
 /* !! is this still correct? */  ""Arithmetic shift right by 1.  For signed numbers this is a floored
   division by 2 (note that @code{/} not necessarily floors).""
 n2 = n1>>1;  n2 = n1>>1;
 :  :
  dup MINI and IF 1 ELSE 0 THEN   dup MINI and IF 1 ELSE 0 THEN
Line 626  n2 = n1>>1; Line 626  n2 = n1>>1;
      IF 1 ELSE 0 THEN or r> swap       IF 1 ELSE 0 THEN or r> swap
  LOOP nip ;   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: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 DCell r = fmdiv(d1,n1);  DCell r = fmdiv(d1,n1);
 n2=r.hi;  n2=r.hi;
Line 648  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) Line 648  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
  um/mod   um/mod
  r> 0< IF  swap negate swap  THEN ;   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: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 DCell r = smdiv(d1,n1);  DCell r = smdiv(d1,n1);
 n2=r.hi;  n2=r.hi;
Line 670  if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) Line 670  if (1%-3<0 && (d1<0) != (n1<0) && n2!=0)
  r> r@ xor 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  #ifdef BUGGY_LONG_LONG
 d = mmul(n1,n2);  d = mmul(n1,n2);
 #else  #else
Line 681  d = (DCell)n1 * (DCell)n2; Line 681  d = (DCell)n1 * (DCell)n2;
  2dup swap 0< and >r   2dup swap 0< and >r
  um* r> - r> - ;   um* r> - r> - ;
   
 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  #ifdef BUGGY_LONG_LONG
 ud = ummul(u1,u2);  ud = ummul(u1,u2);
Line 698  ud = (UDCell)u1 * (UDCell)u2; Line 698  ud = (UDCell)u1 * (UDCell)u2;
    over MINI     over MINI
    and >r >r 2dup d+ swap r> + swap r> ;     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
   ""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 UDCell r = umdiv(ud,u1);  UDCell r = umdiv(ud,u1);
 u2=r.hi;  u2=r.hi;
Line 717  u2 = ud%u1; Line 718  u2 = ud%u1;
    over MINI     over MINI
    and >r >r 2dup d+ swap r> + swap r> ;     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  #ifdef BUGGY_LONG_LONG
 d2.lo = d1.lo+n;  d2.lo = d1.lo+n;
 d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);  d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
Line 727  d2 = d1+n; Line 728  d2 = d1+n;
 :  :
  s>d d+ ;   s>d d+ ;
   
 d+      d1 d2 -- d              double  d_plus  d+      ( d1 d2 -- d )          double  d_plus
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d.lo = d1.lo+d2.lo;  d.lo = d1.lo+d2.lo;
 d.hi = d1.hi + d2.hi + (d.lo<d1.lo);  d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
Line 737  d = d1+d2; Line 738  d = d1+d2;
 :  :
  rot + >r tuck + swap over u> r> swap - ;   rot + >r tuck + swap over u> r> swap - ;
   
 d-      d1 d2 -- d              double          d_minus  d-      ( d1 d2 -- d )          double          d_minus
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d.lo = d1.lo - d2.lo;  d.lo = d1.lo - d2.lo;
 d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);  d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
Line 747  d = d1-d2; Line 748  d = d1-d2;
 :  :
  dnegate d+ ;   dnegate d+ ;
   
 dnegate d1 -- d2                double  dnegate ( d1 -- d2 )            double  d_negate
 /* use dminus as alias */  /* use dminus as alias */
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d2 = dnegate(d1);  d2 = dnegate(d1);
Line 757  d2 = -d1; Line 758  d2 = -d1;
 :  :
  invert swap negate tuck 0= - ;   invert swap negate tuck 0= - ;
   
 d2*     d1 -- d2                double          d_two_star  d2*     ( d1 -- d2 )            double          d_two_star
   ""Shift left by 1; also works on unsigned numbers""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d2.lo = d1.lo<<1;  d2.lo = d1.lo<<1;
 d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));  d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
Line 767  d2 = 2*d1; Line 769  d2 = 2*d1;
 :  :
  2dup d+ ;   2dup d+ ;
   
 d2/     d1 -- d2                double          d_two_slash  d2/     ( d1 -- d2 )            double          d_two_slash
   ""Arithmetic shift right by 1.  For signed numbers this is a floored
   division by 2.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d2.hi = d1.hi>>1;  d2.hi = d1.hi>>1;
 d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));  d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
Line 778  d2 = d1>>1; Line 782  d2 = d1>>1;
  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 ;
   
 and     w1 w2 -- w              core  and     ( w1 w2 -- w )          core
 w = w1&w2;  w = w1&w2;
   
 or      w1 w2 -- w              core  or      ( w1 w2 -- w )          core
 w = w1|w2;  w = w1|w2;
 :  :
  invert swap invert and invert ;   invert swap invert and invert ;
   
 xor     w1 w2 -- w              core  xor     ( w1 w2 -- w )          core    x_or
 w = w1^w2;  w = w1^w2;
   
 invert  w1 -- w2                core  invert  ( w1 -- w2 )            core
 w2 = ~w1;  w2 = ~w1;
 :  :
  MAXU xor ;   MAXU xor ;
   
 rshift  u1 n -- u2              core  rshift  ( u1 n -- u2 )          core    r_shift
   ""Logical shift right by @i{n} bits.""
   u2 = u1>>n;    u2 = u1>>n;
 :  :
     0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
   
 lshift  u1 n -- u2              core  lshift  ( u1 n -- u2 )          core    l_shift
   u2 = u1<<n;    u2 = u1<<n;
 :  :
     0 ?DO 2* LOOP ;      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]      [ char $1x char 0 = [IF]
Line 815  f = FLAG($4==$5); Line 820  f = FLAG($4==$5);
         ] xor 0= [          ] xor 0= [
     [THEN] ] ;      [THEN] ] ;
   
 $1<>    $2 -- f         $7      $3different  $1<>    ( $2 -- f )             $7      $3not_equals
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
 :  :
     [ char $1x char 0 = [IF]      [ char $1x char 0 = [IF]
Line 824  f = FLAG($4!=$5); Line 829  f = FLAG($4!=$5);
         ] xor 0<> [          ] xor 0<> [
     [THEN] ] ;      [THEN] ] ;
   
 $1<     $2 -- f         $8      $3less  $1<     ( $2 -- f )             $8      $3less_than
 f = FLAG($4<$5);  f = FLAG($4<$5);
 :  :
     [ char $1x char 0 = [IF]      [ char $1x char 0 = [IF]
Line 836  f = FLAG($4<$5); Line 841  f = FLAG($4<$5);
         [THEN]          [THEN]
     [THEN] ] ;      [THEN] ] ;
   
 $1>     $2 -- f         $9      $3greater  $1>     ( $2 -- f )             $9      $3greater_than
 f = FLAG($4>$5);  f = FLAG($4>$5);
 :  :
     [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]      [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
     $1< ;      $1< ;
   
 $1<=    $2 -- f         gforth  $3less_or_equal  $1<=    ( $2 -- f )             gforth  $3less_or_equal
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
 :  :
     $1> 0= ;      $1> 0= ;
   
 $1>=    $2 -- f         gforth  $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] ]      [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
Line 861  comparisons(u, u1 u2, u_, u1, u2, gforth Line 866  comparisons(u, u1 u2, u_, u1, u2, gforth
   
 \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(dcomparisons,  define(dcomparisons,
 $1=     $2 -- f         $6      $3equals  $1=     ( $2 -- f )             $6      $3equals
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);  f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
 #else  #else
 f = FLAG($4==$5);  f = FLAG($4==$5);
 #endif  #endif
   
 $1<>    $2 -- f         $7      $3different  $1<>    ( $2 -- f )             $7      $3not_equals
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);  f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
 #else  #else
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
 #endif  #endif
   
 $1<     $2 -- f         $8      $3less  $1<     ( $2 -- f )             $8      $3less_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
 #else  #else
 f = FLAG($4<$5);  f = FLAG($4<$5);
 #endif  #endif
   
 $1>     $2 -- f         $9      $3greater  $1>     ( $2 -- f )             $9      $3greater_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
 #else  #else
 f = FLAG($4>$5);  f = FLAG($4>$5);
 #endif  #endif
   
 $1<=    $2 -- f         gforth  $3less_or_equal  $1<=    ( $2 -- f )             gforth  $3less_or_equal
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
 #else  #else
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
 #endif  #endif
   
 $1>=    $2 -- f         gforth  $3greater_or_equal  $1>=    ( $2 -- f )             gforth  $3greater_or_equal
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
 #else  #else
Line 905  f = FLAG($4>=$5); Line 910  f = FLAG($4>=$5);
   
 )  )
   
 \+has? dcomps [IF]  \+dcomps
   
 dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)  dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
 dcomparisons(d0, d, d_zero_, d, DZERO, 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)  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
   ""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2).  This works for
   unsigned and signed numbers (but not a mixture).  Another way to think
   about this word is to consider the numbers as a circle (wrapping
   around from @code{max-u} to 0 for unsigned, and from @code{max-n} to
   min-n for signed numbers); now consider the range from u2 towards
   increasing numbers up to and excluding u3 (giving an empty range if
   u2=u3); if u1 is in this range, @code{within} returns true.""
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
 sp@     -- a_addr               gforth          spat  \g internal
   
   sp@     ( -- a_addr )           gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp+1;
   
 sp!     a_addr --               gforth          spstore  sp!     ( a_addr -- )           gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without spTOS caching */
   
 rp@     -- a_addr               gforth          rpat  rp@     ( -- a_addr )           gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
   
 rp!     a_addr --               gforth          rpstore  rp!     ( a_addr -- )           gforth          rp_store
 rp = a_addr;  rp = a_addr;
   
 \+has? floating [IF]  \+floating
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     ( -- f_addr )   gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
   
 fp!     f_addr --       gforth  fp_store  fp!     ( f_addr -- )   gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 \+[THEN]  \+
   
 ;s      --              gforth  semis  ;s      ( R:w -- )              gforth  semis
 ip = (Xt *)(*rp++);  ""The primitive compiled by @code{EXIT}.""
 NEXT_P0;  SET_IP((Xt *)w);
   
 >r      w --            core    to_r  \g stack
 *--rp = w;  
   >r      ( w -- R:w )            core    to_r
 :  :
  (>r) ;   (>r) ;
 : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;  : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
   
 r>      -- w            core    r_from  r>      ( R:w -- w )            core    r_from
 w = *rp++;  
 :  :
  rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;   rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 Create (rdrop) ' ;s A,  Create (rdrop) ' ;s A,
   
 rdrop   --              gforth  rdrop   ( R:w -- )              gforth
 rp++;  
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     w1 w2 --        core-ext        two_to_r  2>r     ( w1 w2 -- R:w1 R:w2 )  core-ext        two_to_r
 *--rp = w1;  
 *--rp = w2;  
 :  :
  swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;
   
 2r>     -- w1 w2        core-ext        two_r_from  2r>     ( R:w1 R:w2 -- w1 w2 )  core-ext        two_r_from
 w2 = *rp++;  
 w1 = *rp++;  
 :  :
  r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;
   
 2r@     -- w1 w2        core-ext        two_r_fetch  2r@     ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )        core-ext        two_r_fetch
 w2 = rp[0];  
 w1 = rp[1];  
 :  :
  i' j ;   i' j ;
   
 2rdrop  --              gforth  two_r_drop  2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop
 rp+=2;  
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
 over    w1 w2 -- w1 w2 w1               core  over    ( w1 w2 -- w1 w2 w1 )           core
 :  :
  sp@ cell+ @ ;   sp@ cell+ @ ;
   
 drop    w --            core  drop    ( w -- )                core
 :  :
  IF THEN ;   IF THEN ;
   
 swap    w1 w2 -- w2 w1          core  swap    ( w1 w2 -- w2 w1 )              core
 :  :
  >r (swap) ! r> (swap) @ ;   >r (swap) ! r> (swap) @ ;
 Variable (swap)  Variable (swap)
   
 dup     w -- w w                core  dup     ( w -- w w )            core    dupe
 :  :
  sp@ @ ;   sp@ @ ;
   
 rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     ( w1 w2 w3 -- w2 w3 w1 )        core    rote
 :  :
 [ defined? (swap) [IF] ]  [ defined? (swap) [IF] ]
     (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;      (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
Line 1011  Variable (rot) Line 1017  Variable (rot)
     >r swap r> swap ;      >r swap r> swap ;
 [THEN]  [THEN]
   
 -rot    w1 w2 w3 -- w3 w1 w2    gforth  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 ;   swap drop ;
   
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    ( w1 w2 -- w2 w1 w2 )   core-ext
 :  :
  swap over ;   swap over ;
   
 ?dup    w -- w                  core    question_dupe  ?dup    ( w -- w )                      core    question_dupe
   ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
   @code{dup} if w is nonzero.""
 if (w!=0) {  if (w!=0) {
   IF_TOS(*sp-- = w;)    IF_spTOS(*sp-- = w;)
 #ifndef USE_TOS  #ifndef USE_TOS
   *--sp = w;    *--sp = w;
 #endif  #endif
Line 1033  if (w!=0) { Line 1041  if (w!=0) {
 :  :
  dup IF dup THEN ;   dup IF dup THEN ;
   
 pick    u -- w                  core-ext  pick    ( u -- w )                      core-ext
   ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
 w = sp[u+1];  w = sp[u+1];
 :  :
  1+ cells sp@ + @ ;   1+ cells sp@ + @ ;
   
 2drop   w1 w2 --                core    two_drop  2drop   ( w1 w2 -- )            core    two_drop
 :  :
  drop drop ;   drop drop ;
   
 2dup    w1 w2 -- w1 w2 w1 w2    core    two_dupe  2dup    ( w1 w2 -- w1 w2 w1 w2 )        core    two_dupe
 :  :
  over over ;   over over ;
   
 2over   w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2        core    two_over  2over   ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 )    core    two_over
 :  :
  3 pick 3 pick ;   3 pick 3 pick ;
   
 2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap  2swap   ( w1 w2 w3 w4 -- w3 w4 w1 w2 )  core    two_swap
 :  :
  rot >r rot r> ;   rot >r rot r> ;
   
 2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double-ext      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  2nip    ( w1 w2 w3 w4 -- w3 w4 )        gforth  two_nip
 :  :
  2swap 2drop ;   2swap 2drop ;
   
 2tuck   w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4        gforth  two_tuck  2tuck   ( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 )    gforth  two_tuck
 :  :
  2swap 2over ;   2swap 2over ;
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
 @       a_addr -- w             core    fetch  @       ( a_addr -- w )         core    fetch
   ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
   
 !       w a_addr --             core    store  !       ( w a_addr -- )         core    store
   ""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;  *a_addr = w;
   
 +!      n a_addr --             core    plus_store  +!      ( n a_addr -- )         core    plus_store
   ""Add @i{n} to the cell at @i{a-addr}.""
 *a_addr += n;  *a_addr += n;
 :  :
  tuck @ + swap ! ;   tuck @ + swap ! ;
   
 c@      c_addr -- c             core    cfetch  c@      ( c_addr -- c )         core    c_fetch
   ""@i{c} is the char stored at @i{c_addr}.""
 c = *c_addr;  c = *c_addr;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1104  c = *c_addr; Line 1117  c = *c_addr;
 ;  ;
 : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;  : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
   
 c!      c c_addr --             core    cstore  c!      ( c c_addr -- )         core    c_store
   ""Store @i{c} into the char at @i{c-addr}.""
 *c_addr = c;  *c_addr = c;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1133  c! c c_addr --  core cstore Line 1147  c! c c_addr --  core cstore
 [THEN]  [THEN]
 : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;  : 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
   ""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell.""
 a_addr[0] = w2;  a_addr[0] = w2;
 a_addr[1] = w1;  a_addr[1] = w1;
 :  :
  tuck ! cell+ ! ;   tuck ! cell+ ! ;
   
 2@      a_addr -- w1 w2         core    two_fetch  2@      ( a_addr -- w1 w2 )             core    two_fetch
   ""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is
   the content of the next cell.""
 w2 = a_addr[0];  w2 = a_addr[0];
 w1 = a_addr[1];  w1 = a_addr[1];
 :  :
  dup cell+ @ swap @ ;   dup cell+ @ swap @ ;
   
 cell+   a_addr1 -- a_addr2      core    cell_plus  cell+   ( a_addr1 -- a_addr2 )  core    cell_plus
   ""@code{1 cells +}""
 a_addr2 = a_addr1+1;  a_addr2 = a_addr1+1;
 :  :
  cell + ;   cell + ;
   
 cells   n1 -- n2                core  cells   ( n1 -- n2 )            core
   "" @i{n2} is the number of address units of @i{n1} cells.""
 n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
 :  :
  [ cell   [ cell
Line 1160  n2 = n1 * sizeof(Cell); Line 1179  n2 = n1 * sizeof(Cell);
  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    char_plus
   ""@code{1 chars +}.""
 c_addr2 = c_addr1 + 1;  c_addr2 = c_addr1 + 1;
 :  :
  1+ ;   1+ ;
   
 (chars)         n1 -- n2        gforth  paren_cares  (chars) ( n1 -- n2 )    gforth  paren_chars
 n2 = n1 * sizeof(Char);  n2 = n1 * sizeof(Char);
 :  :
  ;   ;
   
 count   c_addr1 -- c_addr2 u    core  count   ( c_addr1 -- c_addr2 u )        core
   ""@i{c-addr2} is the first character and @i{u} the length of the
   counted string at @i{c-addr1}.""
 u = *c_addr1;  u = *c_addr1;
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
Line 1189  f83name2=f83name1; Line 1211  f83name2=f83name1;
         r> @          r> @
     REPEAT  THEN  nip nip ;      REPEAT  THEN  nip nip ;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (find-samelen) ( u f83name1 -- u f83name2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;      BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL THEN ;
   
 \+has? hash [IF]  \+hash
   
 (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind  (hashfind)      ( c_addr u a_addr -- f83name2 ) new     paren_hashfind
 struct F83Name *f83name1;  struct F83Name *f83name1;
 f83name2=NULL;  f83name2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
Line 1215  while(a_addr != NULL) Line 1237  while(a_addr != NULL)
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind  (tablefind)     ( c_addr u a_addr -- f83name2 ) new     paren_tablefind
 ""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
 struct F83Name *f83name1;  struct F83Name *f83name1;
 f83name2=NULL;  f83name2=NULL;
Line 1238  while(a_addr != NULL) Line 1260  while(a_addr != NULL)
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (hashkey)       c_addr u1 -- u2         gforth  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          gforth  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 1272  Create rot-values Line 1294  Create rot-values
   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,
   
 \+[THEN]  \+
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  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 1294  else { Line 1316  else {
  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  aligned ( c_addr -- a_addr )    core
   "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}.""
 a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));  a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
 :  :
  [ cell 1- ] Literal + [ -1 cells ] Literal and ;   [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   
 faligned        c_addr -- f_addr        float   f_aligned  faligned        ( c_addr -- f_addr )    float   f_aligned
   "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}.""
 f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));  f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
 :  :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 >body           xt -- a_addr    core    to_body  >body   ( xt -- a_addr )        core    to_body
   "" Get the address of the body of the word represented by @i{xt} (the address
   of the word's data field).""
 a_addr = PFA(xt);  a_addr = PFA(xt);
 :  :
     2 cells + ;      2 cells + ;
   
 >code-address           xt -- c_addr            gforth  to_code_address  \ threading stuff is currently only interesting if we have a compiler
 ""c_addr is the code address of the word xt""  \fhas? standardthreading has? compiler and [IF]
   
   >code-address   ( xt -- c_addr )                gforth  to_code_address
   ""@i{c-addr} is the code address of the word @i{xt}.""
 /* !! This behaves installation-dependently for DOES-words */  /* !! This behaves installation-dependently for DOES-words */
 c_addr = (Address)CODE_ADDRESS(xt);  c_addr = (Address)CODE_ADDRESS(xt);
 :  :
     @ ;      @ ;
   
 >does-code      xt -- a_addr            gforth  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 @i{xt} is the execution token of a child of a @code{DOES>} word,
 a_addr is the start of the Forth code after the DOES>;  @i{a-addr} is the start of the Forth code after the @code{DOES>};
 Otherwise a_addr is 0.""  Otherwise @i{a-addr} is 0.""
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
 :  :
     cell+ @ ;      cell+ @ ;
   
 code-address!           c_addr xt --            gforth  code_address_store  code-address!   ( c_addr xt -- )                gforth  code_address_store
 ""Creates a code field with code address c_addr at xt""  ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
 :  :
     ! ;      ! ;
   
 does-code!      a_addr xt --            gforth  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  ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
 is the start of the Forth code after DOES>""  @i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
 does-handler!   a_addr --       gforth  does_handler_store  does-handler!   ( a_addr -- )   gforth  does_handler_store
 ""creates a DOES>-handler at address a_addr. a_addr usually points  ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 just behind a DOES>.""  @i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :  :
     drop ;      drop ;
   
 /does-handler   -- n    gforth  slash_does_handler  /does-handler   ( -- n )        gforth  slash_does_handler
 ""the size of a does-handler (includes possible padding)""  ""The size of a @code{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;
 :  :
     2 cells ;      2 cells ;
   
 threading-method        -- n    gforth  threading_method  threading-method        ( -- n )        gforth  threading_method
 ""0 if the engine is direct threaded. Note that this may change during  ""0 if the engine is direct threaded. Note that this may change during
 the lifetime of an image.""  the lifetime of an image.""
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
Line 1369  n=1; Line 1398  n=1;
 :  :
  1 ;   1 ;
   
 \+has? os [IF]  \f[THEN]
   
 key-file        wfileid -- n            gforth  paren_key_file  \g hostos
   
   key-file        ( wfileid -- n )                gforth  paren_key_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key((FILE*)wfileid);  n = key((FILE*)wfileid);
   #else
   n = key(stdin);
   #endif
   
 key?-file       wfileid -- n            facility        key_q_file  key?-file       ( wfileid -- n )                facility        key_q_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key_query((FILE*)wfileid);  n = key_query((FILE*)wfileid);
   #else
   n = key_query(stdin);
   #endif
   
   \+os
   
 stdin   -- wfileid      gforth  stdin   ( -- wfileid )  gforth
 wfileid = (Cell)stdin;  wfileid = (Cell)stdin;
   
 stdout  -- wfileid      gforth  stdout  ( -- wfileid )  gforth
 wfileid = (Cell)stdout;  wfileid = (Cell)stdout;
   
 stderr  -- wfileid      gforth  stderr  ( -- wfileid )  gforth
 wfileid = (Cell)stderr;  wfileid = (Cell)stderr;
   
 form    -- urows ucols  gforth  form    ( -- urows ucols )      gforth
 ""The number of lines and columns in the terminal. These numbers may change  ""The number of lines and columns in the terminal. These numbers may change
 with the window size.""  with the window size.""
 /* we could block SIGWINCH here to get a consistent size, but I don't  /* we could block SIGWINCH here to get a consistent size, but I don't
Line 1396  with the window size."" Line 1437  with the window size.""
 urows=rows;  urows=rows;
 ucols=cols;  ucols=cols;
   
 flush-icache    c_addr u --     gforth  flush_icache  flush-icache    ( c_addr u -- ) gforth  flush_icache
 ""Make sure that the instruction cache of the processor (if there is  ""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  one) does not contain stale data at @i{c-addr} and @i{u} bytes
 afterwards. @code{END-CODE} performs a @code{flush-icache}  afterwards. @code{END-CODE} performs a @code{flush-icache}
 automatically. Caveat: @code{flush-icache} might not work on your  automatically. Caveat: @code{flush-icache} might not work on your
 installation; this is usually the case if direct threading is not  installation; this is usually the case if direct threading is not
Line 1408  your machine has a separate instruction Line 1449  your machine has a separate instruction
 cache.""  cache.""
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE(c_addr,u);
   
 (bye)   n --    gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
   SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        c_addr u -- wretval wior        gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  peren_system
   #ifndef MSDOS
 int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
 deprep_terminal();  deprep_terminal();
   #endif
 wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
 wior = IOR(wretval==-1 || (wretval==127 && errno != 0));  wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
   #ifndef MSDOS
 if (old_tp)  if (old_tp)
   prep_terminal();    prep_terminal();
   #endif
   
 getenv  c_addr1 u1 -- c_addr2 u2        gforth  getenv  ( c_addr1 u1 -- c_addr2 u2 )    gforth
   ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
   is the host operating system's expansion of that environment variable. If the
   environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
   in length.""
   /* close ' to keep fontify happy */
 c_addr2 = getenv(cstr(c_addr1,u1,1));  c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 open-pipe       c_addr u ntype -- wfileid wior  gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
 wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 close-pipe      wfileid -- wretval wior         gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
 wretval = pclose((FILE *)wfileid);  wretval = pclose((FILE *)wfileid);
 wior = IOR(wretval==-1);  wior = IOR(wretval==-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
   ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
   Months are numbered from 1.""
 struct timeval time1;  struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
 gettimeofday(&time1,&zone1);  gettimeofday(&time1,&zone1);
   /* !! Single Unix specification: 
      If tzp is not a null pointer, the behaviour is unspecified. */
 ltime=localtime((time_t *)&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;
Line 1444  nhour =ltime->tm_hour; Line 1499  nhour =ltime->tm_hour;
 nmin  =ltime->tm_min;  nmin  =ltime->tm_min;
 nsec  =ltime->tm_sec;  nsec  =ltime->tm_sec;
   
 ms      n --    facility-ext  ms      ( n -- )        facility-ext
   ""Wait at least @i{n} milli-second.""
 struct timeval timeout;  struct timeval timeout;
 timeout.tv_sec=n/1000;  timeout.tv_sec=n/1000;
 timeout.tv_usec=1000*(n%1000);  timeout.tv_usec=1000*(n%1000);
 (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
   ""Allocate @i{u} address units of contiguous data space. The initial
   contents of the data space is undefined. If the allocation is successful,
   @i{a-addr} is the start address of the allocated region and @i{wior}
   is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
   is a non-zero I/O result code.""
 a_addr = (Cell *)malloc(u?u:1);  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
   ""Return the region of data space starting at @i{a-addr} to the system.
   The region must originally have been obtained using @code{allocate} or
   @code{resize}. If the operational is successful, @i{wior} is 0.
   If the operation fails, @i{wior} is a non-zero I/O result code.""
 free(a_addr);  free(a_addr);
 wior = 0;  wior = 0;
   
 resize          a_addr1 u -- a_addr2 wior       memory  resize  ( a_addr1 u -- a_addr2 wior )   memory
 ""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.
 @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}  If the operation is successful, @i{wior} is 0.
 @code{allocate}s @i{u} address units.""  If the operation fails, @i{wior} is a non-zero
   I/O result code. If @i{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  /* the following check is not necessary on most OSs, but it is needed
    on SunOS 4.1.2. */     on SunOS 4.1.2. */
   /* close ' to keep fontify happy */
 if (a_addr1==NULL)  if (a_addr1==NULL)
   a_addr2 = (Cell *)malloc(u);    a_addr2 = (Cell *)malloc(u);
 else  else
   a_addr2 = (Cell *)realloc(a_addr1, u);    a_addr2 = (Cell *)realloc(a_addr1, u);
 wior = IOR(a_addr2==NULL);      /* !! Define a return code */  wior = IOR(a_addr2==NULL);      /* !! Define a return code */
   
 strerror        n -- c_addr u   gforth  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  strsignal       ( n -- c_addr u )       gforth
 c_addr = strsignal(n);  c_addr = strsignal(n);
 u = strlen(c_addr);  u = strlen(c_addr);
   
 call-c  w --    gforth  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 global  access the stack itself. The stack pointers are exported in the global
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{FP}.""
 /* This is a first attempt at support for calls to C. This may change in  /* This is a first attempt at support for calls to C. This may change in
    the future */     the future */
 IF_FTOS(fp[0]=FTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 SP=sp;  SP=sp;
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  sp=SP;
 fp=FP;  fp=FP;
 IF_TOS(TOS=sp[0]);  IF_spTOS(spTOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+[THEN] ( has? os ) has? file [IF]  \+
   \+file
   
 close-file      wfileid -- wior         file    close_file  close-file      ( wfileid -- wior )             file    close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
   
 open-file       c_addr u ntype -- w2 wior       file    open_file  open-file       ( c_addr u wfam -- wfileid wior )       file    open_file
 w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
 wior =  IOR(w2 == 0);  wior =  IOR(wfileid == 0);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
 Cell    fd;  Cell    fd;
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);  fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
 if (fd != -1) {  if (fd != -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    wfileid = (Cell)fdopen(fd, fileattr[wfam]);
   wior = IOR(w2 == 0);    wior = IOR(wfileid == 0);
 } else {  } else {
   w2 = 0;    wfileid = 0;
   wior = IOR(1);    wior = IOR(1);
 }  }
   
 delete-file     c_addr u -- wior                file    delete_file  delete-file     ( c_addr u -- wior )            file    delete_file
 wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);  wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     ( c_addr1 u1 c_addr2 u2 -- wior )       file-ext        rename_file
   ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);  char *s1=tilde_cstr(c_addr2, u2, 1);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);  wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
   
 file-position   wfileid -- ud wior      file    file_position  file-position   ( wfileid -- ud wior )  file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
 ud = LONG2UD(ftell((FILE *)wfileid));  ud = LONG2UD(ftell((FILE *)wfileid));
 wior = IOR(UD2LONG(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, UD2LONG(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 = LONG2UD(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), UD2LONG(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 */
 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));
Line 1546  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1616  wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    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
 /*  /* this may one day be replaced with : read-line (read-line) nip ; */
 Cell c;  Cell c;
 flag=-1;  flag=-1;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
 {  {
    *c_addr++ = (Char)(c = getc((FILE *)wfileid));     c = getc((FILE *)wfileid);
    if(c=='\n') break;     if (c=='\n') break;
    if(c==EOF)     if (c=='\r') {
      {       if ((c = getc((FILE *)wfileid))!='\n')
          ungetc(c,(FILE *)wfileid);
        break;
      }
      if (c==EOF) {
         flag=FLAG(u2!=0);          flag=FLAG(u2!=0);
         break;          break;
      }       }
      c_addr[u2] = (Char)c;
 }  }
 wior=FILEIO(ferror((FILE *)wfileid));  wior=FILEIO(ferror((FILE *)wfileid));
 */  
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {  
   wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */  
   if (wior)  
     clearerr((FILE *)wfileid);  
   u2 = strlen(c_addr);  
   u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));  
 }  
 else {  
   wior=0;  
   u2=0;  
 }  
   
 \+[THEN]  has? file [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 */
   #ifdef HAS_FILE
 {  {
   UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);    UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));    wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
   if (wior)    if (wior)
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
 }  }
   #else
   TYPE(c_addr, u1);
   #endif
   
 emit-file       c wfileid -- wior       gforth  emit_file  emit-file       ( c wfileid -- wior )   gforth  emit_file
   #ifdef HAS_FILE
 wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);  wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   #else
   PUTC(c);
   #endif
   
 \+[THEN]  has? file [IF]  \+file
   
 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);
   
 file-status     c_addr u -- ntype wior  file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
 char *filename=tilde_cstr(c_addr, u, 1);  char *filename=tilde_cstr(c_addr, u, 1);
 if (access (filename, F_OK) != 0) {  if (access (filename, F_OK) != 0) {
   ntype=0;    wfam=0;
   wior=IOR(1);    wior=IOR(1);
 }  }
 else if (access (filename, R_OK | W_OK) == 0) {  else if (access (filename, R_OK | W_OK) == 0) {
   ntype=2; /* r/w */    wfam=2; /* r/w */
   wior=0;    wior=0;
 }  }
 else if (access (filename, R_OK) == 0) {  else if (access (filename, R_OK) == 0) {
   ntype=0; /* r/o */    wfam=0; /* r/o */
   wior=0;    wior=0;
 }  }
 else if (access (filename, W_OK) == 0) {  else if (access (filename, W_OK) == 0) {
   ntype=4; /* w/o */    wfam=4; /* w/o */
   wior=0;    wior=0;
 }  }
 else {  else {
   ntype=1; /* well, we cannot access the file, but better deliver a legal    wfam=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. */              access mode (r/o bin), so we get a decent error later upon open. */
   wior=0;    wior=0;
 }  }
   
 \+[THEN] ( has? file ) has? floating [IF]  \+
   \+floating
   
   \g floating
   
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)  comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, 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  #ifdef BUGGY_LONG_LONG
 extern double ldexp(double x, int exp);  extern double ldexp(double x, int exp);
 r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;  r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
Line 1633  r = ldexp((Float)d.hi,CELL_BITS) + (Floa Line 1706  r = ldexp((Float)d.hi,CELL_BITS) + (Floa
 r = d;  r = d;
 #endif  #endif
   
 f>d             r -- d          float   f_to_d  f>d     ( r -- d )              float   f_to_d
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d.hi = ldexp(r,-CELL_BITS) - (r<0);  d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  d.lo = r-ldexp((Float)d.hi,CELL_BITS);
 #else  #else
 d = r;  d = r;
 #endif  #endif
   
 f!              r f_addr --     float   f_store  f!      ( r f_addr -- ) float   f_store
   ""Store @i{r} into the float at address @i{f-addr}.""
 *f_addr = r;  *f_addr = r;
   
 f@              f_addr -- r     float   f_fetch  f@      ( f_addr -- r ) float   f_fetch
   ""@i{r} is the float at address @i{f-addr}.""
 r = *f_addr;  r = *f_addr;
   
 df@             df_addr -- r    float-ext       d_f_fetch  df@     ( df_addr -- r )        float-ext       d_f_fetch
   ""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *df_addr;  r = *df_addr;
 #else  #else
 !! df@  !! df@
 #endif  #endif
   
 df!             r df_addr --    float-ext       d_f_store  df!     ( r df_addr -- )        float-ext       d_f_store
   ""Store @i{r} as double-precision IEEE floating-point value to the
   address @i{df-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *df_addr = r;  *df_addr = r;
 #else  #else
 !! df!  !! df!
 #endif  #endif
   
 sf@             sf_addr -- r    float-ext       s_f_fetch  sf@     ( sf_addr -- r )        float-ext       s_f_fetch
   ""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *sf_addr;  r = *sf_addr;
 #else  #else
 !! sf@  !! sf@
 #endif  #endif
   
 sf!             r sf_addr --    float-ext       s_f_store  sf!     ( r sf_addr -- )        float-ext       s_f_store
   ""Store @i{r} as single-precision IEEE floating-point value to the
   address @i{sf-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *sf_addr = r;  *sf_addr = r;
 #else  #else
 !! sf!  !! sf!
 #endif  #endif
   
 f+              r1 r2 -- r3     float   f_plus  f+      ( r1 r2 -- r3 ) float   f_plus
 r3 = r1+r2;  r3 = r1+r2;
   
 f-              r1 r2 -- r3     float   f_minus  f-      ( r1 r2 -- r3 ) float   f_minus
 r3 = r1-r2;  r3 = r1-r2;
   
 f*              r1 r2 -- r3     float   f_star  f*      ( r1 r2 -- r3 ) float   f_star
 r3 = r1*r2;  r3 = r1*r2;
   
 f/              r1 r2 -- r3     float   f_slash  f/      ( r1 r2 -- r3 ) float   f_slash
 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""  ""@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   f_negate
 r2 = - r1;  r2 = - r1;
   
 fdrop           r --            float  fdrop   ( r -- )                float   f_drop
   
 fdup            r -- r r        float  fdup    ( r -- r r )    float   f_dupe
   
 fswap           r1 r2 -- r2 r1  float  fswap   ( r1 r2 -- r2 r1 )      float   f_swap
   
 fover           r1 r2 -- r1 r2 r1       float  fover   ( r1 r2 -- r1 r2 r1 )   float   f_over
   
 frot            r1 r2 r3 -- r2 r3 r1    float  frot    ( r1 r2 r3 -- r2 r3 r1 )        float   f_rote
   
 fnip            r1 r2 -- r2     gforth  fnip    ( r1 r2 -- r2 ) gforth  f_nip
   
 ftuck           r1 r2 -- r2 r1 r2       gforth  ftuck   ( r1 r2 -- r2 r1 r2 )   gforth  f_tuck
   
 float+          f_addr1 -- f_addr2      float   float_plus  float+  ( f_addr1 -- f_addr2 )  float   float_plus
   ""@code{1 floats +}.""
 f_addr2 = f_addr1+1;  f_addr2 = f_addr1+1;
   
 floats          n1 -- n2        float  floats  ( n1 -- n2 )    float
   ""@i{n2} is the number of address units of @i{n1} floats.""
 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""  ""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   f_round
 ""round to the nearest integral value""  ""Round to the nearest integral value.""
 /* !! unclear wording */  /* !! unclear wording */
 #ifdef HAVE_RINT  #ifdef HAVE_RINT
 r2 = rint(r1);  r2 = rint(r1);
Line 1729  r2 = floor(r1+0.5); Line 1812  r2 = floor(r1+0.5);
 /* !! This is not quite true to the rounding rules given in the standard */  /* !! This is not quite true to the rounding rules given in the standard */
 #endif  #endif
   
 fmax            r1 r2 -- r3     float  fmax    ( r1 r2 -- r3 ) float   f_max
 if (r1<r2)  if (r1<r2)
   r3 = r2;    r3 = r2;
 else  else
   r3 = r1;    r3 = r1;
   
 fmin            r1 r2 -- r3     float  fmin    ( r1 r2 -- r3 ) float   f_min
 if (r1<r2)  if (r1<r2)
   r3 = r1;    r3 = r1;
 else  else
   r3 = r2;    r3 = r2;
   
 represent               r c_addr u -- n f1 f2   float  represent       ( r c_addr u -- n f1 f2 )       float
 char *sig;  char *sig;
 int flag;  int flag;
 int decpt;  int decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &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((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);  memmove(c_addr,sig,u);
   
 >float  c_addr u -- flag        float   to_float  >float  ( c_addr u -- flag )    float   to_float
   ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
   character string @i{c-addr u} to internal floating-point
   representation. If the string represents a valid floating-point number
   @i{r} is placed on the floating-point stack and @i{flag} is
   true. Otherwise, @i{flag} is false. A string of blanks is a special
   case and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
 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);  int sign = 0;
   if(number[0]=='-') {
      sign = 1;
      number++;
      u--;
   }
   while(isspace((unsigned)(number[--u])) && u>0);
 switch(number[u])  switch(number[u])
 {  {
    case 'd':     case 'd':
Line 1769  number[u]='\0'; Line 1864  number[u]='\0';
 r=strtod(number,&endconv);  r=strtod(number,&endconv);
 if((flag=FLAG(!(Cell)*endconv)))  if((flag=FLAG(!(Cell)*endconv)))
 {  {
    IF_FTOS(fp[0] = FTOS);     IF_fpTOS(fp[0] = fpTOS);
    fp += -1;     fp += -1;
    FTOS = r;     fpTOS = sign ? -r : r;
 }  }
 else if(*endconv=='d' || *endconv=='D')  else if(*endconv=='d' || *endconv=='D')
 {  {
Line 1779  else if(*endconv=='d' || *endconv=='D') Line 1874  else if(*endconv=='d' || *endconv=='D')
    r=strtod(number,&endconv);     r=strtod(number,&endconv);
    if((flag=FLAG(!(Cell)*endconv)))     if((flag=FLAG(!(Cell)*endconv)))
      {       {
         IF_FTOS(fp[0] = FTOS);          IF_fpTOS(fp[0] = fpTOS);
         fp += -1;          fp += -1;
         FTOS = r;          fpTOS = sign ? -r : r;
      }       }
 }  }
   
 fabs            r1 -- r2        float-ext  fabs    ( r1 -- r2 )    float-ext       f_abs
 r2 = fabs(r1);  r2 = fabs(r1);
   
 facos           r1 -- r2        float-ext  facos   ( r1 -- r2 )    float-ext       f_a_cos
 r2 = acos(r1);  r2 = acos(r1);
   
 fasin           r1 -- r2        float-ext  fasin   ( r1 -- r2 )    float-ext       f_a_sine
 r2 = asin(r1);  r2 = asin(r1);
   
 fatan           r1 -- r2        float-ext  fatan   ( r1 -- r2 )    float-ext       f_a_tan
 r2 = atan(r1);  r2 = atan(r1);
   
 fatan2          r1 r2 -- r3     float-ext  fatan2  ( r1 r2 -- r3 ) float-ext       f_a_tan_two
 ""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably  ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably
 intends this to be the inverse of @code{fsincos}. In gforth it is.""  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       f_cos
 r2 = cos(r1);  r2 = cos(r1);
   
 fexp            r1 -- r2        float-ext  fexp    ( r1 -- r2 )    float-ext       f_e_x_p
 r2 = exp(r1);  r2 = exp(r1);
   
 fexpm1          r1 -- r2        float-ext  fexpm1  ( r1 -- r2 )    float-ext       f_e_x_p_m_one
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 #ifdef HAVE_EXPM1  #ifdef HAVE_EXPM1
 extern double  extern double
Line 1821  r2 = expm1(r1); Line 1916  r2 = expm1(r1);
 r2 = exp(r1)-1.;  r2 = exp(r1)-1.;
 #endif  #endif
   
 fln             r1 -- r2        float-ext  fln     ( r1 -- r2 )    float-ext       f_l_n
 r2 = log(r1);  r2 = log(r1);
   
 flnp1           r1 -- r2        float-ext  flnp1   ( r1 -- r2 )    float-ext       f_l_n_p_one
 ""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
 #ifdef HAVE_LOG1P  #ifdef HAVE_LOG1P
 extern double  extern double
Line 1837  r2 = log1p(r1); Line 1932  r2 = log1p(r1);
 r2 = log(r1+1.);  r2 = log(r1+1.);
 #endif  #endif
   
 flog            r1 -- r2        float-ext  flog    ( r1 -- r2 )    float-ext       f_log
 ""the decimal logarithm""  ""The decimal logarithm.""
 r2 = log10(r1);  r2 = log10(r1);
   
 falog           r1 -- r2        float-ext  falog   ( r1 -- r2 )    float-ext       f_a_log
 ""@i{r2}=10**@i{r1}""  ""@i{r2}=10**@i{r1}""
 extern double pow10(double);  extern double pow10(double);
 r2 = pow10(r1);  r2 = pow10(r1);
   
 fsin            r1 -- r2        float-ext  fsin    ( r1 -- r2 )    float-ext       f_sine
 r2 = sin(r1);  r2 = sin(r1);
   
 fsincos         r1 -- r2 r3     float-ext  fsincos ( r1 -- r2 r3 ) float-ext       f_sine_cos
 ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""  ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
 r2 = sin(r1);  r2 = sin(r1);
 r3 = cos(r1);  r3 = cos(r1);
   
 fsqrt           r1 -- r2        float-ext  fsqrt   ( r1 -- r2 )    float-ext       f_square_root
 r2 = sqrt(r1);  r2 = sqrt(r1);
   
 ftan            r1 -- r2        float-ext  ftan    ( r1 -- r2 )    float-ext       f_tan
 r2 = tan(r1);  r2 = tan(r1);
 :  :
  fsincos f/ ;   fsincos f/ ;
   
 fsinh           r1 -- r2        float-ext  fsinh   ( r1 -- r2 )    float-ext       f_cinch
 r2 = sinh(r1);  r2 = sinh(r1);
 :  :
  fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;   fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
   
 fcosh           r1 -- r2        float-ext  fcosh   ( r1 -- r2 )    float-ext       f_cosh
 r2 = cosh(r1);  r2 = cosh(r1);
 :  :
  fexp fdup 1/f f+ f2/ ;   fexp fdup 1/f f+ f2/ ;
   
 ftanh           r1 -- r2        float-ext  ftanh   ( r1 -- r2 )    float-ext       f_tan_h
 r2 = tanh(r1);  r2 = tanh(r1);
 :  :
  f2* fexpm1 fdup 2. d>f f+ f/ ;   f2* fexpm1 fdup 2. d>f f+ f/ ;
   
 fasinh          r1 -- r2        float-ext  fasinh  ( r1 -- r2 )    float-ext       f_a_cinch
 r2 = asinh(r1);  r2 = asinh(r1);
 :  :
  fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;   fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
   
 facosh          r1 -- r2        float-ext  facosh  ( r1 -- r2 )    float-ext       f_a_cosh
 r2 = acosh(r1);  r2 = acosh(r1);
 :  :
  fdup fdup f* 1. d>f f- fsqrt f+ fln ;   fdup fdup f* 1. d>f f- fsqrt f+ fln ;
   
 fatanh          r1 -- r2        float-ext  fatanh  ( r1 -- r2 )    float-ext       f_a_tan_h
 r2 = atanh(r1);  r2 = atanh(r1);
 :  :
  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 ;
   
 sfloats         n1 -- n2        float-ext       s_floats  sfloats ( n1 -- n2 )    float-ext       s_floats
   ""@i{n2} is the number of address units of @i{n1}
   single-precision IEEE floating-point numbers.""
 n2 = n1*sizeof(SFloat);  n2 = n1*sizeof(SFloat);
   
 dfloats         n1 -- n2        float-ext       d_floats  dfloats ( n1 -- n2 )    float-ext       d_floats
   ""@i{n2} is the number of address units of @i{n1}
   double-precision IEEE floating-point numbers.""
 n2 = n1*sizeof(DFloat);  n2 = n1*sizeof(DFloat);
   
 sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned  sfaligned       ( c_addr -- sf_addr )   float-ext       s_f_aligned
   ""@i{sf-addr} is the first single-float-aligned address greater
   than or equal to @i{c-addr}.""
 sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));  sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
 :  :
  [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;   [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
   
 dfaligned       c_addr -- df_addr       float-ext       d_f_aligned  dfaligned       ( c_addr -- df_addr )   float-ext       d_f_aligned
   ""@i{df-addr} is the first double-float-aligned address greater
   than or equal to @i{c-addr}.""
 df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));  df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
 :  :
  [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
Line 1915  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2018  df_addr = (DFloat *)((((Cell)c_addr)+(si
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+[THEN] ( has? floats ) has? glocals [IF]  \+
   \+glocals
   
 @local#         -- w    gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+noffset);
 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));
   
 @local1 -- w    new     fetch_local_four  @local1 ( -- w )        new     fetch_local_four
 w = *(Cell *)(lp+1*sizeof(Cell));  w = *(Cell *)(lp+1*sizeof(Cell));
   
 @local2 -- w    new     fetch_local_eight  @local2 ( -- w )        new     fetch_local_eight
 w = *(Cell *)(lp+2*sizeof(Cell));  w = *(Cell *)(lp+2*sizeof(Cell));
   
 @local3 -- w    new     fetch_local_twelve  @local3 ( -- w )        new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = *(Cell *)(lp+3*sizeof(Cell));
   
 \+has? floating [IF]  \+floating
   
 f@local#        -- r    gforth  f_fetch_local_number  f@local#        ( #noffset -- r )       gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+noffset);
 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));
   
 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));
   
 \+[THEN]  \+
   
 laddr#          -- c_addr       gforth  laddr_number  laddr#  ( #noffset -- 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+noffset);
 INC_IP(1);  
   
 lp+!#   --      gforth  lp_plus_store_number  lp+!#   ( #noffset -- ) 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 += (Cell)NEXT_INST;  lp += noffset;
 INC_IP(1);  
   
 lp-     --      new     minus_four_lp_plus_store  lp-     ( -- )  new     minus_four_lp_plus_store
 lp += -sizeof(Cell);  lp += -sizeof(Cell);
   
 lp+     --      new     eight_lp_plus_store  lp+     ( -- )  new     eight_lp_plus_store
 lp += sizeof(Float);  lp += sizeof(Float);
   
 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 --       gforth  lp_store  lp!     ( c_addr -- )   gforth  lp_store
 lp = (Address)c_addr;  lp = (Address)c_addr;
   
 >l      w --    gforth  to_l  >l      ( w -- )        gforth  to_l
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 \+has? floating [IF]  \+floating
   
 f>l     r --    gforth  f_to_l  f>l     ( r -- )        gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 fpick   u -- r          gforth  fpick   ( u -- r )              gforth
   ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
 r = fp[u+1]; /* +1, because update of fp happens before this fragment */  r = fp[u+1]; /* +1, because update of fp happens before this fragment */
 :  :
  floats fp@ + f@ ;   floats fp@ + f@ ;
   
 \+[THEN]  [THEN] \ has? glocals  \+
   \+
   
 \+has? OS [IF]  \+OS
   
 define(`uploop',  define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')         `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
Line 2009  define(argclist, Line 2111  define(argclist,
                `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')                 `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')
 \ icall(argnum)  \ icall(argnum)
 define(icall,  define(icall,
 `icall$1        argflist($1)u -- uret   gforth  `icall$1        ( argflist($1)u -- uret )       gforth
 uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));  uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
 define(fcall,  define(fcall,
 `fcall$1        argflist($1)u -- rret   gforth  `fcall$1        ( argflist($1)u -- rret )       gforth
 rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));  rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
   
   \ close ' to keep fontify happy
   
 open-lib        c_addr1 u1 -- u2        gforth  open_lib  open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 #ifndef RTLD_GLOBAL  #ifndef RTLD_GLOBAL
 #define RTLD_GLOBAL 0  #define RTLD_GLOBAL 0
 #endif  #endif
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef _WIN32
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define open-lib!  #warning Define open-lib!
Line 2035  u2 = 0; Line 2138  u2 = 0;
 #  endif  #  endif
 #endif  #endif
   
 lib-sym c_addr1 u1 u2 -- u3     gforth  lib_sym  lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef _WIN32
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define lib-sym!  #warning Define lib-sym!
Line 2052  icall(20) Line 2155  icall(20)
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+[THEN] \ has? OS  \+
   
 up!     a_addr --       gforth  up_store  up!     ( a_addr -- )   gforth  up_store
 UP=up=(char *)a_addr;  UP=up=(char *)a_addr;
 :  :
  up ! ;   up ! ;
 Variable UP  Variable UP
   
   wcall   ( u -- )        gforth
   IF_fpTOS(fp[0]=fpTOS);
   FP=fp;
   sp=(Cell*)(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
   fp=FP;
   IF_spTOS(spTOS=sp[0];)
   IF_fpTOS(fpTOS=fp[0]);
   
   \+file
   
   open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
   wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
   wior =  IOR(wdirid == 0);
   
   read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
   struct dirent * dent;
   dent = readdir((DIR *)wdirid);
   wior = 0;
   flag = -1;
   if(dent == NULL) {
     u2 = 0;
     flag = 0;
   } else {
     u2 = strlen(dent->d_name);
     if(u2 > u1) {
       u2 = u1;
       wior = -512-ENAMETOOLONG;
     }
     memmove(c_addr, dent->d_name, u2);
   }
   
   close-dir       ( wdirid -- wior )      gforth  close_dir
   wior = IOR(closedir((DIR *)wdirid));
   
   filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file
   char * string = cstr(c_addr1, u1, 1);
   char * pattern = cstr(c_addr2, u2, 0);
   flag = FLAG(!fnmatch(pattern, string, 0));
   
   \+
   
   newline ( -- c_addr u ) gforth
   ""String containing the newline sequence of the host OS""
   char newline[] = {
   #if defined(unix) || defined(__MACH__)
   /* Darwin/MacOS X sets __MACH__, but not unix. */
   '\n'
   #else
   '\r','\n'
   #endif
   };
   c_addr=newline;
   u=sizeof(newline);
   :
    "newline count ;
   Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
   
   \+os
   
   utime   ( -- dtime )    gforth
   ""Report the current time in microseconds since some epoch.""
   struct timeval time1;
   gettimeofday(&time1,NULL);
   dtime = timeval2us(&time1);
   
   cputime ( -- duser dsystem ) gforth
   ""duser and dsystem are the respective user- and system-level CPU
   times used since the start of the Forth system (excluding child
   processes), in microseconds (the granularity may be much larger,
   however).  On platforms without the getrusage call, it reports elapsed
   time (since some epoch) for duser and 0 for dsystem.""
   #ifdef HAVE_GETRUSAGE
   struct rusage usage;
   getrusage(RUSAGE_SELF, &usage);
   duser = timeval2us(&usage.ru_utime);
   dsystem = timeval2us(&usage.ru_stime);
   #else
   struct timeval time1;
   gettimeofday(&time1,NULL);
   duser = timeval2us(&time1);
   #ifndef BUGGY_LONG_LONG
   dsystem = (DCell)0;
   #else
   dsystem=(DCell){0,0};
   #endif
   #endif
   
   \+
   
   \+floating
   
   v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
   ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
   next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
   ucount elements.""
   for (r=0.; ucount>0; ucount--) {
     r += *f_addr1 * *f_addr2;
     f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
     f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
   }
   :
    >r swap 2swap swap 0e r> 0 ?DO
        dup f@ over + 2swap dup f@ f* f+ over + 2swap
    LOOP 2drop 2drop ; 
   
   faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
   ""vy=ra*vx+vy""
   for (; ucount>0; ucount--) {
     *f_y += ra * *f_x;
     f_x = (Float *)(((Address)f_x)+nstridex);
     f_y = (Float *)(((Address)f_y)+nstridey);
   }
   :
    >r swap 2swap swap r> 0 ?DO
        fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
    LOOP 2drop 2drop fdrop ;
   
   \+
   
   \+file
   
   (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line
   Cell c;
   flag=-1;
   u3=0;
   for(u2=0; u2<u1; u2++)
   {
      c = getc((FILE *)wfileid);
      u3++;
      if (c=='\n') break;
      if (c=='\r') {
        if ((c = getc((FILE *)wfileid))!='\n')
          ungetc(c,(FILE *)wfileid);
        else
          u3++;
        break;
      }
      if (c==EOF) {
           flag=FLAG(u2!=0);
           break;
        }
      c_addr[u2] = (Char)c;
   }
   wior=FILEIO(ferror((FILE *)wfileid));
   
   \+
   
   (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
   for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
     if ((UCell)LONGNAME_COUNT(longname1)==u &&
         memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
       break;
   longname2=longname1;
   :
       BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
           >r 2dup r@ cell+ cell+ capscomp  0=
           IF  2drop r>  EXIT  THEN
           r> @
       REPEAT  THEN  nip nip ;
   : (findl-samelen) ( u longname1 -- u longname2/0 )
       BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
   
   \+hash
   
   (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind
   struct Longname *longname1;
   longname2=NULL;
   while(a_addr != NULL)
   {
      longname1=(struct Longname *)(a_addr[1]);
      a_addr=(Cell *)(a_addr[0]);
      if ((UCell)LONGNAME_COUNT(longname1)==u &&
          memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
        {
           longname2=longname1;
           break;
        }
   }
   :
    BEGIN  dup  WHILE
           2@ >r >r dup r@ cell+ @ lcount-mask and =
           IF  2dup r@ cell+ cell+ capscomp 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
   (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind
   ""A case-sensitive variant of @code{(hashfind)}""
   struct Longname *longname1;
   longname2=NULL;
   while(a_addr != NULL)
   {
      longname1=(struct Longname *)(a_addr[1]);
      a_addr=(Cell *)(a_addr[0]);
      if ((UCell)LONGNAME_COUNT(longname1)==u &&
          memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)
        {
           longname2=longname1;
           break;
        }
   }
   :
    BEGIN  dup  WHILE
           2@ >r >r dup r@ cell+ @ lcount-mask and =
           IF  2dup r@ cell+ cell+ -text 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
   \+
   
   \+peephole
   
   \g peephole
   
   primtable       ( -- wprimtable )       new
   ""wprimtable is a table containing the xts of the primitives indexed
   by sequence-number in prim (for use in prepare-peephole-table).""
   wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);
   
   prepare-peephole-table  ( wprimtable -- wpeeptable ) new prepare_peephole_opt
   ""wpeeptable is a data structure used by @code{peephole-opt}; it is
   constructed by combining a primitives table with a simple peephole
   optimization table.""
   wpeeptable = prepare_peephole_table((Xt *)wprimtable);
   
   peephole-opt    ( xt1 xt2 wpeeptable -- xt )    new     peephole_opt
   ""xt is the combination of xt1 and xt2 (according to wpeeptable); if
   they cannot be combined, xt is 0.""
   xt = peephole_opt(xt1, xt2, wpeeptable);
   
   call    ( #a_callee -- R:a_retaddr )    new
   ""Call callee (a variant of docol with inline argument).""
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)a_callee);
   
   useraddr        ( #u -- a_addr )        new
   a_addr = (Cell *)(up+u);
   
   compile-prim ( xt1 -- xt2 )     new     compile_prim
   xt2 = (Xt)compile_prim((Label)xt1);
   
   include(peeprules.vmg)
   
   \+

Removed from v.1.13  
changed lines
  Added in v.1.87


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>