Diff for /gforth/prim between versions 1.71 and 1.133

version 1.71, 2001/01/27 20:14:55 version 1.133, 2003/08/08 05:56:37
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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 53 Line 53
 \ your code does not fall through, the results are not stored into the  \ your code does not fall through, the results are not stored into the
 \ stack. Use different names on both sides of the '--', if you change a  \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).  \ value (some stores to the stack are optimized away).
 \   \
 \   \ For superinstructions the syntax is:
   \
   \ forth-name [/ c-name] = forth-name forth-name ...
   \
 \   \ 
 \ The stack variables have the following types:  \ The stack variables have the following types:
 \   \ 
 \ name matches  type  \ name matches  type
 \ f.*           Bool  \ f.*           Bool
 \ c.*           Char  \ c.*           Char
 \ [nw].*                Cell  \ [nw].*        Cell
 \ u.*           UCell  \ u.*           UCell
 \ d.*           DCell  \ d.*           DCell
 \ ud.*          UDCell  \ ud.*          UDCell
Line 72 Line 75
 \ 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 get-current prefixes set-current
 \E   \E 
 \E s" Bool"             single data-stack type-prefix f  \E s" Bool"             single data-stack type-prefix f
Line 91 Line 97
 \E s" DFloat *"         single data-stack type-prefix df_  \E s" DFloat *"         single data-stack type-prefix df_
 \E s" SFloat *"         single data-stack type-prefix sf_  \E s" SFloat *"         single data-stack type-prefix sf_
 \E s" Xt"               single data-stack type-prefix xt  \E s" Xt"               single data-stack type-prefix xt
 \E s" WID"              single data-stack type-prefix wid  
 \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 
