Diff for /gforth/prim between versions 1.65 and 1.145

version 1.65, 2000/11/12 18:14:09 version 1.145, 2003/10/09 14:15:19
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 
   \E s" Bool"             single data-stack type-prefix f
   \E s" Char"             single data-stack type-prefix c
   \E s" Cell"             single data-stack type-prefix n
   \E s" Cell"             single data-stack type-prefix w
   \E s" UCell"            single data-stack type-prefix u
   \E s" DCell"            double data-stack type-prefix d
   \E s" UDCell"           double data-stack type-prefix ud
   \E s" Float"            single fp-stack   type-prefix r
   \E s" Cell *"           single data-stack type-prefix a_
   \E s" Char *"           single data-stack type-prefix c_
   \E s" Float *"          single data-stack type-prefix f_
   \E s" DFloat *"         single data-stack type-prefix df_
   \E s" SFloat *"         single data-stack type-prefix sf_
   \E s" Xt"               single data-stack type-prefix xt
   \E s" struct F83Name *" single data-stack type-prefix f83name
   \E s" struct Longname *" single data-stack type-prefix longname
   \E 
   \E return-stack stack-prefix R:
   \E inst-stream  stack-prefix #
   \E 
   \E set-current
   \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 99 Line 136
 \ 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
   
   \E register IPTOS Cell
   \E register spTOS Cell
   \E register sp1 Cell
   \E register sp2 Cell
   \E register sp3 Cell
   
   \E create IPregs IPTOS ,
   \E create regs sp2 , sp1 , spTOS ,
   
   \E IPregs 1 0 stack-state IPss1
   \E regs 3 cells + 0 0 stack-state ss0
   \E regs 2 cells + 1  0 stack-state ss1
   \E regs 1 cells + 2  1 stack-state ss2
   \E regs 0 cells + 3  2 stack-state ss3
   
   \ the first of these is the default state
   \E state S0
   \E state S1
   \E state S2
   \E state S3
   
   \E ss0 data-stack S0 set-ss
   \E ss1 data-stack S1 set-ss
   \E ss2 data-stack S2 set-ss
   \E ss3 data-stack S3 set-ss
   
   \E IPss1 inst-stream S0 set-ss
   \E IPss1 inst-stream S1 set-ss
   \E IPss1 inst-stream S2 set-ss
   \E IPss1 inst-stream S3 set-ss
   
   \E data-stack to cache-stack
   \E here 4 cache-states 2! s0 , s1 , s2 , s3 ,
   
   \ !! the following should be automatic
   \E S0 to state-default
   \E state-default to state-in
   \E state-default to state-out
   
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   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""
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)PFA(CFA));
   
   (docon) ( -- w )        gforth-internal paren_docon
   ""run-time routine for constants""
   w = *(Cell *)PFA(CFA);
   
   (dovar) ( -- a_body )   gforth-internal paren_dovar
   ""run-time routine for variables and CREATEd words""
   a_body = PFA(CFA);
   
   (douser) ( -- a_user )  gforth-internal paren_douser
   ""run-time routine for constants""
   a_user = (Cell *)(up+*(Cell *)PFA(CFA));
   
   (dodefer) ( -- )        gforth-internal paren_dodefer
   ""run-time routine for deferred words""
   ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
   SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
   EXEC(*(Xt *)PFA(CFA));
   
   (dofield) ( n1 -- n2 )  gforth-internal paren_field
   ""run-time routine for fields""
   n2 = n1 + *(Cell *)PFA(CFA);
   
   (dodoes) ( -- a_body R:a_retaddr )      gforth-internal paren_dodoes
   ""run-time routine for @code{does>}-defined words""
   a_retaddr = (Cell *)IP;
   a_body = PFA(CFA);
   SET_IP(DOES_CODE1(CFA));
   
   (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
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
 ;  
 :  :
  ;   ;
   
 lit     ( -- w )                gforth  call    ( #a_callee -- R:a_retaddr )    new
 w = (Cell)NEXT_INST;  ""Call callee (a variant of docol with inline argument).""
 INC_IP(1);  #ifdef NO_IP
 :  INST_TAIL;
  r> dup @ swap cell+ >r ;  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+!#    ( -- )  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 += (Cell)(IP[1]);  lp += nlocals;
 goto branch;  #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   
 \+  \+
   
 branch  ( -- )          gforth  branch  ( #a_target -- )        gforth
 branch:  #ifdef NO_IP
 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 :  :
  r> dup @ + >r ;   r> @ >r ;
   
 \ condbranch(forthname,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      $2  $1 ( `#'a_target $2 ) $3
 $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  $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
 }  }
 else  SUPER_CONTINUE;
     INC_IP(1);  $6
 $4  
   
 \+glocals  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
 $3    lp += (Cell)(IP[1]);  $4      #ifdef NO_IP
 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 else  SUPER_CONTINUE;
     INC_IP(2);  
   
 \+  \+
 )  )
   
 condbranch(?branch,( f -- )             f83     question_branch,  condbranch(?branch,f --,f83     question_branch,
 if (f==0) {  ,if (f==0) {
     IF_spTOS(spTOS = sp[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 182  if (f==0) { Line 382  if (f==0) {
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( 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)+(Cell)NEXT_INST));  #ifdef NO_IP
   NEXT;  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 ?dup-0=-?branch ( 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 201  few cycles in that case, but is easy to Line 405  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
   NEXT;    NEXT;
   #endif
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 \+  \+
 \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 */
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = 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
   
 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,
 ""The run-time procedure compiled by S+LOOP. It loops until the index  ""The run-time procedure compiled by S+LOOP. It loops until the index
 crosses the boundary between limit and limit-sign(n). I.e. a symmetric  crosses the boundary between limit and limit-sign(n). I.e. a symmetric
 version of (+LOOP).""  version of (+LOOP).""
Line 262  if (n<0) { Line 468  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)   ( 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) {
     IF_spTOS(spTOS = sp[0]);  #ifdef NO_IP
     goto branch;      JUMP(a_target);
     }  #else
 else {      SET_IP((Xt *)a_target);
     INC_IP(1);      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)   ( 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) {
     IF_spTOS(spTOS = sp[0]);  #ifdef NO_IP
     goto branch;      JUMP(a_target);
     }  #else
 else {      SET_IP((Xt *)a_target);
     INC_IP(1);      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)  ( 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) {
     IF_spTOS(spTOS = sp[0]);  #ifdef NO_IP
     goto branch;  JUMP(a_target);
     }  #else
 else {  SET_IP((Xt *)a_target);
     INC_IP(1);  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)   ( 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) {
     IF_spTOS(spTOS = sp[0]);  #ifdef NO_IP
     goto branch;  JUMP(a_target);
     }  #else
 else {  SET_IP((Xt *)a_target);
     INC_IP(1);  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)  ( 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) {
     IF_spTOS(spTOS = sp[0]);  #ifdef NO_IP
     goto branch;  JUMP(a_target);
     }  #else
 else {  SET_IP((Xt *)a_target);
     INC_IP(1);  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 630  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 646  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 655  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 675  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 482  c2 = toupper(c1); Line 707  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 715  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 669  ud = ummul(u1,u2); Line 882  ud = ummul(u1,u2);
 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> ;
Line 789  lshift ( u1 n -- u2 )  core l_shift Line 1001  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 1124  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 1158  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 951  rdrop ( R:w -- )  gforth Line 1172  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 1053  w = sp[u+1]; Line 1274  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 1402  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 1188  f83name2=f83name1; Line 1420  f83name2=f83name1;
     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.  
 */  
 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 1272  Create rot-values Line 1497  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 1521  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 1540  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 1590  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 1615  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 1625  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 1638  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 1692  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 1736  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 1762  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 1799  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 2011  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 2029  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 2049  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 2189  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
   
 @local# ( -- w )        gforth  fetch_local_number  \g locals
 w = *(Cell *)(lp+(Cell)NEXT_INST);  
 INC_IP(1);  @local# ( #noffset -- w )       gforth  fetch_local_number
   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
   
 f@local#        ( -- r )        gforth  f_fetch_local_number  f@local#        ( #noffset -- r )       gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+noffset);
 INC_IP(1);  
   
 f@local0        ( -- r )        new     f_fetch_local_zero  f@local0        ( -- r )        new     f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));  r = ((Float *)lp)[0];
   
 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];
   
 \+  \+
   
 laddr#  ( -- c_addr )   gforth  laddr_number  laddr#  ( #noffset -- c_addr )  gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(Cell)NEXT_INST);  c_addr = (Char *)(lp+noffset);
 INC_IP(1);  
   
 lp+!#   ( -- )  gforth  lp_plus_store_number  lp+!#   ( #noffset -- ) gforth  lp_plus_store_number
 ""used with negative immediate values it allocates memory on the  ""used with negative immediate values it allocates memory on the
 local stack, a positive immediate argument drops memory from the local  local stack, a positive immediate argument drops memory from the local
 stack""  stack""
 lp += (Cell)NEXT_INST;  lp += noffset;
 INC_IP(1);  
   
 lp-     ( -- )  new     minus_four_lp_plus_store  lp-     ( -- )  new     minus_four_lp_plus_store
 lp += -sizeof(Cell);  lp += -sizeof(Cell);
Line 2067  r = fp[u+1]; /* +1, because update of fp Line 2291  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
   
   wcall   ( u -- )        gforth
   IF_fpTOS(fp[0]=fpTOS);
   FP=fp;
   sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
   fp=FP;
   IF_spTOS(spTOS=sp[0];)
   IF_fpTOS(fpTOS=fp[0]);
   
   \+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-int-r  ( R:w -- )  gforth  av_int_r
   av_int(alist, w);
   
   av-float-r      ( -- )  gforth  av_float_r
   float r = *(Float*)lp;
   lp += sizeof(Float);
   av_float(alist, r);
   
   av-double-r     ( -- )  gforth  av_double_r
   double r = *(Float*)lp;
   lp += sizeof(Float);
   av_double(alist, r);
   
   av-longlong-r   ( R:d -- )      gforth  av_longlong_r
   av_longlong(alist, d);
   
   av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r
   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);
   REST_REGS
   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  ( a_ip -- c_addr )      gforth  alloc_callback
   c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);
   
   va-start-void   ( -- )  gforth  va_start_void
   va_start_void(clist);
   
   va-start-int    ( -- )  gforth  va_start_int
   va_start_int(clist);
   
   va-start-longlong       ( -- )  gforth  va_start_longlong
   va_start_longlong(clist);
   
   va-start-ptr    ( -- )  gforth  va_start_ptr
   va_start_ptr(clist, (char *));
   
   va-start-float  ( -- )  gforth  va_start_float
   va_start_float(clist);
   
   va-start-double ( -- )  gforth  va_start_double
   va_start_double(clist);
   
   va-arg-int      ( -- w )        gforth  va_arg_int
   w = va_arg_int(clist);
   
   va-arg-longlong ( -- d )        gforth  va_arg_longlong
   d = va_arg_longlong(clist);
   
   va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr
   c_addr = (char *)va_arg_ptr(clist,char*);
   
   va-arg-float    ( -- r )        gforth  va_arg_float
   r = va_arg_float(clist);
   
   va-arg-double   ( -- r )        gforth  va_arg_double
   r = va_arg_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;
   
   \+
   
   \+OLDCALL
   
 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 2098  rret = (SYSCALL(Float(*)(argdlist($1)))u Line 2512  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  \g peephole
 UP=up=(char *)a_addr;  
 :  
  up ! ;  
 Variable UP  
   
 wcall   ( u -- )        gforth  \+peephole
 IF_fpTOS(fp[0]=fpTOS);  
 FP=fp;  
 sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);  
 fp=FP;  
 IF_spTOS(spTOS=sp[0];)  
 IF_fpTOS(fpTOS=fp[0]);  
   
 \+file  compile-prim1 ( a_prim -- ) gforth compile_prim1
   ""compile prim (incl. immargs) at @var{a_prim}""
   compile_prim1(a_prim);
   
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  finish-code ( -- ) gforth finish_code
 wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));  ""Perform delayed steps in code generation (branch resolution, I-cache
 wior =  IOR(wdirid == 0);  flushing).""
   finish_code();
   
 read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 struct dirent * dent;  f = forget_dyncode(c_code);
 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;  
   memmove(c_addr, dent->d_name, u2);  
 }  
   
 close-dir       ( wdirid -- wior )      gforth  close_dir  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 wior = IOR(closedir((DIR *)wdirid));  ""a_prim is the code address of the primitive that has been
   compile_prim1ed to a_code""
   a_prim = (Cell *)decompile_code((Label)a_code);
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  \ set-next-code and call2 do not appear in images and can be
 char * string = cstr(c_addr1, u1, 1);  \ renumbered arbitrarily
 char * pattern = cstr(c_addr2, u2, 0);  
 flag = FLAG(!fnmatch(pattern, string, 0));  
   
 \+  set-next-code ( #w -- ) gforth set_next_code
   #ifdef NO_IP
 newline ( -- c_addr u ) gforth  next_code = (Label)w;
 ""String containing the newline sequence of the host OS""  
 char newline[] = {  
 #ifdef unix  
 '\n'  
 #else  
 '\r','\n'  
 #endif  #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  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  #else
 struct timeval time1;  assert(0);
 gettimeofday(&time1,NULL);  
 duser = timeval2us(&time1);  
 #ifndef BUGGY_LONG_LONG  
 dsystem = (DCell)0;  
 #else  
 dsystem=(DCell){0,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  \g static_super
 ""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 ;  
   
 \+  \C #if !defined(GFORTH_DEBUGGING) && !defined(INDIRECT_THREADED) && !defined(DOUBLY_INDIRECT) && !defined(VM_PROFILING)
   
 \+file  include(peeprules.vmg)
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line  \C #endif
 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));  
   
 \+  \g end

Removed from v.1.65  
changed lines
  Added in v.1.145


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