Diff for /gforth/prim between versions 1.108 and 1.174

version 1.108, 2002/12/24 23:40:29 version 1.174, 2005/08/02 12:00:51
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 100 Line 100
 \E s" struct F83Name *" single data-stack type-prefix f83name  \E s" struct F83Name *" single data-stack type-prefix f83name
 \E s" struct Longname *" single data-stack type-prefix longname  \E s" struct Longname *" single data-stack type-prefix longname
 \E   \E 
   \E data-stack   stack-prefix S:
   \E fp-stack     stack-prefix F:
 \E return-stack stack-prefix R:  \E return-stack stack-prefix R:
 \E inst-stream  stack-prefix #  \E inst-stream  stack-prefix #
 \E   \E 
 \E set-current  \E set-current
 \E store-optimization on  \E store-optimization on
   \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
   \E
   \E include-skipped-insts on \ static superinsts include cells for components
   \E                          \ useful for dynamic programming and
   \E                          \ superinsts across entry points
   
 \   \ 
 \   \ 
Line 131 Line 138
 \ throw execute, cfa and NEXT1 out?  \ throw execute, cfa and NEXT1 out?
 \ macroize *ip, ip++, *ip++ (pipelining)?  \ macroize *ip, ip++, *ip++ (pipelining)?
   
   \ Stack caching setup
   
   ifdef(`STACK_CACHE_FILE', `include(STACK_CACHE_FILE)', `include(cache0.vmg)')
   
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
 undefine(`symbols')  undefine(`symbols')
   
   \F 0 [if]
   
   \ run-time routines for non-primitives.  They are defined as
   \ primitives, because that simplifies things.
   
   (docol) ( -- R:a_retaddr )      gforth-internal paren_docol
   ""run-time routine for colon definitions""
   #ifdef NO_IP
   a_retaddr = next_code;
   INST_TAIL;
   goto **(Label *)PFA(CFA);
   #else /* !defined(NO_IP) */
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)PFA(CFA));
   #endif /* !defined(NO_IP) */
   
   (docon) ( -- w )        gforth-internal paren_docon
   ""run-time routine for constants""
   w = *(Cell *)PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (dovar) ( -- a_body )   gforth-internal paren_dovar
   ""run-time routine for variables and CREATEd words""
   a_body = PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (douser) ( -- a_user )  gforth-internal paren_douser
   ""run-time routine for constants""
   a_user = (Cell *)(up+*(Cell *)PFA(CFA));
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (dodefer) ( -- )        gforth-internal paren_dodefer
   ""run-time routine for deferred words""
   #ifndef NO_IP
   ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
   #endif /* !defined(NO_IP) */
   SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
   VM_JUMP(EXEC1(*(Xt *)PFA(CFA)));
   
   (dofield) ( n1 -- n2 )  gforth-internal paren_field
   ""run-time routine for fields""
   n2 = n1 + *(Cell *)PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (dodoes) ( -- a_body R:a_retaddr )      gforth-internal paren_dodoes
   ""run-time routine for @code{does>}-defined words""
   #ifdef NO_IP
   a_retaddr = next_code;
   a_body = PFA(CFA);
   INST_TAIL;
   goto **(Label *)DOES_CODE1(CFA);
   #else /* !defined(NO_IP) */
   a_retaddr = (Cell *)IP;
   a_body = PFA(CFA);
   SET_IP(DOES_CODE1(CFA));
   #endif /* !defined(NO_IP) */
   
   (does-handler) ( -- )   gforth-internal paren_does_handler
   ""just a slot to have an encoding for the DOESJUMP, 
   which is no longer used anyway (!! eliminate this)""
   
   \F [endif]
   
 \g control  \g control
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
 :  :
  ;   ;
   
 lit     ( #w -- w )             gforth  call    ( #a_callee -- R:a_retaddr )    new
 :  ""Call callee (a variant of docol with inline argument).""
  r> dup @ swap cell+ >r ;  #ifdef NO_IP
   assert(0);
   INST_TAIL;
   JUMP(a_callee);
   #else
   #ifdef DEBUG
       {
         CFA_TO_NAME((((Cell *)a_callee)-2));
         fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
                 len,name);
       }
   #endif
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)a_callee);
   #endif
   
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]);  
 SUPER_END;  SUPER_END;
 EXEC(xt);  VM_JUMP(EXEC1(xt));
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
Line 161  perform ( a_addr -- ) gforth Line 260  perform ( a_addr -- ) gforth
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]);  
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  VM_JUMP(EXEC1(*(Xt *)a_addr));
 :  :
  @ execute ;   @ execute ;
   
 \fhas? skipbranchprims 0= [IF]  ;s      ( R:w -- )              gforth  semis
   ""The primitive compiled by @code{EXIT}.""
   #ifdef NO_IP
   INST_TAIL;
   goto *(void *)w;
   #else
   SET_IP((Xt *)w);
   #endif
   
   unloop  ( R:w1 R:w2 -- )        core
   /* !! alias for 2rdrop */
   :
    r> rdrop rdrop >r ;
   
   lit-perform     ( #a_addr -- )  new     lit_perform
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   VM_JUMP(EXEC1(*(Xt *)a_addr));
   
   does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
   #ifdef NO_IP
   /* compiled to LIT CALL by compile_prim */
   assert(0);
   #else
   a_pfa = PFA(a_cfa);
   nest = (Cell)IP;
   #ifdef DEBUG
       {
         CFA_TO_NAME(a_cfa);
         fprintf(stderr,"%08lx: does %08lx %.*s\n",
                 (Cell)ip,(Cell)a_cfa,len,name);
       }
   #endif
   SET_IP(DOES_CODE1(a_cfa));
   #endif
   
 \+glocals  \+glocals
   
 branch-lp+!#    ( #ndisp #nlocals -- )  gforth  branch_lp_plus_store_number  branch-lp+!# ( #a_target #nlocals -- )  gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 lp += nlocals;  lp += nlocals;
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));  #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   
 \+  \+
   
 branch  ( #ndisp -- )           gforth  branch  ( #a_target -- )        gforth
 SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 :  :
  r> dup @ + >r ;   r> @ >r ;
   
 \ condbranch(forthname,stackeffect,restline,code,forthcode)  \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
   \ this is non-syntactical: code must open a brace that is closed by the macro
   \ condbranch(forthname,stackeffect,restline,code1,code2,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 ( `#'ndisp $2 ) $3  $1 ( `#'a_target $2 ) $3
 $4      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   }
   $6
   
   \+glocals
   
   $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
   $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   }
   
   \+
   )
   
   \ version that generates two jumps (not good for PR 15242 workaround)
   define(condbranch_twojump,
   $1 ( `#'a_target $2 ) $3
   $4      #ifdef NO_IP
 INST_TAIL;  INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 $5  $6
   
 \+glocals  \+glocals
   
 $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number  $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
 $4    lp += nlocals;  $4      #ifdef NO_IP
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));  
 INST_TAIL;  INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
Line 205  SUPER_CONTINUE; Line 397  SUPER_CONTINUE;
 )  )
   
 condbranch(?branch,f --,f83     question_branch,  condbranch(?branch,f --,f83     question_branch,
 if (f==0) {  ,if (f==0) {
 ,:  ,:
  0= dup     \ !f !f   0= dup 0=          \ !f f
  r> dup @   \ !f !f IP branchoffset   r> tuck cell+      \ !f branchoffset f IP+
  rot and +  \ !f IP|IP+branchoffset   and -rot @ and or  \ f&IP+|!f&branch
  swap 0= cell and + \ IP''  
  >r ;)   >r ;)
   
 \ 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
Line 218  if (f==0) { Line 409  if (f==0) {
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( #ndisp f -- f )       new     question_dupe_question_branch  ?dup-?branch    ( #a_target f -- S:... )        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++;  #ifdef NO_IP
   IF_spTOS(spTOS = sp[0]);  INST_TAIL;
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  JUMP(a_target);
   INST_TAIL;  #else
   SET_IP((Xt *)a_target);
   #endif
   } else {
   sp--;
   sp[0]=f;
 }  }
 SUPER_CONTINUE;  
   
 ?dup-0=-?branch ( #ndisp f -- ) new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #a_target f -- S:... ) 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  
 effect ( f -- ) and correcting for it in the branch-taken case costs a  
 few cycles in that case, but is easy to convert to a CONDBRANCH  
 invocation */  
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));    sp[0]=f;
   NEXT;  #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
   #endif
 }  }
 SUPER_CONTINUE;  
   
 \+  \+
 \f[THEN]  
 \fhas? skiploopprims 0= [IF]  \fhas? skiploopprims 0= [IF]
   
 condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,  condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,
 n2=n1-1;  n2=n1-1;
 if (n1) {  ,if (n1) {
 ,:  ,:
  r> r> dup 1- >r   r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)   IF @ >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,  condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
 n2=n1+1;  n2=n1+1;
 if (n2 != nlimit) {  ,if (n2 != nlimit) {
 ,:  ,:
  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 @ >r THEN ;)
   
 condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,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 */
Line 266  condbranch((+loop),n R:nlimit R:n1 -- R: Line 459  condbranch((+loop),n R:nlimit R:n1 -- R:
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = n1-nlimit;  Cell olddiff = n1-nlimit;
 n2=n1+n;          n2=n1+n;        
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  ,if (((olddiff^(olddiff+n))    /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {       &(olddiff^n))             /* OR it is a wrap-around effect */
       >=0) { /* & is used to avoid having two branches for gforth-native */
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
  2 pick r@ + r@ xor 0< 0=   2 pick r@ + r@ xor 0< 0=
  3 pick r> xor 0< 0= or   3 pick r> xor 0< 0= or
  IF    >r + >r dup @ + >r   IF    >r + >r @ >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+xconds  \+xconds
Line 281  if ((olddiff^(olddiff+n))>=0   /* the li Line 475  if ((olddiff^(olddiff+n))>=0   /* the li
 condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,  condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
 UCell olddiff = n1-nlimit;  UCell olddiff = n1-nlimit;
 n2=n1-u;  n2=n1-u;
 if (olddiff>u) {  ,if (olddiff>u) {
 ,)  ,)
   
 condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,  condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,
Line 296  if (n<0) { Line 490  if (n<0) {
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 n2=n1+n;  n2=n1+n;
 if (diff>=0 || newdiff<0) {  ,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */
 ,)  ,)
   
 \+  \+
   
 unloop  ( R:w1 R:w2 -- )        core  (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for
 /* !! alias for 2rdrop */  
 :  
  r> rdrop rdrop >r ;  
   
 (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for  
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 nlimit=0;  nlimit=0;
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do  (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do
 :  :
  r> swap rot >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do  (?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth   paren_question_do
 if (nstart == nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart == nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
   #endif
 }  }
 SUPER_CONTINUE;  
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
        dup @ + >r         @ >r
   ELSE r> swap rot >r >r    ELSE r> swap rot >r >r
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+xconds  \+xconds
   
 (+do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_plus_do  (+do)   ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do
 if (nstart >= nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart >= nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
   #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  >=   >=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u+do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_plus_do  (u+do)  ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do
 if (ustart >= ulimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (ustart >= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  u>=   u>=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (-do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_minus_do  (-do)   ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do
 if (nstart <= nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart <= nlimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  <=   <=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u-do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_minus_do  (u-do)  ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do
 if (ustart <= ulimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (ustart <= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  u<=   u<=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
Line 444  cmove ( c_from c_to u -- ) string c_move Line 658  cmove ( c_from c_to u -- ) string c_move
 @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @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  from low address to high address; i.e., for overlapping areas it is
 safe if @i{c-to}=<@i{c-from}.""  safe if @i{c-to}=<@i{c-from}.""
 while (u-- > 0)  cmove(c_from,c_to,u);
   *c_to++ = *c_from++;  
 :  :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
Line 454  cmove> ( c_from c_to u -- ) string c_mov Line 667  cmove> ( c_from c_to u -- ) string c_mov
 @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @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  from high address to low address; i.e., for overlapping areas it is
 safe if @i{c-to}>=@i{c-from}.""  safe if @i{c-to}>=@i{c-from}.""
 while (u-- > 0)  cmove_up(c_from,c_to,u);
   c_to[u] = c_from[u];  
 :  :
  dup 0= IF  drop 2drop exit  THEN   dup 0= IF  drop 2drop exit  THEN
  rot over + -rot bounds swap 1-   rot over + -rot bounds swap 1-
Line 475  is 1. Currently this is based on the mac Line 687  is 1. Currently this is based on the mac
 comparison. In the future, this may change to consider 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 */   /* close ' to keep fontify happy */ 
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = compare(c_addr1, u1, c_addr2, u2);
 if (n==0)  
   n = u1-u2;  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  :
  rot 2dup swap - >r min swap -text dup   rot 2dup swap - >r min swap -text dup
  IF  rdrop  ELSE  drop r> sgn  THEN ;   IF  rdrop  ELSE  drop r> sgn  THEN ;
 : sgn ( n -- -1/0/1 )  : -text ( c_addr1 u c_addr2 -- n )
  dup 0= IF EXIT THEN  0< 2* 1+ ;  
   
 -text   ( c_addr1 u c_addr2 -- n )      new     dash_text  
 n = memcmp(c_addr1, c_addr2, u);  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  
  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  sgn ;   ELSE  c@ I c@ - unloop  THEN  sgn ;
 : sgn ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
  dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
   \ -text is only used by replaced primitives now; move it elsewhere
   \ -text ( c_addr1 u c_addr2 -- n )      new     dash_text
   \ n = memcmp(c_addr1, c_addr2, u);
   \ if (n<0)
   \   n = -1;
   \ else if (n>0)
   \   n = 1;
   \ :
   \  swap bounds
   \  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
   \  ELSE  c@ I c@ - unloop  THEN  sgn ;
   \ : sgn ( n -- -1/0/1 )
   \  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}  ""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.""  is the equivalent upper-case character. All other characters are unchanged.""
Line 508  c2 = toupper(c1); Line 719  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  
 n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  
  swap bounds  
  ?DO  dup c@ I c@ <>  
      IF  dup c@ toupper I c@ toupper =  
      ELSE  true  THEN  WHILE  1+  LOOP  drop 0  
  ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;  
   
 -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;  
 while (u2>0 && c_addr[u2-1] == ' ')  
   u2--;  
 :  
  BEGIN  1- 2dup + c@ bl =  WHILE  
         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}  ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
 characters from the start of the string.""  characters from the start of the string.""
Line 541  u2 = u1-n; Line 729  u2 = u1-n;
   
 \g arith  \g arith
   
   lit     ( #w -- w )             gforth
   :
    r> dup @ swap cell+ >r ;
   
 +       ( n1 n2 -- n )          core    plus  +       ( n1 n2 -- n )          core    plus
 n = n1+n2;  n = n1+n2;
   
   \ lit+ / lit_plus = lit +
   
   lit+    ( n1 #n2 -- n )         new     lit_plus
   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 @i{n3} to @i{n1} (giving @i{n})""  ""add @i{n3} to @i{n1} (giving @i{n})""
Line 603  n = n1*n2; Line 800  n = n1*n2;
   
 /       ( n1 n2 -- n )          core    slash  /       ( n1 n2 -- n )          core    slash
 n = n1/n2;  n = n1/n2;
   if(FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) n--;
 :  :
  /mod nip ;   /mod nip ;
   
 mod     ( n1 n2 -- n )          core  mod     ( n1 n2 -- n )          core
 n = n1%n2;  n = n1%n2;
   if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += 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! */
   if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
     n4--;
     n3+=n2;
   }
 :  :
  >r s>d r> fm/mod ;   >r s>d r> fm/mod ;
   
   */mod   ( n1 n2 n3 -- n4 n5 )   core    star_slash_mod
   ""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double.""
   #ifdef BUGGY_LL_MUL
   DCell d = mmul(n1,n2);
   #else
   DCell d = (DCell)n1 * (DCell)n2;
   #endif
   #ifdef BUGGY_LL_DIV
   DCell r = fmdiv(d,n3);
   n4=DHI(r);
   n5=DLO(r);
   #else
   /* assumes that the processor uses either floored or symmetric division */
   n5 = d/n3;
   n4 = d%n3;
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
     n5--;
     n4+=n3;
   }
   #endif
   :
    >r m* r> fm/mod ;
   
   */      ( n1 n2 n3 -- n4 )      core    star_slash
   ""n4=(n1*n2)/n3, with the intermediate result being double.""
   #ifdef BUGGY_LL_MUL
   DCell d = mmul(n1,n2);
   #else
   DCell d = (DCell)n1 * (DCell)n2;
   #endif
   #ifdef BUGGY_LL_DIV
   DCell r = fmdiv(d,n3);
   n4=DLO(r);
   #else
   /* assumes that the processor uses either floored or symmetric division */
   n4 = d/n3;
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0) n4--;
   #endif
   :
    */mod nip ;
   
 2*      ( n1 -- n2 )            core            two_star  2*      ( n1 -- n2 )            core            two_star
 ""Shift left by 1; also works on unsigned numbers""  ""Shift left by 1; also works on unsigned numbers""
 n2 = 2*n1;  n2 = 2*n1;
Line 636  n2 = n1>>1; Line 880  n2 = n1>>1;
   
 fm/mod  ( d1 n1 -- n2 n3 )              core            f_m_slash_mod  fm/mod  ( d1 n1 -- n2 n3 )              core            f_m_slash_mod
 ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{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_LL_DIV
   #ifdef ASM_SM_SLASH_REM
   ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);
   if (((DHI(d1)^n1)<0) && n2!=0) {
     n3--;
     n2+=n1;
   }
   #else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = fmdiv(d1,n1);  DCell r = fmdiv(d1,n1);
 n2=r.hi;  n2=DHI(r);
 n3=r.lo;  n3=DLO(r);
 #else  #endif /* !defined(ASM_SM_SLASH_REM) */
   #else
   #ifdef ASM_SM_SLASH_REM4
   ASM_SM_SLASH_REM4(d1, n1, n2, n3);
   if (((DHI(d1)^n1)<0) && n2!=0) {
     n3--;
     n2+=n1;
   }
   #else /* !defined(ASM_SM_SLASH_REM4) */
 /* assumes that the processor uses either floored or symmetric division */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
 /* note that this 1%-3>0 is optimized by the compiler */  /* note that this 1%-3>0 is optimized by the compiler */
 if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {  if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) {
   n3--;    n3--;
   n2+=n1;    n2+=n1;
 }  }
   #endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif  #endif
 :  :
  dup >r dup 0< IF  negate >r dnegate r>  THEN   dup >r dup 0< IF  negate >r dnegate r>  THEN
Line 658  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) Line 918  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
   
 sm/rem  ( d1 n1 -- n2 n3 )              core            s_m_slash_rem  sm/rem  ( d1 n1 -- n2 n3 )              core            s_m_slash_rem
 ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{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_LL_DIV
   #ifdef ASM_SM_SLASH_REM
   ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);
   #else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = smdiv(d1,n1);  DCell r = smdiv(d1,n1);
 n2=r.hi;  n2=DHI(r);
 n3=r.lo;  n3=DLO(r);
 #else  #endif /* !defined(ASM_SM_SLASH_REM) */
   #else
   #ifdef ASM_SM_SLASH_REM4
   ASM_SM_SLASH_REM4(d1, n1, n2, n3);
   #else /* !defined(ASM_SM_SLASH_REM4) */
 /* assumes that the processor uses either floored or symmetric division */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
 /* note that this 1%-3<0 is optimized by the compiler */  /* note that this 1%-3<0 is optimized by the compiler */
 if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {  if (1%-3<0 && ((DHI(d1)^n1)<0) && n2!=0) {
   n3++;    n3++;
   n2-=n1;    n2-=n1;
 }  }
   #endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif  #endif
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
Line 679  if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) Line 947  if (1%-3<0 && (d1<0) != (n1<0) && n2!=0)
  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_LL_MUL
 d = mmul(n1,n2);  d = mmul(n1,n2);
 #else  #else
 d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
Line 691  d = (DCell)n1 * (DCell)n2; Line 959  d = (DCell)n1 * (DCell)n2;
   
 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_LL_MUL
 ud = ummul(u1,u2);  ud = ummul(u1,u2);
 #else  #else
 ud = (UDCell)u1 * (UDCell)u2;  ud = (UDCell)u1 * (UDCell)u2;
 #endif  #endif
 :  :
    >r >r 0 0 r> r> [ 8 cells ] literal 0     0 -rot dup [ 8 cells ] literal -
    DO     DO
        over >r dup >r 0< and d2*+ drop          dup 0< I' and d2*+ drop
        r> 2* r> swap     LOOP ;
    LOOP 2drop ;  
 : d2*+ ( ud n -- ud+n c )  : d2*+ ( ud n -- ud+n c )
    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""  ""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_DIV
   #ifdef ASM_UM_SLASH_MOD
   ASM_UM_SLASH_MOD(ud.lo, ud.hi, u1, u2, u3);
   #else /* !defined(ASM_UM_SLASH_MOD) */
 UDCell r = umdiv(ud,u1);  UDCell r = umdiv(ud,u1);
 u2=r.hi;  u2=DHI(r);
 u3=r.lo;  u3=DLO(r);
 #else  #endif /* !defined(ASM_UM_SLASH_MOD) */
   #else
   #ifdef ASM_UM_SLASH_MOD4
   ASM_UM_SLASH_MOD4(ud, u1, u2, u3);
   #else /* !defined(ASM_UM_SLASH_MOD4) */
 u3 = ud/u1;  u3 = ud/u1;
 u2 = ud%u1;  u2 = ud%u1;
   #endif /* !defined(ASM_UM_SLASH_MOD4) */
 #endif  #endif
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0
Line 727  u2 = ud%u1; Line 1002  u2 = ud%u1;
    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_LL_ADD
 d2.lo = d1.lo+n;  DLO_IS(d2, DLO(d1)+n);
 d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);  DHI_IS(d2, DHI(d1) - (n<0) + (DLO(d2)<DLO(d1)));
 #else  #else
 d2 = d1+n;  d2 = d1+n;
 #endif  #endif
Line 737  d2 = d1+n; Line 1012  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_LL_ADD
 d.lo = d1.lo+d2.lo;  DLO_IS(d, DLO(d1) + DLO(d2));
 d.hi = d1.hi + d2.hi + (d.lo<d1.lo);  DHI_IS(d, DHI(d1) + DHI(d2) + (d.lo<DLO(d1)));
 #else  #else
 d = d1+d2;  d = d1+d2;
 #endif  #endif
Line 747  d = d1+d2; Line 1022  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_LL_ADD
 d.lo = d1.lo - d2.lo;  DLO_IS(d, DLO(d1) - DLO(d2));
 d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);  DHI_IS(d, DHI(d1)-DHI(d2)-(DLO(d1)<DLO(d2)));
 #else  #else
 d = d1-d2;  d = d1-d2;
 #endif  #endif
Line 758  d = d1-d2; Line 1033  d = d1-d2;
   
 dnegate ( d1 -- d2 )            double  d_negate  dnegate ( d1 -- d2 )            double  d_negate
 /* use dminus as alias */  /* use dminus as alias */
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_ADD
 d2 = dnegate(d1);  d2 = dnegate(d1);
 #else  #else
 d2 = -d1;  d2 = -d1;
Line 768  d2 = -d1; Line 1043  d2 = -d1;
   
 d2*     ( d1 -- d2 )            double          d_two_star  d2*     ( d1 -- d2 )            double          d_two_star
 ""Shift left by 1; also works on unsigned numbers""  ""Shift left by 1; also works on unsigned numbers""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_SHIFT
 d2.lo = d1.lo<<1;  DLO_IS(d2, DLO(d1)<<1);
 d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));  DHI_IS(d2, (DHI(d1)<<1) | (DLO(d1)>>(CELL_BITS-1)));
 #else  #else
 d2 = 2*d1;  d2 = 2*d1;
 #endif  #endif
Line 780  d2 = 2*d1; Line 1055  d2 = 2*d1;
 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  ""Arithmetic shift right by 1.  For signed numbers this is a floored
 division by 2.""  division by 2.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_SHIFT
 d2.hi = d1.hi>>1;  DHI_IS(d2, DHI(d1)>>1);
 d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));  DLO_IS(d2, (DLO(d1)>>1) | (DHI(d1)<<(CELL_BITS-1)));
 #else  #else
 d2 = d1>>1;  d2 = d1>>1;
 #endif  #endif
Line 808  w2 = ~w1; Line 1083  w2 = ~w1;
   
 rshift  ( u1 n -- u2 )          core    r_shift  rshift  ( u1 n -- u2 )          core    r_shift
 ""Logical shift right by @i{n} bits.""  ""Logical shift right by @i{n} bits.""
   u2 = u1>>n;  #ifdef BROKEN_SHIFT
     u2 = rshift(u1, n);
   #else
     u2 = u1 >> n;
   #endif
 :  :
     0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
   
 lshift  ( u1 n -- u2 )          core    l_shift  lshift  ( u1 n -- u2 )          core    l_shift
   u2 = u1<<n;  #ifdef BROKEN_SHIFT
     u2 = lshift(u1, n);
   #else
     u2 = u1 << n;
   #endif
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
   \g compare
   
 \ 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
Line 875  comparisons(u, u1 u2, u_, u1, u2, gforth Line 1160  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_LL_CMP
 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      $3not_equals  $1<>    ( $2 -- f )             $7      $3not_equals
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 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_than  $1<     ( $2 -- f )             $8      $3less_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 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_than  $1>     ( $2 -- f )             $9      $3greater_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 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_LL_CMP
 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_LL_CMP
 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);
Line 938  f = FLAG(u1-u2 < u3-u2); Line 1223  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
 \g internal  \g stack
   
   useraddr        ( #u -- a_addr )        new
   a_addr = (Cell *)(up+u);
   
   up!     ( a_addr -- )   gforth  up_store
   UP=up=(char *)a_addr;
   :
    up ! ;
   Variable UP
   
 sp@     ( -- a_addr )           gforth          sp_fetch  sp@     ( S:... -- a_addr )             gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp;
   
 sp!     ( a_addr -- )           gforth          sp_store  sp!     ( a_addr -- S:... )             gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without spTOS caching */  
   
 rp@     ( -- a_addr )           gforth          rp_fetch  rp@     ( -- a_addr )           gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
Line 955  rp = a_addr; Line 1248  rp = a_addr;
   
 \+floating  \+floating
   
 fp@     ( -- f_addr )   gforth  fp_fetch  fp@     ( f:... -- f_addr )     gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
   
 fp!     ( f_addr -- )   gforth  fp_store  fp!     ( f_addr -- f:... )     gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 \+  \+
   
 ;s      ( R:w -- )              gforth  semis  
 ""The primitive compiled by @code{EXIT}.""  
 #ifdef NO_IP  
 INST_TAIL;  
 goto *(void *)w;  
 #else  
 SET_IP((Xt *)w);  
 #endif  
   
 \g stack  
   
 >r      ( w -- R:w )            core    to_r  >r      ( w -- R:w )            core    to_r
 :  :
  (>r) ;   (>r) ;
Line 988  rdrop ( R:w -- )  gforth Line 1270  rdrop ( R:w -- )  gforth
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     ( w1 w2 -- R:w1 R:w2 )  core-ext        two_to_r  2>r     ( d -- R:d )    core-ext        two_to_r
 :  :
  swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;
   
 2r>     ( R:w1 R:w2 -- w1 w2 )  core-ext        two_r_from  2r>     ( R:d -- d )    core-ext        two_r_from
 :  :
  r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;
   
 2r@     ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )        core-ext        two_r_fetch  2r@     ( R:d -- R:d d )        core-ext        two_r_fetch
 :  :
  i' j ;   i' j ;
   
 2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop  2rdrop  ( R:d -- )              gforth  two_r_drop
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1042  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1324  tuck ( w1 w2 -- w2 w1 w2 ) core-ext
 :  :
  swap over ;   swap over ;
   
 ?dup    ( w -- w )                      core    question_dupe  ?dup    ( w -- S:... w )        core    question_dupe
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a  ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""  @code{dup} if w is nonzero.""
 if (w!=0) {  if (w!=0) {
   IF_spTOS(*sp-- = w;)  
 #ifndef USE_TOS  
   *--sp = w;    *--sp = w;
 #endif  
 }  }
 :  :
  dup IF dup THEN ;   dup IF dup THEN ;
   
 pick    ( u -- w )                      core-ext  pick    ( S:... u -- S:... w )          core-ext
 ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""  ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
 w = sp[u+1];  w = sp[u];
 :  :
  1+ cells sp@ + @ ;   1+ cells sp@ + @ ;
   
Line 1090  w = sp[u+1]; Line 1369  w = sp[u+1];
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
   \g memory
   
 @       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
 ""@i{w} is the cell stored at @i{a_addr}.""  ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
   
   \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
 !       ( w a_addr -- )         core    store  !       ( w a_addr -- )         core    store
 ""Store @i{w} into the cell at @i{a-addr}.""  ""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;  *a_addr = w;
Line 1211  c_addr2 = c_addr1+1; Line 1497  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
   \g compiler
   
   \+f83headerstring
   
 (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 &&
Line 1224  f83name2=f83name1; Line 1514  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 ;
   : capscomp ( c_addr1 u c_addr2 -- n )
    swap bounds
    ?DO  dup c@ I c@ <>
        IF  dup c@ toupper I c@ toupper =
        ELSE  true  THEN  WHILE  1+  LOOP  drop 0
    ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
   : sgn ( n -- -1/0/1 )
    dup 0= IF EXIT THEN  0< 2* 1+ ;
   
   \-
   
   (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
   longname2=listlfind(c_addr, u, 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 ;
   : capscomp ( c_addr1 u c_addr2 -- n )
    swap bounds
    ?DO  dup c@ I c@ <>
        IF  dup c@ toupper I c@ toupper =
        ELSE  true  THEN  WHILE  1+  LOOP  drop 0
    ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
   : sgn ( n -- -1/0/1 )
    dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 \+hash  \+hash
   
 (hashfind)      ( c_addr u a_addr -- f83name2 ) new     paren_hashfind  (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind
 struct F83Name *f83name1;  longname2 = hashlfind(c_addr, u, a_addr);
 f83name2=NULL;  
 while(a_addr != NULL)  
 {  
    f83name1=(struct F83Name *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)F83NAME_COUNT(f83name1)==u &&  
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  
      {  
         f83name2=f83name1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ c@ $1F and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
         IF  2dup r@ cell+ char+ capscomp 0=          IF  2dup r@ cell+ cell+ capscomp 0=
             IF  2drop r> rdrop  EXIT  THEN  THEN              IF  2drop r> rdrop  EXIT  THEN  THEN
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (tablefind)     ( c_addr u a_addr -- f83name2 ) new     paren_tablefind  (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind
 ""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
 struct F83Name *f83name1;  longname2 = tablelfind(c_addr, u, a_addr);
 f83name2=NULL;  
 while(a_addr != NULL)  
 {  
    f83name1=(struct F83Name *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)F83NAME_COUNT(f83name1)==u &&  
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  
      {  
         f83name2=f83name1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ c@ $1F and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
         IF  2dup r@ cell+ char+ -text 0=          IF  2dup r@ cell+ cell+ -text 0=
             IF  2drop r> rdrop  EXIT  THEN  THEN              IF  2drop r> rdrop  EXIT  THEN  THEN
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   : -text ( c_addr1 u c_addr2 -- n )
 (hashkey)       ( c_addr u1 -- u2 )             gforth  paren_hashkey   swap bounds
 u2=0;   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
 while(u1--)   ELSE  c@ I c@ - unloop  THEN  sgn ;
    u2+=(Cell)toupper(*c_addr++);  : sgn ( n -- -1/0/1 )
 :   dup 0= IF EXIT THEN  0< 2* 1+ ;
  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  ukey = hashkey1(c_addr, u, ubits);
    ubits bits and xors it with the character. This function does ok in  
    the chi-sqare-test.  Rot should be <=7 (preferably <=5) for  
    ASCII strings (larger if ubits is large), and should share no  
    divisors with ubits.  
 */  
 static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5};  
 unsigned rot = rot_values[ubits];  
 Char *cp = c_addr;  
 for (ukey=0; cp<c_addr+u; cp++)  
     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))   
              ^ toupper(*cp))  
             & ((1<<ubits)-1));  
 :  :
  dup rot-values + c@ over 1 swap lshift 1- >r   dup rot-values + c@ over 1 swap lshift 1- >r
  tuck - 2swap r> 0 2swap bounds   tuck - 2swap r> 0 2swap bounds
Line 1310  Create rot-values Line 1592  Create rot-values
   
 \+  \+
   
   \+
   
 (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? */  struct Cellpair r=parse_white(c_addr1, u1);
 Char *endp = c_addr1+u1;  c_addr2 = (Char *)(r.n1);
 while (c_addr1<endp && isspace(*c_addr1))  u2 = r.n2;
   c_addr1++;  
 if (c_addr1<endp) {  
   for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)  
     ;  
   u2 = c_addr1-c_addr2;  
 }  
 else {  
   c_addr2 = c_addr1;  
   u2 = 0;  
 }  
 :  :
  BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string   BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string
  REPEAT  THEN  2dup   REPEAT  THEN  2dup
Line 1342  f_addr = (Float *)((((Cell)c_addr)+(size Line 1616  f_addr = (Float *)((((Cell)c_addr)+(size
 :  :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 >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);  
 :  
     2 cells + ;  
   
 \ threading stuff is currently only interesting if we have a compiler  \ threading stuff is currently only interesting if we have a compiler
 \fhas? standardthreading has? compiler and [IF]  \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 */  
 c_addr = (Address)CODE_ADDRESS(xt);  
 :  
     @ ;  
   
 >does-code      ( xt -- a_addr )                gforth  to_does_code  
 ""If @i{xt} is the execution token of a child of a @code{DOES>} word,  
 @i{a-addr} is the start of the Forth code after the @code{DOES>};  
 Otherwise @i{a-addr} is 0.""  
 a_addr = (Cell *)DOES_CODE(xt);  
 :  
     cell+ @ ;  
   
 code-address!   ( c_addr xt -- )                gforth  code_address_store  
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  
 MAKE_CF(xt, c_addr);  
 :  
     ! ;  
   
 does-code!      ( a_addr xt -- )                gforth  does_code_store  
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;  
 @i{a-addr} is the start of the Forth code after @code{DOES>}.""  
 MAKE_DOES_CF(xt, a_addr);  
 :  
     dodoes: over ! cell+ ! ;  
   
 does-handler!   ( a_addr -- )   gforth  does_handler_store  
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  
 @i{a-addr} points just behind a @code{DOES>}.""  
 MAKE_DOES_HANDLER(a_addr);  
 :  
     drop ;  
   
 /does-handler   ( -- n )        gforth  slash_does_handler  
 ""The size of a @code{DOES>}-handler (includes possible padding).""  
 /* !! a constant or environmental query might be better */  
 n = DOES_HANDLER_SIZE;  
 :  
     2 cells ;  
   
 threading-method        ( -- n )        gforth  threading_method  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.""
Line 1464  FLUSH_ICACHE(c_addr,u); Line 1688  FLUSH_ICACHE(c_addr,u);
 SUPER_END;  SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  paren_system
 #ifndef MSDOS  wretval = gforth_system(c_addr, u);  
 int old_tp=terminal_prepped;  
 deprep_terminal();  
 #endif  
 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)  
   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}  ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
Line 1496  wior = IOR(wretval==-1); Line 1712  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.  ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
 Months are numbered from 1.""  Months are numbered from 1.""
   #if 1
   time_t now;
   struct tm *ltime;
   time(&now);
   ltime=localtime(&now);
   #else
 struct timeval time1;  struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
Line 1503  gettimeofday(&time1,&zone1); Line 1725  gettimeofday(&time1,&zone1);
 /* !! Single Unix specification:   /* !! Single Unix specification: 
    If tzp is not a null pointer, the behaviour is unspecified. */     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);
   #endif
 nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
 nmonth=ltime->tm_mon+1;  nmonth=ltime->tm_mon+1;
 nday  =ltime->tm_mday;  nday  =ltime->tm_mday;
Line 1556  c_addr = strerror(n); Line 1779  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 = (Address)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_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_spTOS(spTOS=sp[0]);  
 IF_fpTOS(fpTOS=fp[0]);  
   
 \+  \+
 \+file  \+file
Line 1600  wior = IOR(unlink(tilde_cstr(c_addr, u, Line 1820  wior = IOR(unlink(tilde_cstr(c_addr, u,
   
 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}""  ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);  wior = rename_file(c_addr1, u1, c_addr2, u2);
 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? */
Line 1627  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1846  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 u3 wior ) file   paren_read_line
 /* this may one day be replaced with : read-line (read-line) nip ; */  struct Cellquad r = read_line(c_addr, u1, wfileid);
 Cell c;  u2   = r.n1;
 flag=-1;  flag = r.n2;
 for(u2=0; u2<u1; u2++)  u3   = r.n3;
 {  wior = r.n4;
    c = getc((FILE *)wfileid);  
    if (c=='\n') break;  
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  
        ungetc(c,(FILE *)wfileid);  
      break;  
    }  
    if (c==EOF) {  
         flag=FLAG(u2!=0);  
         break;  
      }  
    c_addr[u2] = (Char)c;  
 }  
 wior=FILEIO(ferror((FILE *)wfileid));  
   
 \+  \+
   
Line 1678  flush-file ( wfileid -- wior )  file-ext Line 1883  flush-file ( wfileid -- wior )  file-ext
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 file-status     ( c_addr u -- wfam wior )       file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
 char *filename=tilde_cstr(c_addr, u, 1);  struct Cellpair r = file_status(c_addr, u);
 if (access (filename, F_OK) != 0) {  wfam = r.n1;
   wfam=0;  wior = r.n2;
   wior=IOR(1);  
 }  file-eof?       ( wfileid -- flag )     gforth  file_eof_query
 else if (access (filename, R_OK | W_OK) == 0) {  flag = FLAG(feof((FILE *) wfileid));
   wfam=2; /* r/w */  
   wior=0;  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
 }  ""Open the directory specified by @i{c-addr, u}
 else if (access (filename, R_OK) == 0) {  and return @i{dir-id} for futher access to it.""
   wfam=0; /* r/o */  wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
   wior=0;  wior =  IOR(wdirid == 0);
 }  
 else if (access (filename, W_OK) == 0) {  read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
   wfam=4; /* w/o */  ""Attempt to read the next entry from the directory specified
   wior=0;  by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. 
 }  If the attempt fails because there is no more entries,
 else {  @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
   wfam=1; /* well, we cannot access the file, but better deliver a legal  If the attempt to read the next entry fails because of any other reason, 
             access mode (r/o bin), so we get a decent error later upon open. */  return @i{ior}<>0.
   wior=0;  If the attempt succeeds, store file name to the buffer at @i{c-addr}
   and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
   If the length of the file name is greater than @i{u1}, 
   store first @i{u1} characters from file name into the buffer and
   indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
   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
   ""Close the directory specified by @i{dir-id}.""
   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));
   
   set-dir ( c_addr u -- wior )    gforth set_dir
   ""Change the current directory to @i{c-addr, u}.
   Return an error if this is not possible""
   wior = IOR(chdir(tilde_cstr(c_addr, u, 1)));
   
   get-dir ( c_addr1 u1 -- c_addr2 u2 )    gforth get_dir
   ""Store the current directory in the buffer specified by @{c-addr1, u1}.
   If the buffer size is not sufficient, return 0 0""
   c_addr2 = getcwd(c_addr1, u1);
   if(c_addr2 != NULL) {
     u2 = strlen(c_addr2);
   } else {
     u2 = 0;
 }  }
   
 \+  \+
   
   newline ( -- c_addr u ) gforth
   ""String containing the newline sequence of the host OS""
   char newline[] = {
   #if DIRSEP=='/'
   /* Unix */
   '\n'
   #else
   /* DOS, Win, OS/2 */
   '\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);
   dsystem = DZERO;
   #endif
   
   \+
   
 \+floating  \+floating
   
 \g floating  \g floating
Line 1710  comparisons(f, r1 r2, f_, r1, r2, gforth Line 2003  comparisons(f, r1 r2, f_, r1, r2, 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_LL_D2F
 extern double ldexp(double x, int exp);  extern double ldexp(double x, int exp);
 r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;  if (DHI(d)<0) {
   #ifdef BUGGY_LL_ADD
     DCell d2=dnegate(d);
   #else
     DCell d2=-d;
   #endif
     r = -(ldexp((Float)DHI(d2),CELL_BITS) + (Float)DLO(d2));
   } else
     r = ldexp((Float)DHI(d),CELL_BITS) + (Float)DLO(d);
 #else  #else
 r = d;  r = d;
 #endif  #endif
Line 1827  else Line 2128  else
   
 represent       ( r c_addr u -- n f1 f2 )       float  represent       ( r c_addr u -- n f1 f2 )       float
 char *sig;  char *sig;
   size_t siglen;
 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((unsigned)(sig[0]))!=0);  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);  siglen=strlen(sig);
   if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */
     siglen=u;
   if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */
     for (; sig[siglen-1]=='0'; siglen--);
       ;
   memcpy(c_addr,sig,siglen);
   memset(c_addr+siglen,f2?'0':' ',u-siglen);
   
 >float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- f:... flag )      float   to_float
 ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
 character string @i{c-addr u} to internal floating-point  character string @i{c-addr u} to internal floating-point
 representation. If the string represents a valid floating-point number  representation. If the string represents a valid floating-point number
 @i{r} is placed on the floating-point stack and @i{flag} is  @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  true. Otherwise, @i{flag} is false. A string of blanks is a special
 case and represents the floating-point number 0.""  case and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */  
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  flag = to_float(c_addr, u, &r);
 char *endconv;  if (flag) {
 int sign = 0;    fp--;
 if(number[0]=='-') {    fp[0]=r;
    sign = 1;  
    number++;  
    u--;  
 }  
 while(isspace((unsigned)(number[--u])) && u>0);  
 switch(number[u])  
 {  
    case 'd':  
    case 'D':  
    case 'e':  
    case 'E':  break;  
    default :  u++; break;  
 }  
 number[u]='\0';  
 r=strtod(number,&endconv);  
 if((flag=FLAG(!(Cell)*endconv)))  
 {  
    IF_fpTOS(fp[0] = fpTOS);  
    fp += -1;  
    fpTOS = sign ? -r : r;  
 }  
 else if(*endconv=='d' || *endconv=='D')  
 {  
    *endconv='E';  
    r=strtod(number,&endconv);  
    if((flag=FLAG(!(Cell)*endconv)))  
      {  
         IF_fpTOS(fp[0] = fpTOS);  
         fp += -1;  
         fpTOS = sign ? -r : r;  
      }  
 }  }
   
 fabs    ( r1 -- r2 )    float-ext       f_abs  fabs    ( r1 -- r2 )    float-ext       f_abs
Line 2013  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2290  df_addr = (DFloat *)((((Cell)c_addr)+(si
 :  :
  [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
 \ The following words access machine/OS/installation-dependent  v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
 \   Gforth internals  ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
 \ !! how about environmental queries DIRECT-THREADED,  next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  ucount elements.""
   r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount);
   :
    >r swap 2swap swap 0e r> 0 ?DO
        dup f@ over + 2swap dup f@ f* f+ over + 2swap
    LOOP 2drop 2drop ; 
   
 \ local variable implementation primitives  faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
 \+  ""vy=ra*vx+vy""
 \+glocals  faxpy(ra, f_x, nstridex, f_y, nstridey, ucount);
   :
    >r swap 2swap swap r> 0 ?DO
        fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
    LOOP 2drop 2drop fdrop ;
   
   \+
   
   \ The following words access machine/OS/installation-dependent
   \   Gforth internals
   \ !! how about environmental queries DIRECT-THREADED,
   \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
   \ local variable implementation primitives
   
   \+glocals
   
   \g locals
   
 @local# ( #noffset -- w )       gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
 w = *(Cell *)(lp+noffset);  w = *(Cell *)(lp+noffset);
   
 @local0 ( -- w )        new     fetch_local_zero  @local0 ( -- w )        new     fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));  w = ((Cell *)lp)[0];
   
 @local1 ( -- w )        new     fetch_local_four  @local1 ( -- w )        new     fetch_local_four
 w = *(Cell *)(lp+1*sizeof(Cell));  w = ((Cell *)lp)[1];
   
 @local2 ( -- w )        new     fetch_local_eight  @local2 ( -- w )        new     fetch_local_eight
 w = *(Cell *)(lp+2*sizeof(Cell));  w = ((Cell *)lp)[2];
   
 @local3 ( -- w )        new     fetch_local_twelve  @local3 ( -- w )        new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = ((Cell *)lp)[3];
   
 \+floating  \+floating
   
Line 2043  f@local# ( #noffset -- r ) gforth f_fetc Line 2342  f@local# ( #noffset -- r ) gforth f_fetc
 r = *(Float *)(lp+noffset);  r = *(Float *)(lp+noffset);
   
 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];
   
 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];
   
 \+  \+
   
Line 2082  f>l ( r -- ) gforth f_to_l Line 2381  f>l ( r -- ) gforth f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 fpick   ( u -- r )              gforth  fpick   ( f:... u -- f:... r )          gforth
 ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""  ""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];
 :  :
  floats fp@ + f@ ;   floats fp@ + f@ ;
   
Line 2093  r = fp[u+1]; /* +1, because update of fp Line 2392  r = fp[u+1]; /* +1, because update of fp
   
 \+OS  \+OS
   
 define(`uploop',  \g syslib
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')  
 define(`_uploop',  
        `ifelse($1, `$3', `$5',  
                `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')  
 \ argflist(argnum): Forth argument list  
 define(argflist,  
        `ifelse($1, 0, `',  
                `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')  
 \ argdlist(argnum): declare C's arguments  
 define(argdlist,  
        `ifelse($1, 0, `',  
                `uploop(`_i', 1, $1, `Cell, ', `Cell')')')  
 \ argclist(argnum): pass C's arguments  
 define(argclist,  
        `ifelse($1, 0, `',  
                `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')  
 \ icall(argnum)  
 define(icall,  
 `icall$1        ( argflist($1)u -- uret )       gforth  
 uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));  
   
 ')  
 define(fcall,  
 `fcall$1        ( argflist($1)u -- rret )       gforth  
 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)
Line 2151  u3 = 0; Line 2421  u3 = 0;
 #  endif  #  endif
 #endif  #endif
   
 uploop(i, 0, 7, `icall(i)')  wcall   ( ... u -- ... )        gforth
 icall(20)  
 uploop(i, 0, 7, `fcall(i)')  
 fcall(20)  
   
 \+  
   
 up!     ( a_addr -- )   gforth  up_store  
 UP=up=(char *)a_addr;  
 :  
  up ! ;  
 Variable UP  
   
 wcall   ( u -- )        gforth  
 IF_fpTOS(fp[0]=fpTOS);  
 FP=fp;  FP=fp;
 sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);  sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;  fp=FP;
 IF_spTOS(spTOS=sp[0];)  
 IF_fpTOS(fpTOS=fp[0]);  
   
 \+file  \+FFCALL
   
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  av-start-void   ( c_addr -- )   gforth  av_start_void
 ""Open the directory specified by @i{c-addr, u}  av_start_void(alist, c_addr);
 and return @i{dir-id} for futher access to it.""  
 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  av-start-int    ( c_addr -- )   gforth  av_start_int
 ""Attempt to read the next entry from the directory specified  av_start_int(alist, c_addr, &irv);
 by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}.   
 If the attempt fails because there is no more entries,  
 @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.  
 If the attempt to read the next entry fails because of any other reason,   
 return @i{ior}<>0.  
 If the attempt succeeds, store file name to the buffer at @i{c-addr}  
 and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.  
 If the length of the file name is greater than @i{u1},   
 store first @i{u1} characters from file name into the buffer and  
 indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""  
 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  av-start-float  ( c_addr -- )   gforth  av_start_float
 ""Close the directory specified by @i{dir-id}.""  av_start_float(alist, c_addr, &frv);
 wior = IOR(closedir((DIR *)wdirid));  
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  av-start-double ( c_addr -- )   gforth  av_start_double
 char * string = cstr(c_addr1, u1, 1);  av_start_double(alist, c_addr, &drv);
 char * pattern = cstr(c_addr2, u2, 0);  
 flag = FLAG(!fnmatch(pattern, string, 0));  
   
 \+  av-start-longlong       ( c_addr -- )   gforth  av_start_longlong
   av_start_longlong(alist, c_addr, &llrv);
   
 newline ( -- c_addr u ) gforth  av-start-ptr    ( c_addr -- )   gforth  av_start_ptr
 ""String containing the newline sequence of the host OS""  av_start_ptr(alist, c_addr, void*, &prv);
 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  av-int  ( w -- )  gforth  av_int
   av_int(alist, w);
   
 utime   ( -- dtime )    gforth  av-float        ( r -- )        gforth  av_float
 ""Report the current time in microseconds since some epoch.""  av_float(alist, r);
 struct timeval time1;  
 gettimeofday(&time1,NULL);  
 dtime = timeval2us(&time1);  
   
 cputime ( -- duser dsystem ) gforth  av-double       ( r -- )        gforth  av_double
 ""duser and dsystem are the respective user- and system-level CPU  av_double(alist, r);
 times used since the start of the Forth system (excluding child  
 processes), in microseconds (the granularity may be much larger,  av-longlong     ( d -- )        gforth  av_longlong
 however).  On platforms without the getrusage call, it reports elapsed  #ifdef BUGGY_LL_SIZE
 time (since some epoch) for duser and 0 for dsystem.""  av_longlong(alist, DLO(d));
 #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  #else
 dsystem=(DCell){0,0};  av_longlong(alist, d);
 #endif  
 #endif  #endif
   
 \+  av-ptr  ( c_addr -- )   gforth  av_ptr
   av_ptr(alist, void*, c_addr);
 \+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  av-int-r  ( R:w -- )  gforth  av_int_r
 ""vy=ra*vx+vy""  av_int(alist, w);
 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 ;  
   
 \+  av-float-r      ( -- )  gforth  av_float_r
   float r = *(Float*)lp;
   lp += sizeof(Float);
   av_float(alist, r);
   
 \+file  av-double-r     ( -- )  gforth  av_double_r
   double r = *(Float*)lp;
   lp += sizeof(Float);
   av_double(alist, r);
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line  av-longlong-r   ( R:d -- )      gforth  av_longlong_r
 Cell c;  #ifdef BUGGY_LL_SIZE
 flag=-1;  av_longlong(alist, DLO(d));
 u3=0;  #else
 for(u2=0; u2<u1; u2++)  av_longlong(alist, d);
 {  #endif
    c = getc((FILE *)wfileid);  
    u3++;  av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r
    if (c=='\n') break;  av_ptr(alist, void*, c_addr);
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  av-call-void    ( ... -- ... )  gforth  av_call_void
        ungetc(c,(FILE *)wfileid);  SAVE_REGS
      else  av_call(alist);
        u3++;  REST_REGS
      break;  
    }  av-call-int     ( ... -- ... w )        gforth  av_call_int
    if (c==EOF) {  SAVE_REGS
         flag=FLAG(u2!=0);  av_call(alist);
         break;  REST_REGS
      }  w = irv;
    c_addr[u2] = (Char)c;  
 }  av-call-float   ( ... -- ... r )        gforth  av_call_float
 wior=FILEIO(ferror((FILE *)wfileid));  SAVE_REGS
   av_call(alist);
   REST_REGS
   r = frv;
   
   av-call-double  ( ... -- ... r )        gforth  av_call_double
   SAVE_REGS
   av_call(alist);
   REST_REGS
   r = drv;
   
   av-call-longlong        ( ... -- ... d )        gforth  av_call_longlong
   SAVE_REGS
   av_call(alist);
   REST_REGS
   #ifdef BUGGY_LONG_LONG
   DLO_IS(d, llrv);
   DHI_IS(d, 0);
   #else
   d = llrv;
   #endif
   
 \+  av-call-ptr     ( ... -- ... c_addr )   gforth  av_call_ptr
   SAVE_REGS
   av_call(alist);
   REST_REGS
   c_addr = prv;
   
 (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind  alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback
 for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))  c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);
   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  va-start-void   ( -- )  gforth  va_start_void
   va_start_void(clist);
   
 (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind  va-start-int    ( -- )  gforth  va_start_int
 struct Longname *longname1;  va_start_int(clist);
 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  va-start-longlong       ( -- )  gforth  va_start_longlong
 ""A case-sensitive variant of @code{(hashfind)}""  va_start_longlong(clist);
 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 ;  
   
 \+  va-start-ptr    ( -- )  gforth  va_start_ptr
   va_start_ptr(clist, (char *));
   
 \+peephole  va-start-float  ( -- )  gforth  va_start_float
   va_start_float(clist);
   
 \g peephole  va-start-double ( -- )  gforth  va_start_double
   va_start_double(clist);
   
 primtable       ( -- wprimtable )       new  va-arg-int      ( -- w )        gforth  va_arg_int
 ""wprimtable is a table containing the xts of the primitives indexed  w = va_arg_int(clist);
 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  va-arg-longlong ( -- d )        gforth  va_arg_longlong
 ""Call callee (a variant of docol with inline argument).""  #ifdef BUGGY_LONG_LONG
 #ifdef NO_IP  DLO_IS(d, va_arg_longlong(clist));
 INST_TAIL;  DHI_IS(d, 0);
 JUMP(a_callee);  
 #else  #else
 #ifdef DEBUG  d = va_arg_longlong(clist);
     {  
       CFA_TO_NAME((((Cell *)a_callee)-2));  
       fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,  
               len,name);  
     }  
 #endif  
 a_retaddr = (Cell *)IP;  
 SET_IP((Xt *)a_callee);  
 #endif  #endif
   
 useraddr        ( #u -- a_addr )        new  va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr
 a_addr = (Cell *)(up+u);  c_addr = (char *)va_arg_ptr(clist,char*);
   
 compile-prim ( xt1 -- xt2 )     obsolete        compile_prim  
 xt2 = (Xt)compile_prim((Label)xt1);  
   
 \ lit@ / lit_fetch = lit @  va-arg-float    ( -- r )        gforth  va_arg_float
   r = va_arg_float(clist);
   
 lit@            ( #a_addr -- w ) new    lit_fetch  va-arg-double   ( -- r )        gforth  va_arg_double
 w = *a_addr;  r = va_arg_double(clist);
   
 lit-perform     ( #a_addr -- )  new     lit_perform  va-return-void ( -- )   gforth va_return_void
 #ifndef NO_IP  va_return_void(clist);
 ip=IP;  return 0;
 #endif  
 SUPER_END;  
 EXEC(*(Xt *)a_addr);  
   
 \ lit+ / lit_plus = lit +  va-return-int ( w -- )  gforth va_return_int
   va_return_int(clist, w);
   return 0;
   
 lit+    ( n1 #n2 -- n )         new     lit_plus  va-return-ptr ( c_addr -- )     gforth va_return_ptr
 n=n1+n2;  va_return_ptr(clist, void *, c_addr);
   return 0;
   
 does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec  va-return-longlong ( d -- )     gforth va_return_longlong
 #ifdef NO_IP  #ifdef BUGGY_LONG_LONG
 /* compiled to LIT CALL by compile_prim */  va_return_longlong(clist, d.lo);
 assert(0);  
 #else  #else
 a_pfa = PFA(a_cfa);  va_return_longlong(clist, d);
 nest = (Cell)IP;  
 IF_spTOS(spTOS = sp[0]);  
 #ifdef DEBUG  
     {  
       CFA_TO_NAME(a_cfa);  
       fprintf(stderr,"%08lx: does %08lx %.*s\n",  
               (Cell)ip,(Cell)a_cfa,len,name);  
     }  
 #endif  
 SET_IP(DOES_CODE1(a_cfa));  
 #endif  #endif
   return 0;
   
 abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number  va-return-float ( r -- )        gforth va_return_float
 /* this will probably not be used */  va_return_float(clist, r);
 lp += nlocals;  return 0;
 #ifdef NO_IP  
 INST_TAIL;  va-return-double ( r -- )       gforth va_return_double
 JUMP(a_target);  va_return_double(clist, r);
 #else  return 0;
 SET_IP((Xt *)a_target);  
 #endif  
   
 \+  \+
   
 abranch ( #a_target -- )        gforth  \+OLDCALL
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 #endif  
 :  
  r> @ >r ;  
   
 \ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)  
 \ this is non-syntactical: code must open a brace that is closed by the macro  
 define(acondbranch,  
 $1 ( `#'a_target $2 ) $3  
 $4      #ifdef NO_IP  
 INST_TAIL;  
 #endif  
 $5      #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 $6  
   
 \+glocals  
   
 $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number  
 $4      #ifdef NO_IP  
 INST_TAIL;  
 #endif  
 $5      lp += nlocals;  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 \+  define(`uploop',
 )         `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
   define(`_uploop',
 acondbranch(a?branch,f --,f83   aquestion_branch,         `ifelse($1, `$3', `$5',
 ,if (f==0) {                 `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')
 ,:  \ argflist(argnum): Forth argument list
  0= dup     \ !f !f \ !! still uses relative addresses  define(argflist,
  r> dup @   \ !f !f IP branchoffset         `ifelse($1, 0, `',
  rot and +  \ !f IP|IP+branchoffset                 `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')
  swap 0= cell and + \ IP''  \ argdlist(argnum): declare C's arguments
  >r ;)  define(argdlist,
          `ifelse($1, 0, `',
                  `uploop(`_i', 1, $1, `Cell, ', `Cell')')')
   \ argclist(argnum): pass C's arguments
   define(argclist,
          `ifelse($1, 0, `',
                  `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')
   \ icall(argnum)
   define(icall,
   `icall$1        ( argflist($1)u -- uret )       gforth
   uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
   
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  ')
 \ is only used in if's (yet)  define(fcall,
   `fcall$1        ( argflist($1)u -- rret )       gforth
   rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
   
 \+xconds  ')
   
 a?dup-?branch   ( #a_target f -- f )    new     aquestion_dupe_question_branch  \ close ' to keep fontify happy
 ""The run-time procedure compiled by @code{?DUP-IF}.""  
 if (f==0) {  
   sp++;  
   IF_spTOS(spTOS = sp[0]);  
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
   INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 a?dup-0=-?branch ( #a_target f -- ) new aquestion_dupe_zero_equals_question_branch  uploop(i, 0, 7, `icall(i)')
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  icall(20)
 /* the approach taken here of declaring the word as having the stack  uploop(i, 0, 7, `fcall(i)')
 effect ( f -- ) and correcting for it in the branch-taken case costs a  fcall(20)
 few cycles in that case, but is easy to convert to a CONDBRANCH  
 invocation */  
 if (f!=0) {  
   sp--;  
 #ifdef NO_IP  
   JUMP(a_target);  
 #else  
   SET_IP((Xt *)a_target);  
   NEXT;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 \+  \+
 \f[THEN]  \+
 \fhas? skiploopprims 0= [IF]  
   
 acondbranch(a(next),R:n1 -- R:n2,cmFORTH        aparen_next,  
 n2=n1-1;  
 ,if (n1) {  
 ,:  
  r> r> dup 1- >r  
  IF @ >r ELSE cell+ >r THEN ;)  
   
 acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth       aparen_loop,  
 n2=n1+1;  
 ,if (n2 != nlimit) {  
 ,:  
  r> r> 1+ r> 2dup =  
  IF >r 1- >r cell+ >r  
  ELSE >r >r @ >r THEN ;)  
   
 acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,  
 /* !! check this thoroughly */  
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  
 /* dependent upon two's complement arithmetic */  
 Cell olddiff = n1-nlimit;  
 n2=n1+n;          
 ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {  
 ,:  
  r> swap  
  r> r> 2dup - >r  
  2 pick r@ + r@ xor 0< 0=  
  3 pick r> xor 0< 0= or  
  IF    >r + >r @ >r  
  ELSE  >r >r drop cell+ >r THEN ;)  
   
 \+xconds  
   
 acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,  
 UCell olddiff = n1-nlimit;  
 n2=n1-u;  
 ,if (olddiff>u) {  
 ,)  
   
 acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth   aparen_symmetric_plus_loop,  
 ""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  
 version of (+LOOP).""  
 /* !! check this thoroughly */  
 Cell diff = n1-nlimit;  
 Cell newdiff = diff+n;  
 if (n<0) {  
     diff = -diff;  
     newdiff = -newdiff;  
 }  
 n2=n1+n;  
 ,if (diff>=0 || newdiff<0) {  
 ,)  
   
 a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth  aparen_question_do  \g peephole
 #ifdef NO_IP  
     INST_TAIL;  
 #endif  
 if (nstart == nlimit) {  
 #ifdef NO_IP  
     JUMP(a_target);  
 #else  
     SET_IP((Xt *)a_target);  
     INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
   2dup =  
   IF   r> swap rot >r >r  
        @ >r  
   ELSE r> swap rot >r >r  
        cell+ >r  
   THEN ;                                \ --> CORE-EXT  
   
 \+xconds  \+peephole
   
 a(+do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do  compile-prim1 ( a_prim -- ) gforth compile_prim1
 #ifdef NO_IP  ""compile prim (incl. immargs) at @var{a_prim}""
     INST_TAIL;  compile_prim1(a_prim);
 #endif  
 if (nstart >= nlimit) {  
 #ifdef NO_IP  
     JUMP(a_target);  
 #else  
     SET_IP((Xt *)a_target);  
     INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  >=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do  finish-code ( ... -- ... ) gforth finish_code
 #ifdef NO_IP  ""Perform delayed steps in code generation (branch resolution, I-cache
     INST_TAIL;  flushing).""
 #endif  /* The ... above are a workaround for a bug in gcc-2.95, which fails
 if (ustart >= ulimit) {     to save spTOS (gforth-fast --enable-force-reg) */
 #ifdef NO_IP  finish_code();
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  u>=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 a(-do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 #ifdef NO_IP  f = forget_dyncode(c_code);
     INST_TAIL;  
 #endif  
 if (nstart <= nlimit) {  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  <=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 #ifdef NO_IP  ""a_prim is the code address of the primitive that has been
     INST_TAIL;  compile_prim1ed to a_code""
 #endif  a_prim = (Cell *)decompile_code((Label)a_code);
 if (ustart <= ulimit) {  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  u<=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 \ set-next-code and call2 do not appear in images and can be  \ set-next-code and call2 do not appear in images and can be
 \ renumbered arbitrarily  \ renumbered arbitrarily
Line 2761  JUMP(a_callee); Line 2680  JUMP(a_callee);
 assert(0);  assert(0);
 #endif  #endif
   
 compile-prim1 ( a_prim -- ) gforth compile_prim1  tag-offsets ( -- a_addr ) gforth tag_offsets
 ""compile prim (incl. immargs) at @var{a_prim}""  extern Cell groups[32];
 compile_prim1(a_prim);  a_addr = groups;
   
 finish-code ( -- ) gforth finish_code  
 ""Perform delayed steps in code generation (branch resolution, I-cache  
 flushing).""  
 finish_code();  
   
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode  
 f = forget_dyncode(c_code);  
   
 decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim  
 ""a_prim is the code address of the primitive that has been  
 compile_prim1ed to a_code""  
 a_prim = decompile_code(a_code);  
   
 \+  \+
   
 include(peeprules.vmg)  \g static_super
   
 \+  ifdef(`STACK_CACHE_FILE',
   `include(peeprules.vmg)')
   
   \g end

Removed from v.1.108  
changed lines
  Added in v.1.174


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