Diff for /gforth/prim between versions 1.108 and 1.121

version 1.108, 2002/12/24 23:40:29 version 1.121, 2003/01/10 21:43:41
Line 105 Line 105
 \E   \E 
 \E set-current  \E set-current
 \E store-optimization on  \E store-optimization on
   \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
   
 \   \ 
 \   \ 
Line 142  noop ( -- )  gforth Line 143  noop ( -- )  gforth
 :  :
  ;   ;
   
 lit     ( #w -- w )             gforth  call    ( #a_callee -- R:a_retaddr )    new
 :  ""Call callee (a variant of docol with inline argument).""
  r> dup @ swap cell+ >r ;  #ifdef NO_IP
   INST_TAIL;
   JUMP(a_callee);
   #else
   #ifdef DEBUG
       {
         CFA_TO_NAME((((Cell *)a_callee)-2));
         fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
                 len,name);
       }
   #endif
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)a_callee);
   #endif
   
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
Line 167  EXEC(*(Xt *)a_addr); Line 181  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
   
 \fhas? skipbranchprims 0= [IF]  ;s      ( R:w -- )              gforth  semis
   ""The primitive compiled by @code{EXIT}.""
   #ifdef NO_IP
   INST_TAIL;
   goto *(void *)w;
   #else
   SET_IP((Xt *)w);
   #endif
   
   unloop  ( R:w1 R:w2 -- )        core
   /* !! alias for 2rdrop */
   :
    r> rdrop rdrop >r ;
   
   lit-perform     ( #a_addr -- )  new     lit_perform
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   EXEC(*(Xt *)a_addr);
   
   does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
   #ifdef NO_IP
   /* compiled to LIT CALL by compile_prim */
   assert(0);
   #else
   a_pfa = PFA(a_cfa);
   nest = (Cell)IP;
   IF_spTOS(spTOS = sp[0]);
   #ifdef DEBUG
       {
         CFA_TO_NAME(a_cfa);
         fprintf(stderr,"%08lx: does %08lx %.*s\n",
                 (Cell)ip,(Cell)a_cfa,len,name);
       }
   #endif
   SET_IP(DOES_CODE1(a_cfa));
   #endif
   
 \+glocals  \+glocals
   
 branch-lp+!#    ( #ndisp #nlocals -- )  gforth  branch_lp_plus_store_number  branch-lp+!# ( #a_target #nlocals -- )  gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 lp += nlocals;  lp += nlocals;
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));  #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   
 \+  \+
   
 branch  ( #ndisp -- )           gforth  branch  ( #a_target -- )        gforth
 SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 :  :
  r> dup @ + >r ;   r> @ >r ;
   
 \ condbranch(forthname,stackeffect,restline,code,forthcode)  \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1 ( `#'ndisp $2 ) $3  $1 ( `#'a_target $2 ) $3
 $4      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  $4      #ifdef NO_IP
 INST_TAIL;  INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 $5  $6
   
 \+glocals  \+glocals
   
 $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number  $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
 $4    lp += nlocals;  $4      #ifdef NO_IP
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));  
 INST_TAIL;  INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
