[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.67 and 1.117

version 1.67, Wed Dec 13 10:15:26 2000 UTC version 1.117, Wed Jan 8 10:25:34 2003 UTC
Line 54 
Line 54 
 \ stack. Use different names on both sides of the '--', if you change a  \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).  \ value (some stores to the stack are optimized away).
 \  \
   \ 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:
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  \E
 \E return-stack stack-prefix R:  \E return-stack stack-prefix R:
 \E inst-stream  stack-prefix #  \E inst-stream  stack-prefix #
 \E  \E
 \E set-current  \E set-current
   \E store-optimization on
   \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
   
 \  \
 \  \
Line 127 
Line 135 
 \ 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 )                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
 TAIL;  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;
 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) {
 ,:  ,:
  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 208 
Line 293 
   
 \+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 227 
Line 316 
 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 288 
Line 379 
     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  
 /* !! alias for 2rdrop */  
 :  
  r> rdrop rdrop >r ;  
   
 (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for  (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 nlimit=0;  nlimit=0;
Line 308 
Line 394 
 :  :
  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 430 
Line 541 
   
 \ 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 539 
Line 652 
 :  :
  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 815 
Line 939 
 :  :
     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 936 
Line 1062 
 :  :
  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 959 
Line 1096 
   
 \+  \+
   
 ;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 1079 
Line 1212 
   
 \ 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 1200 
Line 1340 
 :  :
  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? */)  for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
     if ((UCell)LONGNAME_COUNT(longname1)==u &&
         memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
     break;      break;
 f83name2=f83name1;  longname2=longname1;
 :  :
     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;  struct Longname *longname1;
 f83name2=NULL;  longname2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
 {  {
    f83name1=(struct F83Name *)(a_addr[1]);     longname1=(struct Longname *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&     if ((UCell)LONGNAME_COUNT(longname1)==u &&
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
      {       {
         f83name2=f83name1;          longname2=longname1;
         break;          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;  struct Longname *longname1;
 f83name2=NULL;  longname2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
 {  {
    f83name1=(struct F83Name *)(a_addr[1]);     longname1=(struct Longname *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&     if ((UCell)LONGNAME_COUNT(longname1)==u &&
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)
      {       {
         f83name2=f83name1;          longname2=longname1;
         break;          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 ;
Line 1277 
Line 1419 
    ASCII strings (larger if ubits is large), and should share no     ASCII strings (larger if ubits is large), and should share no
    divisors with ubits.     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];  static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5};
   unsigned rot = rot_values[ubits];
 Char *cp = c_addr;  Char *cp = c_addr;
 for (ukey=0; cp<c_addr+u; cp++)  for (ukey=0; cp<c_addr+u; cp++)
     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))      ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
Line 1330 
Line 1473 
 :  :
  [ 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  code-address!   ( c_addr xt -- )                gforth  code_address_store
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  :
     ! ;      ! ;
   
Line 1366 
Line 1485 
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;  ""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>}.""  @i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
Line 1374 
Line 1492 
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 @i{a-addr} points just behind a @code{DOES>}.""  @i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  
 :  :
     drop ;      drop ;
   
Line 1402 
Line 1519 
   
 \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 1450 
Line 1569 
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE(c_addr,u);
   
 (bye)   ( n -- )        gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
   SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  peren_system
Line 1474 
Line 1594 
 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 1593 
Line 1713 
   
 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 1615 
Line 1735 
 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""  
 Cell c;  Cell c;
 flag=-1;  flag=-1;
   u3=0;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
 {  {
    c = getc((FILE *)wfileid);     c = getc((FILE *)wfileid);
      u3++;
    if (c=='\n') break;     if (c=='\n') break;
    if (c=='\r') {     if (c=='\r') {
      if ((c = getc((FILE *)wfileid))!='\n')       if ((c = getc((FILE *)wfileid))!='\n')
        ungetc(c,(FILE *)wfileid);         ungetc(c,(FILE *)wfileid);
        else
          u3++;
      break;       break;
    }     }
    if (c==EOF) {     if (c==EOF) {
Line 1689 
Line 1812 
   wior=0;    wior=0;
 }  }
   
   file-eof?       ( wfileid -- flag )     gforth  file_eof_query
   flag = FLAG(feof((FILE *) wfileid));
   
   open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
   ""Open the directory specified by @i{c-addr, u}
   and return @i{dir-id} for futher access to it.""
   wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
   wior =  IOR(wdirid == 0);
   
   read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
   ""Attempt to read the next entry from the directory specified
   by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}.
   If the attempt fails because there is no more entries,
   @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
   If the attempt to read the next entry fails because of any other reason,
   return @i{ior}<>0.
   If the attempt succeeds, store file name to the buffer at @i{c-addr}
   and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
   If the length of the file name is greater than @i{u1},
   store first @i{u1} characters from file name into the buffer and
   indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
   struct dirent * dent;
   dent = readdir((DIR *)wdirid);
   wior = 0;
   flag = -1;
   if(dent == NULL) {
     u2 = 0;
     flag = 0;
   } else {
     u2 = strlen(dent->d_name);
     if(u2 > u1) {
       u2 = u1;
       wior = -512-ENAMETOOLONG;
     }
     memmove(c_addr, dent->d_name, u2);
   }
   
   close-dir       ( wdirid -- wior )      gforth  close_dir
   ""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);
   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;  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 1799 
Line 2020 
 /* !! 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 2009 
Line 2224 
 :  :
  [ 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.""
   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 ;
   
   \+
   
 \ 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 2093 
Line 2334 
   
 \+OS  \+OS
   
   \g syslib
   
 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 2158 
Line 2401 
   
 \+  \+
   
 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  
 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;  
   memmove(c_addr, dent->d_name, u2);  
 }  
   
 close-dir       ( wdirid -- wior )      gforth  close_dir  primtable       ( -- wprimtable )       new
 wior = IOR(closedir((DIR *)wdirid));  ""wprimtable is a table containing the xts of the primitives indexed
   by sequence-number in prim (for use in prepare-peephole-table).""
   wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  prepare-peephole-table  ( wprimtable -- wpeeptable ) new prepare_peephole_opt
 char * string = cstr(c_addr1, u1, 1);  ""wpeeptable is a data structure used by @code{peephole-opt}; it is
 char * pattern = cstr(c_addr2, u2, 0);  constructed by combining a primitives table with a simple peephole
 flag = FLAG(!fnmatch(pattern, string, 0));  optimization table.""
   wpeeptable = prepare_peephole_table((Xt *)wprimtable);
   
 \+  peephole-opt    ( xt1 xt2 wpeeptable -- xt )    new     peephole_opt
   ""xt is the combination of xt1 and xt2 (according to wpeeptable); if
   they cannot be combined, xt is 0.""
   xt = peephole_opt(xt1, xt2, wpeeptable);
   
 newline ( -- c_addr u ) gforth  compile-prim ( xt1 -- xt2 )     obsolete        compile_prim
 ""String containing the newline sequence of the host OS""  xt2 = (Xt)compile_prim((Label)xt1);
 char newline[] = {  
 #ifdef 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  #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
   
 \+  compile-prim1 ( a_prim -- ) gforth compile_prim1
   ""compile prim (incl. immargs) at @var{a_prim}""
   compile_prim1(a_prim);
   
 \+floating  finish-code ( -- ) gforth finish_code
   ""Perform delayed steps in code generation (branch resolution, I-cache
   flushing).""
   finish_code();
   
 v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the  f = forget_dyncode(c_code);
 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  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 ""vy=ra*vx+vy""  ""a_prim is the code address of the primitive that has been
 for (; ucount>0; ucount--) {  compile_prim1ed to a_code""
   *f_y += ra * *f_x;  a_prim = (Label)decompile_code((Label)a_code);
   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  include(peeprules.vmg)
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line  \g end
 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));  
   
 \+  

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help