[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.111 and 1.112

version 1.111, Mon Dec 30 22:41:07 2002 UTC version 1.112, Wed Jan 1 17:28:29 2003 UTC
Line 143 
Line 143 
 :  :
  ;   ;
   
 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 168 
Line 181 
 :  :
  @ 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 206 
Line 281 
 )  )
   
 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 219 
Line 293 
   
 \+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 237 
Line 316 
 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 267 
Line 349 
 /* 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 282 
Line 364 
 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 297 
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 317 
Line 394 
 :  :
  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 344 
Line 435 
  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 360 
Line 458 
  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 376 
Line 481 
  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 392 
Line 504 
  r> swap >r swap >r   r> swap >r swap >r
  u<=   u<=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
Line 542 
Line 654 
   
 \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 941 
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 964 
Line 1096 
   
 \+  \+
   
 ;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 1097 
Line 1218 
 ""@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 1216 
Line 1342 
   
 \g compiler  \g compiler
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
   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? */)
     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 1632 
Line 1758 
 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 1706 
Line 1835 
   wior=0;    wior=0;
 }  }
   
 \+  file-eof?       ( wfileid -- flag )     gforth  file_eof_query
 \+floating  flag = FLAG(feof((FILE *) wfileid));
   
 \g floating  
   
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)  ""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);
   
 d>f     ( d -- r )              float   d_to_f  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 defined(unix) || defined(__MACH__)
   /* Darwin/MacOS X sets __MACH__, but not unix. */
   '\n'
   #else
   '\r','\n'
   #endif
   };
   c_addr=newline;
   u=sizeof(newline);
   :
    "newline count ;
   Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
   
   \+os
   
   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
   
   \g floating
   
   comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
   comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
   
   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;  r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
Line 2018 
Line 2242 
 :  :
  [ 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  \g locals
Line 2033 
Line 2285 
 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 2050 
Line 2302 
 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 2167 
Line 2419 
   
 \+  \+
   
 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 2181 
Line 2427 
 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  primtable       ( -- wprimtable )       new
 ""Close the directory specified by @i{dir-id}.""  ""wprimtable is a table containing the xts of the primitives indexed
 wior = IOR(closedir((DIR *)wdirid));  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[] = {  
 #if defined(unix) || defined(__MACH__)  
 /* Darwin/MacOS X sets __MACH__, but not unix. */  
 '\n'  
 #else  
 '\r','\n'  
 #endif  
 };  
 c_addr=newline;  
 u=sizeof(newline);  
 :  
  "newline count ;  
 Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,  
   
 \+os  \ 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
   
 \+  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
 v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star  flushing).""
 ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the  finish_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  
 ""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 0=          \ !f f  
  r> tuck cell+      \ !f branchoffset f IP+  
  and -rot @ and or  \ f&IP+|!f&branch  
  >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  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 f = forget_dyncode(c_code);  f = forget_dyncode(c_code);
Line 2791 
Line 2489 
 include(peeprules.vmg)  include(peeprules.vmg)
   
 \g end  \g end
   
 \+  

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help