Line 205  SUPER_CONTINUE; Line 281  SUPER_CONTINUE;
 )  )
   
 condbranch(?branch,f --,f83     question_branch,  condbranch(?branch,f --,f83     question_branch,
 if (f==0) {  ,if (f==0) {
 ,:  ,:
  0= dup     \ !f !f   0= dup 0=          \ !f f
  r> dup @   \ !f !f IP branchoffset   r> tuck cell+      \ !f branchoffset f IP+
  rot and +  \ !f IP|IP+branchoffset   and -rot @ and or  \ f&IP+|!f&branch
  swap 0= cell and + \ IP''  
  >r ;)   >r ;)
   
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  \ we don't need an lp_plus_store version of the ?dup-stuff, because it
Line 218  if (f==0) { Line 293  if (f==0) {
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( #ndisp f -- f )       new     question_dupe_question_branch  ?dup-?branch    ( #a_target f -- f )    new     question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""  ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {  if (f==0) {
   sp++;    sp++;
   IF_spTOS(spTOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
   INST_TAIL;  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
 ?dup-0=-?branch ( #ndisp f -- ) new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #a_target f -- ) new  question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
 /* the approach taken here of declaring the word as having the stack  /* the approach taken here of declaring the word as having the stack
 effect ( f -- ) and correcting for it in the branch-taken case costs a  effect ( f -- ) and correcting for it in the branch-taken case costs a
Line 236  few cycles in that case, but is easy to Line 316  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
   NEXT;    NEXT;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
 \+  \+
 \f[THEN]  
 \fhas? skiploopprims 0= [IF]  \fhas? skiploopprims 0= [IF]
   
 condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,  condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,
 n2=n1-1;  n2=n1-1;
 if (n1) {  ,if (n1) {
 ,:  ,:
  r> r> dup 1- >r   r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)   IF @ >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,  condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
 n2=n1+1;  n2=n1+1;
 if (n2 != nlimit) {  ,if (n2 != nlimit) {
 ,:  ,:
  r> r> 1+ r> 2dup =   r> r> 1+ r> 2dup =
  IF >r 1- >r cell+ >r   IF >r 1- >r cell+ >r
  ELSE >r >r dup @ + >r THEN ;)   ELSE >r >r @ >r THEN ;)
   
 condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,  condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 266  condbranch((+loop),n R:nlimit R:n1 -- R: Line 349  condbranch((+loop),n R:nlimit R:n1 -- R:
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = n1-nlimit;  Cell olddiff = n1-nlimit;
 n2=n1+n;          n2=n1+n;        
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
  2 pick r@ + r@ xor 0< 0=   2 pick r@ + r@ xor 0< 0=
  3 pick r> xor 0< 0= or   3 pick r> xor 0< 0= or
  IF    >r + >r dup @ + >r   IF    >r + >r @ >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+xconds  \+xconds
Line 281  if ((olddiff^(olddiff+n))>=0   /* the li Line 364  if ((olddiff^(olddiff+n))>=0   /* the li
 condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,  condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
 UCell olddiff = n1-nlimit;  UCell olddiff = n1-nlimit;
 n2=n1-u;  n2=n1-u;
 if (olddiff>u) {  ,if (olddiff>u) {
 ,)  ,)
   
 condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,  condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,
Line 296  if (n<0) { Line 379  if (n<0) {
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 n2=n1+n;  n2=n1+n;
 if (diff>=0 || newdiff<0) {  ,if (diff>=0 || newdiff<0) {
 ,)  ,)
   
 \+  \+
   
 unloop  ( R:w1 R:w2 -- )        core  (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for
 /* !! alias for 2rdrop */  
 :  
  r> rdrop rdrop >r ;  
   
 (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for  
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 nlimit=0;  nlimit=0;
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do  (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do
 :  :
  r> swap rot >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do  (?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth   paren_question_do
 if (nstart == nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart == nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
       INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
        dup @ + >r         @ >r
   ELSE r> swap rot >r >r    ELSE r> swap rot >r >r
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+xconds  \+xconds
   
 (+do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_plus_do  (+do)   ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do
 if (nstart >= nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart >= nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
       INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 343  SUPER_CONTINUE; Line 435  SUPER_CONTINUE;
  r> swap >r swap >r   r> swap >r swap >r
  >=   >=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u+do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_plus_do  (u+do)  ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do
 if (ustart >= ulimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (ustart >= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 359  SUPER_CONTINUE; Line 458  SUPER_CONTINUE;
  r> swap >r swap >r   r> swap >r swap >r
  u>=   u>=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (-do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_minus_do  (-do)   ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do
 if (nstart <= nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart <= nlimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 375  SUPER_CONTINUE; Line 481  SUPER_CONTINUE;
  r> swap >r swap >r   r> swap >r swap >r
  <=   <=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u-do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_minus_do  (u-do)  ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do
 if (ustart <= ulimit) {  #ifdef NO_IP
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  
     INST_TAIL;      INST_TAIL;
   #endif
   if (ustart <= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 391  SUPER_CONTINUE; Line 504  SUPER_CONTINUE;
  r> swap >r swap >r   r> swap >r swap >r
  u<=   u<=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
Line 541  u2 = u1-n; Line 654  u2 = u1-n;
   
 \g arith  \g arith
   
   lit     ( #w -- w )             gforth
   :
    r> dup @ swap cell+ >r ;
   
 +       ( n1 n2 -- n )          core    plus  +       ( n1 n2 -- n )          core    plus
 n = n1+n2;  n = n1+n2;
   
   \ lit+ / lit_plus = lit +
   
   lit+    ( n1 #n2 -- n )         new     lit_plus
   n=n1+n2;
   
 \ PFE-0.9.14 has it differently, but the next release will have it as follows  \ PFE-0.9.14 has it differently, but the next release will have it as follows
 under+  ( n1 n2 n3 -- n n2 )    gforth  under_plus  under+  ( n1 n2 n3 -- n n2 )    gforth  under_plus
 ""add @i{n3} to @i{n1} (giving @i{n})""  ""add @i{n3} to @i{n1} (giving @i{n})""
Line 817  lshift ( u1 n -- u2 )  core l_shift Line 939  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 938  f = FLAG(u1-u2 < u3-u2); Line 1062  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
 \g internal  \g stack
   
   useraddr        ( #u -- a_addr )        new
   a_addr = (Cell *)(up+u);
   
   up!     ( a_addr -- )   gforth  up_store
   UP=up=(char *)a_addr;
   :
    up ! ;
   Variable UP
   
 sp@     ( -- a_addr )           gforth          sp_fetch  sp@     ( -- a_addr )           gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp+1;
Line 963  fp = f_addr; Line 1096  fp = f_addr;
   
 \+  \+
   
 ;s      ( R:w -- )              gforth  semis  
 ""The primitive compiled by @code{EXIT}.""  
 #ifdef NO_IP  
 INST_TAIL;  
 goto *(void *)w;  
 #else  
 SET_IP((Xt *)w);  
 #endif  
   
 \g stack  
   
 >r      ( w -- R:w )            core    to_r  >r      ( w -- R:w )            core    to_r
 :  :
  (>r) ;   (>r) ;
Line 1090  w = sp[u+1]; Line 1212  w = sp[u+1];
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
   \g memory
   
 @       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
 ""@i{w} is the cell stored at @i{a_addr}.""  ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
   
   \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
 !       ( w a_addr -- )         core    store  !       ( w a_addr -- )         core    store
 ""Store @i{w} into the cell at @i{a-addr}.""  ""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;  *a_addr = w;
Line 1211  c_addr2 = c_addr1+1; Line 1340  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  \g compiler
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  
   if ((UCell)F83NAME_COUNT(f83name1)==u &&  (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  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 ;
   
 (hashkey)       ( c_addr u1 -- u2 )             gforth  paren_hashkey  
 u2=0;  
 while(u1--)  
    u2+=(Cell)toupper(*c_addr++);  
 :  
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;  
   
 (hashkey1)      ( c_addr u ubits -- ukey )              gforth  paren_hashkey1  (hashkey1)      ( c_addr u ubits -- ukey )              gforth  paren_hashkey1
 ""ukey is the hash key for the string c_addr u fitting in ubits bits""  ""ukey is the hash key for the string c_addr u fitting in ubits bits""
 /* this hash function rotates the key at every step by rot bits within  /* this hash function rotates the key at every step by rot bits within
Line 1342  f_addr = (Float *)((((Cell)c_addr)+(size Line 1466  f_addr = (Float *)((((Cell)c_addr)+(size
 :  :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 >body   ( xt -- a_addr )        core    to_body  
 "" Get the address of the body of the word represented by @i{xt} (the address  
 of the word's data field).""  
 a_addr = PFA(xt);  
 :  
     2 cells + ;  
   
 \ threading stuff is currently only interesting if we have a compiler  \ threading stuff is currently only interesting if we have a compiler
 \fhas? standardthreading has? compiler and [IF]  \fhas? standardthreading has? compiler and [IF]
   
 >code-address   ( xt -- c_addr )                gforth  to_code_address  
 ""@i{c-addr} is the code address of the word @i{xt}.""  
 /* !! This behaves installation-dependently for DOES-words */  
 c_addr = (Address)CODE_ADDRESS(xt);  
 :  
     @ ;  
   
 >does-code      ( xt -- a_addr )                gforth  to_does_code  
 ""If @i{xt} is the execution token of a child of a @code{DOES>} word,  
 @i{a-addr} is the start of the Forth code after the @code{DOES>};  
 Otherwise @i{a-addr} is 0.""  
 a_addr = (Cell *)DOES_CODE(xt);  
 :  
     cell+ @ ;  
   
 code-address!   ( c_addr xt -- )                gforth  code_address_store  
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  
 MAKE_CF(xt, c_addr);  
 :  
     ! ;  
   
 does-code!      ( a_addr xt -- )                gforth  does_code_store  
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;  
 @i{a-addr} is the start of the Forth code after @code{DOES>}.""  
 MAKE_DOES_CF(xt, a_addr);  
 :  
     dodoes: over ! cell+ ! ;  
   
 does-handler!   ( a_addr -- )   gforth  does_handler_store  
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  
 @i{a-addr} points just behind a @code{DOES>}.""  
 MAKE_DOES_HANDLER(a_addr);  
 :  
     drop ;  
   
 /does-handler   ( -- n )        gforth  slash_does_handler  
 ""The size of a @code{DOES>}-handler (includes possible padding).""  
 /* !! a constant or environmental query might be better */  
 n = DOES_HANDLER_SIZE;  
 :  
     2 cells ;  
   
 threading-method        ( -- n )        gforth  threading_method  threading-method        ( -- n )        gforth  threading_method
 ""0 if the engine is direct threaded. Note that this may change during  ""0 if the engine is direct threaded. Note that this may change during
 the lifetime of an image.""  the lifetime of an image.""
Line 1627  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1701  wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 read-line       ( c_addr u1 wfileid -- u2 flag wior )   file    read_line  (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line
 /* this may one day be replaced with : read-line (read-line) nip ; */  
 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 1701  else { Line 1778  else {
   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  \g floating
Line 1712  comparisons(f0, r, f_zero_, r, 0., float Line 1885  comparisons(f0, r, f_zero_, r, 0., float
 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
Line 2013  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2190  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.""
   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
   
   \g locals
   
 @local# ( #noffset -- w )       gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
 w = *(Cell *)(lp+noffset);  w = *(Cell *)(lp+noffset);
   
 @local0 ( -- w )        new     fetch_local_zero  @local0 ( -- w )        new     fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));  w = ((Cell *)lp)[0];
   
 @local1 ( -- w )        new     fetch_local_four  @local1 ( -- w )        new     fetch_local_four
 w = *(Cell *)(lp+1*sizeof(Cell));  w = ((Cell *)lp)[1];
   
 @local2 ( -- w )        new     fetch_local_eight  @local2 ( -- w )        new     fetch_local_eight
 w = *(Cell *)(lp+2*sizeof(Cell));  w = ((Cell *)lp)[2];
   
 @local3 ( -- w )        new     fetch_local_twelve  @local3 ( -- w )        new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = ((Cell *)lp)[3];
   
 \+floating  \+floating
   
Line 2043  f@local# ( #noffset -- r ) gforth f_fetc Line 2250  f@local# ( #noffset -- r ) gforth f_fetc
 r = *(Float *)(lp+noffset);  r = *(Float *)(lp+noffset);
   
 f@local0        ( -- r )        new     f_fetch_local_zero  f@local0        ( -- r )        new     f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));  r = ((Float *)lp)[0];
   
 f@local1        ( -- r )        new     f_fetch_local_eight  f@local1        ( -- r )        new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  r = ((Float *)lp)[1];
   
 \+  \+
   
Line 2093  r = fp[u+1]; /* +1, because update of fp Line 2300  r = fp[u+1]; /* +1, because update of fp
   
 \+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  fcall(20) Line 2367  fcall(20)
   
 \+  \+
   
 up!     ( a_addr -- )   gforth  up_store  
 UP=up=(char *)a_addr;  
 :  
  up ! ;  
 Variable UP  
   
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_fpTOS(fp[0]=fpTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
Line 2172  fp=FP; Line 2375  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  
 ""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  \g peephole
 ""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  compile-prim1 ( a_prim -- ) gforth compile_prim1
 ""Close the directory specified by @i{dir-id}.""  ""compile prim (incl. immargs) at @var{a_prim}""
 wior = IOR(closedir((DIR *)wdirid));  compile_prim1(a_prim);
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  finish-code ( -- ) gforth finish_code
 char * string = cstr(c_addr1, u1, 1);  ""Perform delayed steps in code generation (branch resolution, I-cache
 char * pattern = cstr(c_addr2, u2, 0);  flushing).""
 flag = FLAG(!fnmatch(pattern, string, 0));  finish_code();
   
 \+  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
   f = forget_dyncode(c_code);
   
 newline ( -- c_addr u ) gforth  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 ""String containing the newline sequence of the host OS""  ""a_prim is the code address of the primitive that has been
 char newline[] = {  compile_prim1ed to a_code""
 #if defined(unix) || defined(__MACH__)  a_prim = (Cell *)decompile_code((Label)a_code);
 /* Darwin/MacOS X sets __MACH__, but not unix. */  
 '\n'  
 #else  
 '\r','\n'  
 #endif  
 };  
 c_addr=newline;  
 u=sizeof(newline);  
 :  
  "newline count ;  
 Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,  
   
 \+os  \ set-next-code and call2 do not appear in images and can be
   \ renumbered arbitrarily
   
 utime   ( -- dtime )    gforth  set-next-code ( #w -- ) gforth set_next_code
 ""Report the current time in microseconds since some epoch.""  #ifdef NO_IP
 struct timeval time1;  next_code = (Label)w;
 gettimeofday(&time1,NULL);  #endif
 dtime = timeval2us(&time1);  
   
 cputime ( -- duser dsystem ) gforth  call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
 ""duser and dsystem are the respective user- and system-level CPU  /* call with explicit return address */
 times used since the start of the Forth system (excluding child  #ifdef NO_IP
 processes), in microseconds (the granularity may be much larger,  INST_TAIL;
 however).  On platforms without the getrusage call, it reports elapsed  JUMP(a_callee);
 time (since some epoch) for duser and 0 for dsystem.""  
 #ifdef HAVE_GETRUSAGE  
 struct rusage usage;  
 getrusage(RUSAGE_SELF, &usage);  
 duser = timeval2us(&usage.ru_utime);  
 dsystem = timeval2us(&usage.ru_stime);  
 #else  
 struct timeval time1;  
 gettimeofday(&time1,NULL);  
 duser = timeval2us(&time1);  
 #ifndef BUGGY_LONG_LONG  
 dsystem = (DCell)0;  
 #else  #else
 dsystem=(DCell){0,0};  assert(0);
 #endif  
 #endif  #endif
   
 \+  \+
   
 \+floating  include(peeprules.vmg)
   
 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 end
 ""vy=ra*vx+vy""  
 for (; ucount>0; ucount--) {  
   *f_y += ra * *f_x;  
   f_x = (Float *)(((Address)f_x)+nstridex);  
   f_y = (Float *)(((Address)f_y)+nstridey);  
 }  
 :  
  >r swap 2swap swap r> 0 ?DO  
      fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap  
  LOOP 2drop 2drop fdrop ;  
   
 \+  
   
 \+file  
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line  
 Cell c;  
 flag=-1;  
 u3=0;  
 for(u2=0; u2<u1; u2++)  
 {  
    c = getc((FILE *)wfileid);  
    u3++;  
    if (c=='\n') break;  
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  
        ungetc(c,(FILE *)wfileid);  
      else  
        u3++;  
      break;  
    }  
    if (c==EOF) {  
         flag=FLAG(u2!=0);  
         break;  
      }  
    c_addr[u2] = (Char)c;  
 }  
 wior=FILEIO(ferror((FILE *)wfileid));  
   
 \+  
   
 (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind  
 for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))  
   if ((UCell)LONGNAME_COUNT(longname1)==u &&  
       memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)  
     break;  
 longname2=longname1;  
 :  
     BEGIN  dup WHILE  (findl-samelen)  dup  WHILE  
         >r 2dup r@ cell+ cell+ capscomp  0=  
         IF  2drop r>  EXIT  THEN  
         r> @  
     REPEAT  THEN  nip nip ;  
 : (findl-samelen) ( u longname1 -- u longname2/0 )  
     BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;  
   
 \+hash  
   
 (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind  
 struct Longname *longname1;  
 longname2=NULL;  
 while(a_addr != NULL)  
 {  
    longname1=(struct Longname *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)LONGNAME_COUNT(longname1)==u &&  
        memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)  
      {  
         longname2=longname1;  
         break;  
      }  
 }  
 :  
  BEGIN  dup  WHILE  
         2@ >r >r dup r@ cell+ @ lcount-mask and =  
         IF  2dup r@ cell+ cell+ capscomp 0=  
             IF  2drop r> rdrop  EXIT  THEN  THEN  
         rdrop r>  
  REPEAT nip nip ;  
   
 (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind  
 ""A case-sensitive variant of @code{(hashfind)}""  
 struct Longname *longname1;  
 longname2=NULL;  
 while(a_addr != NULL)  
 {  
    longname1=(struct Longname *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)LONGNAME_COUNT(longname1)==u &&  
        memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)  
      {  
         longname2=longname1;  
         break;  
      }  
 }  
 :  
  BEGIN  dup  WHILE  
         2@ >r >r dup r@ cell+ @ lcount-mask and =  
         IF  2dup r@ cell+ cell+ -text 0=  
             IF  2drop r> rdrop  EXIT  THEN  THEN  
         rdrop r>  
  REPEAT nip nip ;  
   
 \+  
   
 \+peephole  
   
 \g peephole  
   
 primtable       ( -- wprimtable )       new  
 ""wprimtable is a table containing the xts of the primitives indexed  
 by sequence-number in prim (for use in prepare-peephole-table).""  
 wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);  
   
 prepare-peephole-table  ( wprimtable -- wpeeptable ) new prepare_peephole_opt  
 ""wpeeptable is a data structure used by @code{peephole-opt}; it is  
 constructed by combining a primitives table with a simple peephole  
 optimization table.""  
 wpeeptable = prepare_peephole_table((Xt *)wprimtable);  
   
 peephole-opt    ( xt1 xt2 wpeeptable -- xt )    new     peephole_opt  
 ""xt is the combination of xt1 and xt2 (according to wpeeptable); if  
 they cannot be combined, xt is 0.""  
 xt = peephole_opt(xt1, xt2, wpeeptable);  
   
 call    ( #a_callee -- R:a_retaddr )    new  
 ""Call callee (a variant of docol with inline argument).""  
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_callee);  
 #else  
 #ifdef DEBUG  
     {  
       CFA_TO_NAME((((Cell *)a_callee)-2));  
       fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,  
               len,name);  
     }  
 #endif  
 a_retaddr = (Cell *)IP;  
 SET_IP((Xt *)a_callee);  
 #endif  
   
 useraddr        ( #u -- a_addr )        new  
 a_addr = (Cell *)(up+u);  
   
 compile-prim ( xt1 -- xt2 )     obsolete        compile_prim  
 xt2 = (Xt)compile_prim((Label)xt1);  
   
 \ lit@ / lit_fetch = lit @  
   
 lit@            ( #a_addr -- w ) new    lit_fetch  
 w = *a_addr;  
   
 lit-perform     ( #a_addr -- )  new     lit_perform  
 #ifndef NO_IP  
 ip=IP;  
 #endif  
 SUPER_END;  
 EXEC(*(Xt *)a_addr);  
   
 \ lit+ / lit_plus = lit +  
   
 lit+    ( n1 #n2 -- n )         new     lit_plus  
 n=n1+n2;  
   
 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  
   
 abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number  
 /* this will probably not be used */  
 lp += nlocals;  
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 #endif  
   
 \+  
   
 abranch ( #a_target -- )        gforth  
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 #endif  
 :  
  r> @ >r ;  
   
 \ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)  
 \ this is non-syntactical: code must open a brace that is closed by the macro  
 define(acondbranch,  
 $1 ( `#'a_target $2 ) $3  
 $4      #ifdef NO_IP  
 INST_TAIL;  
 #endif  
 $5      #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 $6  
   
 \+glocals  
   
 $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number  
 $4      #ifdef NO_IP  
 INST_TAIL;  
 #endif  
 $5      lp += nlocals;  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 \+  
 )  
   
 acondbranch(a?branch,f --,f83   aquestion_branch,  
 ,if (f==0) {  
 ,:  
  0= dup     \ !f !f \ !! still uses relative addresses  
  r> dup @   \ !f !f IP branchoffset  
  rot and +  \ !f IP|IP+branchoffset  
  swap 0= cell and + \ IP''  
  >r ;)  
   
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  
 \ is only used in if's (yet)  
   
 \+xconds  
   
 a?dup-?branch   ( #a_target f -- f )    new     aquestion_dupe_question_branch  
 ""The run-time procedure compiled by @code{?DUP-IF}.""  
 if (f==0) {  
   sp++;  
   IF_spTOS(spTOS = sp[0]);  
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
   INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 a?dup-0=-?branch ( #a_target f -- ) new aquestion_dupe_zero_equals_question_branch  
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  
 /* the approach taken here of declaring the word as having the stack  
 effect ( f -- ) and correcting for it in the branch-taken case costs a  
 few cycles in that case, but is easy to convert to a CONDBRANCH  
 invocation */  
 if (f!=0) {  
   sp--;  
 #ifdef NO_IP  
   JUMP(a_target);  
 #else  
   SET_IP((Xt *)a_target);  
   NEXT;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 \+  
 \f[THEN]  
 \fhas? skiploopprims 0= [IF]  
   
 acondbranch(a(next),R:n1 -- R:n2,cmFORTH        aparen_next,  
 n2=n1-1;  
 ,if (n1) {  
 ,:  
  r> r> dup 1- >r  
  IF @ >r ELSE cell+ >r THEN ;)  
   
 acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth       aparen_loop,  
 n2=n1+1;  
 ,if (n2 != nlimit) {  
 ,:  
  r> r> 1+ r> 2dup =  
  IF >r 1- >r cell+ >r  
  ELSE >r >r @ >r THEN ;)  
   
 acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,  
 /* !! check this thoroughly */  
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  
 /* dependent upon two's complement arithmetic */  
 Cell olddiff = n1-nlimit;  
 n2=n1+n;          
 ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {  
 ,:  
  r> swap  
  r> r> 2dup - >r  
  2 pick r@ + r@ xor 0< 0=  
  3 pick r> xor 0< 0= or  
  IF    >r + >r @ >r  
  ELSE  >r >r drop cell+ >r THEN ;)  
   
 \+xconds  
   
 acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,  
 UCell olddiff = n1-nlimit;  
 n2=n1-u;  
 ,if (olddiff>u) {  
 ,)  
   
 acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth   aparen_symmetric_plus_loop,  
 ""The run-time procedure compiled by S+LOOP. It loops until the index  
 crosses the boundary between limit and limit-sign(n). I.e. a symmetric  
 version of (+LOOP).""  
 /* !! check this thoroughly */  
 Cell diff = n1-nlimit;  
 Cell newdiff = diff+n;  
 if (n<0) {  
     diff = -diff;  
     newdiff = -newdiff;  
 }  
 n2=n1+n;  
 ,if (diff>=0 || newdiff<0) {  
 ,)  
   
 a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth  aparen_question_do  
 #ifdef NO_IP  
     INST_TAIL;  
 #endif  
 if (nstart == nlimit) {  
 #ifdef NO_IP  
     JUMP(a_target);  
 #else  
     SET_IP((Xt *)a_target);  
     INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
   2dup =  
   IF   r> swap rot >r >r  
        @ >r  
   ELSE r> swap rot >r >r  
        cell+ >r  
   THEN ;                                \ --> CORE-EXT  
   
 \+xconds  
   
 a(+do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do  
 #ifdef NO_IP  
     INST_TAIL;  
 #endif  
 if (nstart >= nlimit) {  
 #ifdef NO_IP  
     JUMP(a_target);  
 #else  
     SET_IP((Xt *)a_target);  
     INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  >=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do  
 #ifdef NO_IP  
     INST_TAIL;  
 #endif  
 if (ustart >= ulimit) {  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  u>=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 a(-do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do  
 #ifdef NO_IP  
     INST_TAIL;  
 #endif  
 if (nstart <= nlimit) {  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  <=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do  
 #ifdef NO_IP  
     INST_TAIL;  
 #endif  
 if (ustart <= ulimit) {  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 :  
  swap 2dup  
  r> swap >r swap >r  
  u<=  
  IF  
      @  
  ELSE  
      cell+  
  THEN  >r ;  
   
 \ set-next-code and call2 do not appear in images and can be  
 \ renumbered arbitrarily  
   
 set-next-code ( #w -- ) gforth set_next_code  
 #ifdef NO_IP  
 next_code = (Label)w;  
 #endif  
   
 call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth  
 /* call with explicit return address */  
 #ifdef NO_IP  
 INST_TAIL;  
 JUMP(a_callee);  
 #else  
 assert(0);  
 #endif  
   
 compile-prim1 ( a_prim -- ) gforth compile_prim1  
 ""compile prim (incl. immargs) at @var{a_prim}""  
 compile_prim1(a_prim);  
   
 finish-code ( -- ) gforth finish_code  
 ""Perform delayed steps in code generation (branch resolution, I-cache  
 flushing).""  
 finish_code();  
   
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode  
 f = forget_dyncode(c_code);  
   
 decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim  
 ""a_prim is the code address of the primitive that has been  
 compile_prim1ed to a_code""  
 a_prim = decompile_code(a_code);  
   
 \+  
   
 include(peeprules.vmg)  
   
 \+  

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


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