Line 99 Line 104
 \E inst-stream  stack-prefix #  \E inst-stream  stack-prefix #
 \E   \E 
 \E set-current  \E set-current
   \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 128 Line 139
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   undefine(`symbols')
   
   \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
   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
 ip=IP;  ip=IP;
   #endif
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
   #ifndef NO_IP
 ip=IP;  ip=IP;
   #endif
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(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;
   EXEC(*(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;
   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
   
 \+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  \ 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
 TAIL;  INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 $5  SUPER_CONTINUE;
   $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;
 TAIL;  #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
   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 201  if (f==0) { Line 297  if (f==0) {
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( #ndisp f -- f )       new     question_dupe_question_branch  ?dup-?branch    ( #a_target 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_spTOS(spTOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
   TAIL;  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
 }  }
   SUPER_CONTINUE;
   
 ?dup-0=-?branch ( #ndisp f -- ) new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #a_target 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 218  few cycles in that case, but is easy to Line 320  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
   NEXT;    NEXT;
   #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 247  condbranch((+loop),n R:nlimit R:n1 -- R: Line 353  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))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 ,:  ,:
  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 262  if ((olddiff^(olddiff+n))>=0   /* the li Line 368  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 277  if (n<0) { Line 383  if (n<0) {
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 n2=n1+n;  n2=n1+n;
 if (diff>=0 || newdiff<0) {  ,if (diff>=0 || newdiff<0) {
 ,)  ,)
   
 \+  \+
   
 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
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (nstart == nlimit) {  if (nstart == nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     TAIL;      JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
       INST_TAIL; NEXT_P2;
   #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
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     TAIL;      JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
       INST_TAIL; NEXT_P2;
   #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
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     TAIL;  JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #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
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     TAIL;  JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #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
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     TAIL;  JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #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 404  k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 ) Line 545  k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
   \g strings
   
 move    ( c_from c_to ucount -- )               core  move    ( c_from c_to ucount -- )               core
 ""Copy the contents of @i{ucount} aus at @i{c-from} to  ""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.""  @i{c-to}. @code{move} works correctly even if the two areas overlap.""
Line 418  cmove ( c_from c_to u -- ) string c_move Line 561  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 428  cmove> ( c_from c_to u -- ) string c_mov Line 570  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 449  is 1. Currently this is based on the mac Line 590  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 )  : sgn ( n -- -1/0/1 )
  dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 -text   ( c_addr1 u c_addr2 -- n )      new     dash_text  \ -text is only used by replaced primitives now; move it elsewhere
 n = memcmp(c_addr1, c_addr2, u);  \ -text ( c_addr1 u c_addr2 -- n )      new     dash_text
 if (n<0)  \ n = memcmp(c_addr1, c_addr2, u);
   n = -1;  \ if (n<0)
 else if (n>0)  \   n = -1;
   n = 1;  \ else if (n>0)
 :  \   n = 1;
  swap bounds  \ :
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0  \  swap bounds
  ELSE  c@ I c@ - unloop  THEN  sgn ;  \  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
 : sgn ( n -- -1/0/1 )  \  ELSE  c@ I c@ - unloop  THEN  sgn ;
  dup 0= IF EXIT THEN  0< 2* 1+ ;  \ : 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}
Line 482  c2 = toupper(c1); Line 618  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 513  u2 = u1-n; Line 626  u2 = u1-n;
 :  :
  tuck - >r + r> dup 0< IF  - 0  THEN ;   tuck - >r + r> dup 0< IF  - 0  THEN ;
   
   \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 789  lshift ( u1 n -- u2 )  core l_shift Line 913  lshift ( u1 n -- u2 )  core l_shift
 :  :
     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 910  f = FLAG(u1-u2 < u3-u2); Line 1036  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
   \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@     ( -- a_addr )           gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp+1;
   
Line 933  fp = f_addr; Line 1070  fp = f_addr;
   
 \+  \+
   
 ;s      ( R:w -- )              gforth  semis  
 ""The primitive compiled by @code{EXIT}.""  
 SET_IP((Xt *)w);  
   
 >r      ( w -- R:w )            core    to_r  >r      ( w -- R:w )            core    to_r
 :  :
  (>r) ;   (>r) ;
Line 1053  w = sp[u+1]; Line 1186  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 1174  c_addr2 = c_addr1+1; Line 1314  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  \g compiler
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  
   if ((UCell)F83NAME_COUNT(f83name1)==u &&  (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  longname2=listlfind(c_addr, u, longname1);
     break;  
 f83name2=f83name1;  
 :  :
     BEGIN  dup WHILE  (find-samelen)  dup  WHILE      BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
         >r 2dup r@ cell+ char+ capscomp  0=          >r 2dup r@ cell+ cell+ capscomp  0=
         IF  2drop r>  EXIT  THEN          IF  2drop r>  EXIT  THEN
         r> @          r> @
     REPEAT  THEN  nip nip ;      REPEAT  THEN  nip nip ;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (findl-samelen) ( u longname1 -- u longname2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;      BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
   
 \+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 ;
   
 (hashkey)       ( c_addr u1 -- u2 )             gforth  paren_hashkey  
 u2=0;  
 while(u1--)  
    u2+=(Cell)toupper(*c_addr++);  
 :  
  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.  
 */  
 unsigned rot = ((char []){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})[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 1273  Create rot-values Line 1369  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 1304  f_addr = (Float *)((((Cell)c_addr)+(size Line 1390  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);  
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  
     ! ;  
   
 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);  
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  
     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);  
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  
 :  
     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 1376  n=1; Line 1409  n=1;
   
 \f[THEN]  \f[THEN]
   
   \g hostos
   
 key-file        ( wfileid -- n )                gforth  paren_key_file  key-file        ( wfileid -- n )                gforth  paren_key_file
 #ifdef HAS_FILE  #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
Line 1424  cache."" Line 1459  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  paren_system
 #ifndef MSDOS  #ifndef MSDOS
 int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
 deprep_terminal();  deprep_terminal();
Line 1448  c_addr2 = getenv(cstr(c_addr1,u1,1)); Line 1484  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 wfam -- 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[wfam]); /* ~ 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
Line 1458  wior = IOR(wretval==-1); Line 1494  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 1465  gettimeofday(&time1,&zone1); Line 1507  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 1518  c_addr = strerror(n); Line 1561  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
Line 1562  wior = IOR(unlink(tilde_cstr(c_addr, u, Line 1605  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? */
 ud = LONG2UD(ftell((FILE *)wfileid));  ud = OFF2UD(ftello((FILE *)wfileid));
 wior = IOR(UD2LONG(ud)==-1);  wior = IOR(UD2OFF(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(fseeko((FILE *)wfileid, UD2OFF(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 = OFF2UD(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), UD2OFF(ud))==-1);
   
 read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file  read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
Line 1589  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1631  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 is only for backward compatibility""  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 1640  flush-file ( wfileid -- wior )  file-ext Line 1668  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));
   
 \+  \+
   
   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);
   #ifndef BUGGY_LONG_LONG
   dsystem = (DCell)0;
   #else
   dsystem=(DCell){0,0};
   #endif
   #endif
   
   \+
   
 \+floating  \+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;  if (d.hi<0) {
     DCell d2=dnegate(d);
     r = -(ldexp((Float)d2.hi,CELL_BITS) + (Float)d2.lo);
   } else
     r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
 #else  #else
 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  extern DCell double2ll(Float r);
 d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);  d = double2ll(r);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  
 #else  
 d = r;  
 #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}.""  ""Store @i{r} into the float at address @i{f-addr}.""
Line 1773  floor ( r1 -- r2 ) float Line 1880  floor ( r1 -- r2 ) float
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround  ( r1 -- r2 )    float   f_round  fround  ( r1 -- r2 )    gforth  f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
 /* !! unclear wording */  
 #ifdef HAVE_RINT  
 r2 = rint(r1);  r2 = rint(r1);
 #else  
 r2 = floor(r1+0.5);  
 /* !! This is not quite true to the rounding rules given in the standard */  
 #endif  
   
 fmax    ( r1 r2 -- r3 ) float   f_max  fmax    ( r1 r2 -- r3 ) float   f_max
 if (r1<r2)  if (r1<r2)
Line 1797  else Line 1898  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;
   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 -- 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
Line 1812  representation. If the string represents Line 1918  representation. If the string represents
 @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;    IF_fpTOS(fp[0] = fpTOS);
 if(number[0]=='-') {    fp += -1;
    sign = 1;    fpTOS = r;
    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 1983  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2058  df_addr = (DFloat *)((((Cell)c_addr)+(si
 :  :
  [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
   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.""
   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 ; 
   
   faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
   ""vy=ra*vx+vy""
   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  \ The following words access machine/OS/installation-dependent
 \   Gforth internals  \   Gforth internals
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+  
 \+glocals  \+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 2013  f@local# ( #noffset -- r ) gforth f_fetc Line 2110  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 2063  r = fp[u+1]; /* +1, because update of fp Line 2160  r = fp[u+1]; /* +1, because update of fp
   
 \+OS  \+OS
   
   \g syslib
   
   open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   #ifndef RTLD_GLOBAL
   #define RTLD_GLOBAL 0
   #endif
   u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
   #else
   #  ifdef _WIN32
   u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
   #  else
   #warning Define open-lib!
   u2 = 0;
   #  endif
   #endif
   
   lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
   #else
   #  ifdef _WIN32
   u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
   #  else
   #warning Define lib-sym!
   u3 = 0;
   #  endif
   #endif
   
   \+FFCALL
   
   av-start-void   ( c_addr -- )    gforth  av_start_void
   av_start_void(alist, c_addr);
   
   av-start-int    ( c_addr -- )    gforth  av_start_int
   av_start_int(alist, c_addr, &irv);
   
   av-start-float    ( c_addr -- )    gforth  av_start_float
   av_start_float(alist, c_addr, &frv);
   
   av-start-double    ( c_addr -- )    gforth  av_start_double
   av_start_double(alist, c_addr, &drv);
   
   av-start-longlong    ( c_addr -- )    gforth  av_start_longlong
   av_start_longlong(alist, c_addr, &llrv);
   
   av-start-ptr    ( c_addr -- )    gforth  av_start_ptr
   av_start_ptr(alist, c_addr, void*, &prv);
   
   av-int  ( w -- )  gforth  av_int
   av_int(alist, w);
   
   av-float        ( r -- )        gforth  av_float
   av_float(alist, r);
   
   av-double        ( r -- )        gforth  av_double
   av_double(alist, r);
   
   av-longlong        ( d -- )        gforth  av_longlong
   av_longlong(alist, d);
   
   av-ptr        ( c_addr -- )        gforth  av_ptr
   av_ptr(alist, void*, c_addr);
   
   av-call-void    ( -- )          gforth  av_call_void
   SAVE_REGS
   av_call(alist);
   REST_REGS
   
   av-call-int    ( -- w )        gforth  av_call_int
   SAVE_REGS
   av_call(alist);
   w = irv;
   
   av-call-float   ( -- r )        gforth  av_call_float
   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
   d = llrv;
   
   av-call-ptr   ( -- c_addr )        gforth  av_call_ptr
   SAVE_REGS
   av_call(alist);
   REST_REGS
   c_addr = prv;
   
   alloc-callback  ( xt -- c_addr )        gforth  alloc_callback
   c_addr = (char *)alloc_callback(engine_callback, ((Xt *)xt)+2);
   
   va-start-int    ( -- w )        gforth  va_start_int
   w = va_start_int(clist);
   
   va-start-longlong       ( -- d )        gforth  va_start_longlong
   d = va_start_longlong(clist);
   
   va-start-ptr    ( -- c_addr )   gforth  va_start_ptr
   c_addr = (char *)va_start_ptr(clist, (char *));
   
   va-start-float  ( -- r )        gforth  va_start_float
   r = va_start_float(clist);
   
   va-start-double ( -- r )        gforth  va_start_double
   r = va_start_double(clist);
   
   va-return-void ( -- )   gforth va_return_void
   va_return_void(clist);
   return 0;
   
   va-return-int ( w -- )  gforth va_return_int
   va_return_int(clist, w);
   return 0;
   
   va-return-ptr ( c_addr -- )     gforth va_return_ptr
   va_return_ptr(clist, void *, c_addr);
   return 0;
   
   va-return-longlong ( d -- )     gforth va_return_longlong
   va_return_longlong(clist, d);
   return 0;
   
   va-return-float ( r -- )        gforth va_return_float
   va_return_float(clist, r);
   return 0;
   
   va-return-double ( r -- )       gforth va_return_double
   va_return_double(clist, r);
   return 0;
   
   \-
   
 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')')
 define(`_uploop',  define(`_uploop',
Line 2094  rret = (SYSCALL(Float(*)(argdlist($1)))u Line 2333  rret = (SYSCALL(Float(*)(argdlist($1)))u
   
 \ close ' to keep fontify happy  \ close ' to keep fontify happy
   
 open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib  
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 #ifndef RTLD_GLOBAL  
 #define RTLD_GLOBAL 0  
 #endif  
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  
 #else  
 #  ifdef _WIN32  
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define open-lib!  
 u2 = 0;  
 #  endif  
 #endif  
   
 lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym  
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  
 #else  
 #  ifdef _WIN32  
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define lib-sym!  
 u3 = 0;  
 #  endif  
 #endif  
   
 uploop(i, 0, 7, `icall(i)')  uploop(i, 0, 7, `icall(i)')
 icall(20)  icall(20)
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+  \+
   \+
 up!     ( a_addr -- )   gforth  up_store  
 UP=up=(char *)a_addr;  
 :  
  up ! ;  
 Variable UP  
   
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_fpTOS(fp[0]=fpTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 sp=(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_spTOS(spTOS=sp[0];)
 IF_fpTOS(fpTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+file  \+peephole
   
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  \g peephole
 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  compile-prim1 ( a_prim -- ) gforth compile_prim1
 struct dirent * dent;  ""compile prim (incl. immargs) at @var{a_prim}""
 dent = readdir((DIR *)wdirid);  compile_prim1(a_prim);
 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  finish-code ( -- ) gforth finish_code
 char * string = cstr(c_addr1, u1, 1);  ""Perform delayed steps in code generation (branch resolution, I-cache
 char * pattern = cstr(c_addr2, u2, 0);  flushing).""
 flag = FLAG(!fnmatch(pattern, string, 0));  finish_code();
   
 \+  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
   f = forget_dyncode(c_code);
   
 newline ( -- c_addr u ) gforth  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 ""String containing the newline sequence of the host OS""  ""a_prim is the code address of the primitive that has been
 char newline[] = {  compile_prim1ed to a_code""
 #if defined(unix) || defined(__MACH__)  a_prim = (Cell *)decompile_code((Label)a_code);
 /* 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  \ set-next-code and call2 do not appear in images and can be
   \ renumbered arbitrarily
   
 utime   ( -- dtime )    gforth  set-next-code ( #w -- ) gforth set_next_code
 ""Report the current time in microseconds since some epoch.""  #ifdef NO_IP
 struct timeval time1;  next_code = (Label)w;
 gettimeofday(&time1,NULL);  #endif
 dtime = timeval2us(&time1);  
   
 cputime ( -- duser dsystem ) gforth  call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
 ""duser and dsystem are the respective user- and system-level CPU  /* call with explicit return address */
 times used since the start of the Forth system (excluding child  #ifdef NO_IP
 processes), in microseconds (the granularity may be much larger,  INST_TAIL;
 however).  On platforms without the getrusage call, it reports elapsed  JUMP(a_callee);
 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  #else
 dsystem=(DCell){0,0};  assert(0);
 #endif  
 #endif  #endif
   
 \+  tag-offsets ( -- a_addr ) gforth tag_offsets
   extern Cell groups[32];
 \+floating  a_addr = groups;
   
 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  \g static_super
 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  (find-samelen)  dup  WHILE  
         >r 2dup r@ cell+ char+ capscomp  0=  
         IF  2drop r>  EXIT  THEN  
         r> @  
     REPEAT  THEN  nip nip ;  
 : (find-samelen) ( u longname1 -- u longname2/0 )  
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;  
   
 \+hash  \C #if !defined(GFORTH_DEBUGGING) && !defined(INDIRECT_THREADED) && !defined(DOUBLY_INDIRECT) && !defined(VM_PROFILING)
   
 (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind  include(peeprules.vmg)
 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+ c@ $1F and =  
         IF  2dup r@ cell+ char+ capscomp 0=  
             IF  2drop r> rdrop  EXIT  THEN  THEN  
         rdrop r>  
  REPEAT nip nip ;  
   
 (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind  \C #endif
 ""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+ c@ $1F and =  
         IF  2dup r@ cell+ char+ -text 0=  
             IF  2drop r> rdrop  EXIT  THEN  THEN  
         rdrop r>  
  REPEAT nip nip ;  
   
 \+  \g end

Removed from v.1.71  
changed lines
  Added in v.1.133


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