Diff for /gforth/prim between versions 1.107 and 1.136

version 1.107, 2002/12/19 23:23:49 version 1.136, 2003/08/17 12:21:05
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 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
   \E
   \E include-skipped-insts on \ static superinsts include cells for components
   \E                          \ useful for dynamic programming and
   \E                          \ superinsts across entry points
   
 \   \ 
 \   \ 
Line 142  noop ( -- )  gforth Line 147  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 185  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 285  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 297  if (f==0) {
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( #ndisp f -- f )       new     question_dupe_question_branch  ?dup-?branch    ( #a_target f -- f )    new     question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""  ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {  if (f==0) {
   sp++;    sp++;
   IF_spTOS(spTOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
   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 320  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
   NEXT;    NEXT;
   #endif
 }  }
 SUPER_CONTINUE;  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 353  condbranch((+loop),n R:nlimit R:n1 -- R:
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = n1-nlimit;  Cell olddiff = n1-nlimit;
 n2=n1+n;          n2=n1+n;        
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
  2 pick r@ + r@ xor 0< 0=   2 pick r@ + r@ xor 0< 0=
  3 pick r> xor 0< 0= or   3 pick r> xor 0< 0= or
  IF    >r + >r dup @ + >r   IF    >r + >r @ >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+xconds  \+xconds
Line 281  if ((olddiff^(olddiff+n))>=0   /* the li Line 368  if ((olddiff^(olddiff+n))>=0   /* the li
 condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,  condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
 UCell olddiff = n1-nlimit;  UCell olddiff = n1-nlimit;
 n2=n1-u;  n2=n1-u;
 if (olddiff>u) {  ,if (olddiff>u) {
 ,)  ,)
   
 condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,  condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,
Line 296  if (n<0) { Line 383  if (n<0) {
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 n2=n1+n;  n2=n1+n;
 if (diff>=0 || newdiff<0) {  ,if (diff>=0 || newdiff<0) {
 ,)  ,)
   
 \+  \+
   
 unloop  ( R:w1 R:w2 -- )        core  (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for
 /* !! alias for 2rdrop */  
 :  
  r> rdrop rdrop >r ;  
   
 (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for  
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 nlimit=0;  nlimit=0;
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do  (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do
 :  :
  r> swap rot >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do  (?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth   paren_question_do
 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 439  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 462  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 485  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 508  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 444  cmove ( c_from c_to u -- ) string c_move Line 561  cmove ( c_from c_to u -- ) string c_move
 @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from low address to high address; i.e., for overlapping areas it is  from low address to high address; i.e., for overlapping areas it is
 safe if @i{c-to}=<@i{c-from}.""  safe if @i{c-to}=<@i{c-from}.""
 while (u-- > 0)  cmove(c_from,c_to,u);
   *c_to++ = *c_from++;  
 :  :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
Line 454  cmove> ( c_from c_to u -- ) string c_mov Line 570  cmove> ( c_from c_to u -- ) string c_mov
 @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from high address to low address; i.e., for overlapping areas it is  from high address to low address; i.e., for overlapping areas it is
 safe if @i{c-to}>=@i{c-from}.""  safe if @i{c-to}>=@i{c-from}.""
 while (u-- > 0)  cmove_up(c_from,c_to,u);
   c_to[u] = c_from[u];  
 :  :
  dup 0= IF  drop 2drop exit  THEN   dup 0= IF  drop 2drop exit  THEN
  rot over + -rot bounds swap 1-   rot over + -rot bounds swap 1-
Line 475  is 1. Currently this is based on the mac Line 590  is 1. Currently this is based on the mac
 comparison. In the future, this may change to consider the current  comparison. In the future, this may change to consider the current
 locale and its collation order.""  locale and its collation order.""
 /* close ' to keep fontify happy */   /* close ' to keep fontify happy */ 
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = compare(c_addr1, u1, c_addr2, u2);
 if (n==0)  
   n = u1-u2;  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  :
  rot 2dup swap - >r min swap -text dup   rot 2dup swap - >r min swap -text dup
  IF  rdrop  ELSE  drop r> sgn  THEN ;   IF  rdrop  ELSE  drop r> sgn  THEN ;
 : sgn ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
  dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 -text   ( c_addr1 u c_addr2 -- n )      new     dash_text  \ -text is only used by replaced primitives now; move it elsewhere
 n = memcmp(c_addr1, c_addr2, u);  \ -text ( c_addr1 u c_addr2 -- n )      new     dash_text
 if (n<0)  \ n = memcmp(c_addr1, c_addr2, u);
   n = -1;  \ if (n<0)
 else if (n>0)  \   n = -1;
   n = 1;  \ else if (n>0)
 :  \   n = 1;
  swap bounds  \ :
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0  \  swap bounds
  ELSE  c@ I c@ - unloop  THEN  sgn ;  \  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
 : sgn ( n -- -1/0/1 )  \  ELSE  c@ I c@ - unloop  THEN  sgn ;
  dup 0= IF EXIT THEN  0< 2* 1+ ;  \ : sgn ( n -- -1/0/1 )
   \  dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 toupper ( c1 -- c2 )    gforth  toupper ( c1 -- c2 )    gforth
 ""If @i{c1} is a lower-case character (in the current locale), @i{c2}  ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
Line 508  c2 = toupper(c1); Line 618  c2 = toupper(c1);
 :  :
  dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;   dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
   
 capscomp        ( c_addr1 u c_addr2 -- n )      new  
 n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  
  swap bounds  
  ?DO  dup c@ I c@ <>  
      IF  dup c@ toupper I c@ toupper =  
      ELSE  true  THEN  WHILE  1+  LOOP  drop 0  
  ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;  
   
 -trailing       ( c_addr u1 -- c_addr u2 )              string  dash_trailing  
 ""Adjust the string specified by @i{c-addr, u1} to remove all trailing  
 spaces. @i{u2} is the length of the modified string.""  
 u2 = u1;  
 while (u2>0 && c_addr[u2-1] == ' ')  
   u2--;  
 :  
  BEGIN  1- 2dup + c@ bl =  WHILE  
         dup  0= UNTIL  ELSE  1+  THEN ;  
   
 /string ( c_addr1 u1 n -- c_addr2 u2 )  string  slash_string  /string ( c_addr1 u1 n -- c_addr2 u2 )  string  slash_string
 ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}  ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
 characters from the start of the string.""  characters from the start of the string.""
Line 541  u2 = u1-n; Line 628  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 913  lshift ( u1 n -- u2 )  core l_shift
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
   \g compare
   
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,  define(comparisons,
 $1=     ( $2 -- f )             $6      $3equals  $1=     ( $2 -- f )             $6      $3equals
Line 938  f = FLAG(u1-u2 < u3-u2); Line 1036  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 1070  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 988  rdrop ( R:w -- )  gforth Line 1084  rdrop ( R:w -- )  gforth
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     ( w1 w2 -- R:w1 R:w2 )  core-ext        two_to_r  2>r     ( d -- R:d )    core-ext        two_to_r
 :  :
  swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;
   
 2r>     ( R:w1 R:w2 -- w1 w2 )  core-ext        two_r_from  2r>     ( R:d -- d )    core-ext        two_r_from
 :  :
  r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;
   
 2r@     ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )        core-ext        two_r_fetch  2r@     ( R:d -- R:d d )        core-ext        two_r_fetch
 :  :
  i' j ;   i' j ;
   
 2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop  2rdrop  ( R:d -- )              gforth  two_r_drop
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1090  w = sp[u+1]; Line 1186  w = sp[u+1];
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
   \g memory
   
 @       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
 ""@i{w} is the cell stored at @i{a_addr}.""  ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
   
   \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
 !       ( w a_addr -- )         core    store  !       ( w a_addr -- )         core    store
 ""Store @i{w} into the cell at @i{a-addr}.""  ""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;  *a_addr = w;
Line 1211  c_addr2 = c_addr1+1; Line 1314  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  \g compiler
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  
   if ((UCell)F83NAME_COUNT(f83name1)==u &&  (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  longname2=listlfind(c_addr, u, longname1);
     break;  
 f83name2=f83name1;  
 :  :
     BEGIN  dup WHILE  (find-samelen)  dup  WHILE      BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
         >r 2dup r@ cell+ char+ capscomp  0=          >r 2dup r@ cell+ cell+ capscomp  0=
         IF  2drop r>  EXIT  THEN          IF  2drop r>  EXIT  THEN
         r> @          r> @
     REPEAT  THEN  nip nip ;      REPEAT  THEN  nip nip ;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (findl-samelen) ( u longname1 -- u longname2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL THEN ;      BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
   
 \+hash  \+hash
   
 (hashfind)      ( c_addr u a_addr -- f83name2 ) new     paren_hashfind  (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind
 struct F83Name *f83name1;  longname2 = hashlfind(c_addr, u, a_addr);
 f83name2=NULL;  
 while(a_addr != NULL)  
 {  
    f83name1=(struct F83Name *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)F83NAME_COUNT(f83name1)==u &&  
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  
      {  
         f83name2=f83name1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ c@ $1F and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
         IF  2dup r@ cell+ char+ capscomp 0=          IF  2dup r@ cell+ cell+ capscomp 0=
             IF  2drop r> rdrop  EXIT  THEN  THEN              IF  2drop r> rdrop  EXIT  THEN  THEN
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (tablefind)     ( c_addr u a_addr -- f83name2 ) new     paren_tablefind  (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind
 ""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
 struct F83Name *f83name1;  longname2 = tablelfind(c_addr, u, a_addr);
 f83name2=NULL;  
 while(a_addr != NULL)  
 {  
    f83name1=(struct F83Name *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)F83NAME_COUNT(f83name1)==u &&  
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  
      {  
         f83name2=f83name1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ c@ $1F and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
         IF  2dup r@ cell+ char+ -text 0=          IF  2dup r@ cell+ cell+ -text 0=
             IF  2drop r> rdrop  EXIT  THEN  THEN              IF  2drop r> rdrop  EXIT  THEN  THEN
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (hashkey)       ( c_addr u1 -- u2 )             gforth  paren_hashkey  
 u2=0;  
 while(u1--)  
    u2+=(Cell)toupper(*c_addr++);  
 :  
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;  
   
 (hashkey1)      ( c_addr u ubits -- ukey )              gforth  paren_hashkey1  (hashkey1)      ( c_addr u ubits -- ukey )              gforth  paren_hashkey1
 ""ukey is the hash key for the string c_addr u fitting in ubits bits""  ""ukey is the hash key for the string c_addr u fitting in ubits bits""
 /* this hash function rotates the key at every step by rot bits within  ukey = hashkey1(c_addr, u, ubits);
    ubits bits and xors it with the character. This function does ok in  
    the chi-sqare-test.  Rot should be <=7 (preferably <=5) for  
    ASCII strings (larger if ubits is large), and should share no  
    divisors with ubits.  
 */  
 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;  
 for (ukey=0; cp<c_addr+u; cp++)  
     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))   
              ^ toupper(*cp))  
             & ((1<<ubits)-1));  
 :  :
  dup rot-values + c@ over 1 swap lshift 1- >r   dup rot-values + c@ over 1 swap lshift 1- >r
  tuck - 2swap r> 0 2swap bounds   tuck - 2swap r> 0 2swap bounds
Line 1311  Create rot-values Line 1369  Create rot-values
 \+  \+
   
 (parse-white)   ( c_addr1 u1 -- c_addr2 u2 )    gforth  paren_parse_white  (parse-white)   ( c_addr1 u1 -- c_addr2 u2 )    gforth  paren_parse_white
 /* use !isgraph instead of isspace? */  struct Cellpair r=parse_white(c_addr1, u1);
 Char *endp = c_addr1+u1;  c_addr2 = (Char *)(r.n1);
 while (c_addr1<endp && isspace(*c_addr1))  u2 = r.n2;
   c_addr1++;  
 if (c_addr1<endp) {  
   for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)  
     ;  
   u2 = c_addr1-c_addr2;  
 }  
 else {  
   c_addr2 = c_addr1;  
   u2 = 0;  
 }  
 :  :
  BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string   BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string
  REPEAT  THEN  2dup   REPEAT  THEN  2dup
Line 1342  f_addr = (Float *)((((Cell)c_addr)+(size Line 1390  f_addr = (Float *)((((Cell)c_addr)+(size
 :  :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 >body   ( xt -- a_addr )        core    to_body  
 "" Get the address of the body of the word represented by @i{xt} (the address  
 of the word's data field).""  
 a_addr = PFA(xt);  
 :  
     2 cells + ;  
   
 \ threading stuff is currently only interesting if we have a compiler  \ threading stuff is currently only interesting if we have a compiler
 \fhas? standardthreading has? compiler and [IF]  \fhas? standardthreading has? compiler and [IF]
   
 >code-address   ( xt -- c_addr )                gforth  to_code_address  
 ""@i{c-addr} is the code address of the word @i{xt}.""  
 /* !! This behaves installation-dependently for DOES-words */  
 c_addr = (Address)CODE_ADDRESS(xt);  
 :  
     @ ;  
   
 >does-code      ( xt -- a_addr )                gforth  to_does_code  
 ""If @i{xt} is the execution token of a child of a @code{DOES>} word,  
 @i{a-addr} is the start of the Forth code after the @code{DOES>};  
 Otherwise @i{a-addr} is 0.""  
 a_addr = (Cell *)DOES_CODE(xt);  
 :  
     cell+ @ ;  
   
 code-address!   ( c_addr xt -- )                gforth  code_address_store  
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  
 MAKE_CF(xt, c_addr);  
 :  
     ! ;  
   
 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 1464  FLUSH_ICACHE(c_addr,u); Line 1462  FLUSH_ICACHE(c_addr,u);
 SUPER_END;  SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  paren_system
 #ifndef MSDOS  #ifndef MSDOS
 int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
 deprep_terminal();  deprep_terminal();
Line 1496  wior = IOR(wretval==-1); Line 1494  wior = IOR(wretval==-1);
 time&date       ( -- nsec nmin nhour nday nmonth nyear )        facility-ext    time_and_date  time&date       ( -- nsec nmin nhour nday nmonth nyear )        facility-ext    time_and_date
 ""Report the current time of day. Seconds, minutes and hours are numbered from 0.  ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
 Months are numbered from 1.""  Months are numbered from 1.""
 struct timeval time1;  #if 1
   time_t now;
   struct tm *ltime;
   time(&now);
   ltime=localtime(&now);
   #else
   struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
 gettimeofday(&time1,&zone1);  gettimeofday(&time1,&zone1);
 /* !! Single Unix specification:   /* !! Single Unix specification: 
    If tzp is not a null pointer, the behaviour is unspecified. */     If tzp is not a null pointer, the behaviour is unspecified. */
 ltime=localtime((time_t *)&time1.tv_sec);  ltime=localtime((time_t *)&time1.tv_sec);
   #endif
 nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
 nmonth=ltime->tm_mon+1;  nmonth=ltime->tm_mon+1;
 nday  =ltime->tm_mday;  nday  =ltime->tm_mday;
Line 1556  c_addr = strerror(n); Line 1561  c_addr = strerror(n);
 u = strlen(c_addr);  u = strlen(c_addr);
   
 strsignal       ( n -- c_addr u )       gforth  strsignal       ( n -- c_addr u )       gforth
 c_addr = strsignal(n);  c_addr = (Address)strsignal(n);
 u = strlen(c_addr);  u = strlen(c_addr);
   
 call-c  ( w -- )        gforth  call_c  call-c  ( w -- )        gforth  call_c
Line 1600  wior = IOR(unlink(tilde_cstr(c_addr, u, Line 1605  wior = IOR(unlink(tilde_cstr(c_addr, u,
   
 rename-file     ( c_addr1 u1 c_addr2 u2 -- wior )       file-ext        rename_file  rename-file     ( c_addr1 u1 c_addr2 u2 -- wior )       file-ext        rename_file
 ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""  ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);  wior = rename_file(c_addr1, u1, c_addr2, u2);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);  
   
 file-position   ( wfileid -- ud wior )  file    file_position  file-position   ( wfileid -- ud wior )  file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
 ud = LONG2UD(ftell((FILE *)wfileid));  ud = OFF2UD(ftello((FILE *)wfileid));
 wior = IOR(UD2LONG(ud)==-1);  wior = IOR(UD2OFF(ud)==-1);
   
 reposition-file ( ud wfileid -- wior )  file    reposition_file  reposition-file ( ud wfileid -- wior )  file    reposition_file
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);  wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1);
   
 file-size       ( wfileid -- ud wior )  file    file_size  file-size       ( wfileid -- ud wior )  file    file_size
 struct stat buf;  struct stat buf;
 wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);  wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 ud = LONG2UD(buf.st_size);  ud = OFF2UD(buf.st_size);
   
 resize-file     ( ud wfileid -- wior )  file    resize_file  resize-file     ( ud wfileid -- wior )  file    resize_file
 wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1);  wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1);
   
 read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file  read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
Line 1627  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1631  wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 read-line       ( c_addr u1 wfileid -- u2 flag wior )   file    read_line  (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior ) file   paren_read_line
 /* this may one day be replaced with : read-line (read-line) nip ; */  struct Cellquad r = read_line(c_addr, u1, wfileid);
 Cell c;  u2   = r.n1;
 flag=-1;  flag = r.n2;
 for(u2=0; u2<u1; u2++)  u3   = r.n3;
 {  wior = r.n4;
    c = getc((FILE *)wfileid);  
    if (c=='\n') break;  
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  
        ungetc(c,(FILE *)wfileid);  
      break;  
    }  
    if (c==EOF) {  
         flag=FLAG(u2!=0);  
         break;  
      }  
    c_addr[u2] = (Char)c;  
 }  
 wior=FILEIO(ferror((FILE *)wfileid));  
   
 \+  \+
   
Line 1678  flush-file ( wfileid -- wior )  file-ext Line 1668  flush-file ( wfileid -- wior )  file-ext
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 file-status     ( c_addr u -- wfam wior )       file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
 char *filename=tilde_cstr(c_addr, u, 1);  struct Cellpair r = file_status(c_addr, u);
 if (access (filename, F_OK) != 0) {  wfam = r.n1;
   wfam=0;  wior = r.n2;
   wior=IOR(1);  
 }  file-eof?       ( wfileid -- flag )     gforth  file_eof_query
 else if (access (filename, R_OK | W_OK) == 0) {  flag = FLAG(feof((FILE *) wfileid));
   wfam=2; /* r/w */  
   wior=0;  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
 }  ""Open the directory specified by @i{c-addr, u}
 else if (access (filename, R_OK) == 0) {  and return @i{dir-id} for futher access to it.""
   wfam=0; /* r/o */  wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
   wior=0;  wior =  IOR(wdirid == 0);
 }  
 else if (access (filename, W_OK) == 0) {  read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
   wfam=4; /* w/o */  ""Attempt to read the next entry from the directory specified
   wior=0;  by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. 
 }  If the attempt fails because there is no more entries,
 else {  @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
   wfam=1; /* well, we cannot access the file, but better deliver a legal  If the attempt to read the next entry fails because of any other reason, 
             access mode (r/o bin), so we get a decent error later upon open. */  return @i{ior}<>0.
   wior=0;  If the attempt succeeds, store file name to the buffer at @i{c-addr}
   and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
   If the length of the file name is greater than @i{u1}, 
   store first @i{u1} characters from file name into the buffer and
   indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
   struct dirent * dent;
   dent = readdir((DIR *)wdirid);
   wior = 0;
   flag = -1;
   if(dent == NULL) {
     u2 = 0;
     flag = 0;
   } else {
     u2 = strlen(dent->d_name);
     if(u2 > u1) {
       u2 = u1;
       wior = -512-ENAMETOOLONG;
     }
     memmove(c_addr, dent->d_name, u2);
 }  }
   
   close-dir       ( wdirid -- wior )      gforth  close_dir
   ""Close the directory specified by @i{dir-id}.""
   wior = IOR(closedir((DIR *)wdirid));
   
   filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file
   char * string = cstr(c_addr1, u1, 1);
   char * pattern = cstr(c_addr2, u2, 0);
   flag = FLAG(!fnmatch(pattern, string, 0));
   
   \+
   
   newline ( -- c_addr u ) gforth
   ""String containing the newline sequence of the host OS""
   char newline[] = {
   #if DIRSEP=='/'
   /* Unix */
   '\n'
   #else
   /* DOS, Win, OS/2 */
   '\r','\n'
   #endif
   };
   c_addr=newline;
   u=sizeof(newline);
   :
    "newline count ;
   Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
   
   \+os
   
   utime   ( -- dtime )    gforth
   ""Report the current time in microseconds since some epoch.""
   struct timeval time1;
   gettimeofday(&time1,NULL);
   dtime = timeval2us(&time1);
   
   cputime ( -- duser dsystem ) gforth
   ""duser and dsystem are the respective user- and system-level CPU
   times used since the start of the Forth system (excluding child
   processes), in microseconds (the granularity may be much larger,
   however).  On platforms without the getrusage call, it reports elapsed
   time (since some epoch) for duser and 0 for dsystem.""
   #ifdef HAVE_GETRUSAGE
   struct rusage usage;
   getrusage(RUSAGE_SELF, &usage);
   duser = timeval2us(&usage.ru_utime);
   dsystem = timeval2us(&usage.ru_stime);
   #else
   struct timeval time1;
   gettimeofday(&time1,NULL);
   duser = timeval2us(&time1);
   #ifndef BUGGY_LONG_LONG
   dsystem = (DCell)0;
   #else
   dsystem=(DCell){0,0};
   #endif
   #endif
   
 \+  \+
   
 \+floating  \+floating
   
 \g floating  \g floating
Line 1712  comparisons(f0, r, f_zero_, r, 0., float Line 1779  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 1827  else Line 1898  else
   
 represent       ( r c_addr u -- n f1 f2 )       float  represent       ( r c_addr u -- n f1 f2 )       float
 char *sig;  char *sig;
   size_t siglen;
 int flag;  int flag;
 int decpt;  int decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &flag);
 n=(r==0 ? 1 : decpt);  n=(r==0. ? 1 : decpt);
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit((unsigned)(sig[0]))!=0);  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);  siglen=strlen(sig);
   if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */
     siglen=u;
   memcpy(c_addr,sig,siglen);
   memset(c_addr+siglen,f2?'0':' ',u-siglen);
   
 >float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- flag )    float   to_float
 ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
Line 1842  representation. If the string represents Line 1918  representation. If the string represents
 @i{r} is placed on the floating-point stack and @i{flag} is  @i{r} is placed on the floating-point stack and @i{flag} is
 true. Otherwise, @i{flag} is false. A string of blanks is a special  true. Otherwise, @i{flag} is false. A string of blanks is a special
 case and represents the floating-point number 0.""  case and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */  
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  flag = to_float(c_addr, u, &r);
 char *endconv;  if (flag) {
 int sign = 0;    IF_fpTOS(fp[0] = fpTOS);
 if(number[0]=='-') {    fp += -1;
    sign = 1;    fpTOS = r;
    number++;  
    u--;  
 }  
 while(isspace((unsigned)(number[--u])) && u>0);  
 switch(number[u])  
 {  
    case 'd':  
    case 'D':  
    case 'e':  
    case 'E':  break;  
    default :  u++; break;  
 }  
 number[u]='\0';  
 r=strtod(number,&endconv);  
 if((flag=FLAG(!(Cell)*endconv)))  
 {  
    IF_fpTOS(fp[0] = fpTOS);  
    fp += -1;  
    fpTOS = sign ? -r : r;  
 }  
 else if(*endconv=='d' || *endconv=='D')  
 {  
    *endconv='E';  
    r=strtod(number,&endconv);  
    if((flag=FLAG(!(Cell)*endconv)))  
      {  
         IF_fpTOS(fp[0] = fpTOS);  
         fp += -1;  
         fpTOS = sign ? -r : r;  
      }  
 }  }
   
 fabs    ( r1 -- r2 )    float-ext       f_abs  fabs    ( r1 -- r2 )    float-ext       f_abs
Line 2013  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2058  df_addr = (DFloat *)((((Cell)c_addr)+(si
 :  :
  [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
   v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
   ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
   next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
   ucount elements.""
   r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount);
   :
    >r swap 2swap swap 0e r> 0 ?DO
        dup f@ over + 2swap dup f@ f* f+ over + 2swap
    LOOP 2drop 2drop ; 
   
   faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
   ""vy=ra*vx+vy""
   faxpy(ra, f_x, nstridex, f_y, nstridey, ucount);
   :
    >r swap 2swap swap r> 0 ?DO
        fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
    LOOP 2drop 2drop fdrop ;
   
   \+
   
 \ The following words access machine/OS/installation-dependent  \ The following words access machine/OS/installation-dependent
 \   Gforth internals  \   Gforth internals
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+  
 \+glocals  \+glocals
   
   \g locals
   
 @local# ( #noffset -- w )       gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
 w = *(Cell *)(lp+noffset);  w = *(Cell *)(lp+noffset);
   
 @local0 ( -- w )        new     fetch_local_zero  @local0 ( -- w )        new     fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));  w = ((Cell *)lp)[0];
   
 @local1 ( -- w )        new     fetch_local_four  @local1 ( -- w )        new     fetch_local_four
 w = *(Cell *)(lp+1*sizeof(Cell));  w = ((Cell *)lp)[1];
   
 @local2 ( -- w )        new     fetch_local_eight  @local2 ( -- w )        new     fetch_local_eight
 w = *(Cell *)(lp+2*sizeof(Cell));  w = ((Cell *)lp)[2];
   
 @local3 ( -- w )        new     fetch_local_twelve  @local3 ( -- w )        new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = ((Cell *)lp)[3];
   
 \+floating  \+floating
   
Line 2043  f@local# ( #noffset -- r ) gforth f_fetc Line 2110  f@local# ( #noffset -- r ) gforth f_fetc
 r = *(Float *)(lp+noffset);  r = *(Float *)(lp+noffset);
   
 f@local0        ( -- r )        new     f_fetch_local_zero  f@local0        ( -- r )        new     f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));  r = ((Float *)lp)[0];
   
 f@local1        ( -- r )        new     f_fetch_local_eight  f@local1        ( -- r )        new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  r = ((Float *)lp)[1];
   
 \+  \+
   
Line 2093  r = fp[u+1]; /* +1, because update of fp Line 2160  r = fp[u+1]; /* +1, because update of fp
   
 \+OS  \+OS
   
   \g syslib
   
   open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   #ifndef RTLD_GLOBAL
   #define RTLD_GLOBAL 0
   #endif
   u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
   #else
   #  ifdef _WIN32
   u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
   #  else
   #warning Define open-lib!
   u2 = 0;
   #  endif
   #endif
   
   lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
   #else
   #  ifdef _WIN32
   u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
   #  else
   #warning Define lib-sym!
   u3 = 0;
   #  endif
   #endif
   
   \+FFCALL
   
   av-start-void   ( c_addr -- )   gforth  av_start_void
   av_start_void(alist, c_addr);
   
   av-start-int    ( c_addr -- )   gforth  av_start_int
   av_start_int(alist, c_addr, &irv);
   
   av-start-float  ( c_addr -- )   gforth  av_start_float
   av_start_float(alist, c_addr, &frv);
   
   av-start-double ( c_addr -- )   gforth  av_start_double
   av_start_double(alist, c_addr, &drv);
   
   av-start-longlong       ( c_addr -- )   gforth  av_start_longlong
   av_start_longlong(alist, c_addr, &llrv);
   
   av-start-ptr    ( c_addr -- )   gforth  av_start_ptr
   av_start_ptr(alist, c_addr, void*, &prv);
   
   av-int  ( w -- )  gforth  av_int
   av_int(alist, w);
   
   av-float        ( r -- )        gforth  av_float
   av_float(alist, r);
   
   av-double       ( r -- )        gforth  av_double
   av_double(alist, r);
   
   av-longlong     ( d -- )        gforth  av_longlong
   av_longlong(alist, d);
   
   av-ptr  ( c_addr -- )   gforth  av_ptr
   av_ptr(alist, void*, c_addr);
   
   av-int-r  ( R:w -- )  gforth  av_int_r
   av_int(alist, w);
   
   av-float-r      ( -- )  gforth  av_float_r
   float r = *(Float*)lp;
   lp += sizeof(Float);
   av_float(alist, r);
   
   av-double-r     ( -- )  gforth  av_double_r
   double r = *(Float*)lp;
   lp += sizeof(Float);
   av_double(alist, r);
   
   av-longlong-r   ( R:d -- )      gforth  av_longlong_r
   av_longlong(alist, d);
   
   av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r
   av_ptr(alist, void*, c_addr);
   
   av-call-void    ( -- )  gforth  av_call_void
   SAVE_REGS
   av_call(alist);
   REST_REGS
   
   av-call-int     ( -- w )        gforth  av_call_int
   SAVE_REGS
   av_call(alist);
   REST_REGS
   w = irv;
   
   av-call-float   ( -- r )        gforth  av_call_float
   SAVE_REGS
   av_call(alist);
   REST_REGS
   r = frv;
   
   av-call-double  ( -- r )        gforth  av_call_double
   SAVE_REGS
   av_call(alist);
   REST_REGS
   r = drv;
   
   av-call-longlong        ( -- d )        gforth  av_call_longlong
   SAVE_REGS
   av_call(alist);
   REST_REGS
   d = llrv;
   
   av-call-ptr     ( -- c_addr )   gforth  av_call_ptr
   SAVE_REGS
   av_call(alist);
   REST_REGS
   c_addr = prv;
   
   alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback
   c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);
   
   va-start-void   ( -- )  gforth  va_start_void
   va_start_void(clist);
   
   va-start-int    ( -- )  gforth  va_start_int
   va_start_int(clist);
   
   va-start-longlong       ( -- )  gforth  va_start_longlong
   va_start_longlong(clist);
   
   va-start-ptr    ( -- )  gforth  va_start_ptr
   va_start_ptr(clist, (char *));
   
   va-start-float  ( -- )  gforth  va_start_float
   va_start_float(clist);
   
   va-start-double ( -- )  gforth  va_start_double
   va_start_double(clist);
   
   va-arg-int      ( -- w )        gforth  va_arg_int
   w = va_arg_int(clist);
   
   va-arg-longlong ( -- d )        gforth  va_arg_longlong
   d = va_arg_longlong(clist);
   
   va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr
   c_addr = (char *)va_arg_ptr(clist,char*);
   
   va-arg-float    ( -- r )        gforth  va_arg_float
   r = va_arg_float(clist);
   
   va-arg-double   ( -- r )        gforth  va_arg_double
   r = va_arg_double(clist);
   
   va-return-void ( -- )   gforth va_return_void
   va_return_void(clist);
   return 0;
   
   va-return-int ( w -- )  gforth va_return_int
   va_return_int(clist, w);
   return 0;
   
   va-return-ptr ( c_addr -- )     gforth va_return_ptr
   va_return_ptr(clist, void *, c_addr);
   return 0;
   
   va-return-longlong ( d -- )     gforth va_return_longlong
   va_return_longlong(clist, d);
   return 0;
   
   va-return-float ( r -- )        gforth va_return_float
   va_return_float(clist, r);
   return 0;
   
   va-return-double ( r -- )       gforth va_return_double
   va_return_double(clist, r);
   return 0;
   
   \-
   
 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 2124  rret = (SYSCALL(Float(*)(argdlist($1)))u Line 2371  rret = (SYSCALL(Float(*)(argdlist($1)))u
   
 \ close ' to keep fontify happy  \ close ' to keep fontify happy
   
 open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib  
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 #ifndef RTLD_GLOBAL  
 #define RTLD_GLOBAL 0  
 #endif  
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  
 #else  
 #  ifdef _WIN32  
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define open-lib!  
 u2 = 0;  
 #  endif  
 #endif  
   
 lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym  
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  
 #else  
 #  ifdef _WIN32  
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define lib-sym!  
 u3 = 0;  
 #  endif  
 #endif  
   
 uploop(i, 0, 7, `icall(i)')  uploop(i, 0, 7, `icall(i)')
 icall(20)  icall(20)
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+  \+
   \+
 up!     ( a_addr -- )   gforth  up_store  
 UP=up=(char *)a_addr;  
 :  
  up ! ;  
 Variable UP  
   
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_fpTOS(fp[0]=fpTOS);  IF_fpTOS(fp[0]=fpTOS);
Line 2172  fp=FP; Line 2387  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
 ""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  compile-prim1 ( a_prim -- ) gforth compile_prim1
 ""Attempt to read the next entry from the directory specified  ""compile prim (incl. immargs) at @var{a_prim}""
 by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}.   compile_prim1(a_prim);
 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  
   
 v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star  
 ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the  
 next at f_addr1+nstride1 and so on (similar for v2). Both vectors have  
 ucount elements.""  
 for (r=0.; ucount>0; ucount--) {  
   r += *f_addr1 * *f_addr2;  
   f_addr1 = (Float *)(((Address)f_addr1)+nstride1);  
   f_addr2 = (Float *)(((Address)f_addr2)+nstride2);  
 }  
 :  
  >r swap 2swap swap 0e r> 0 ?DO  
      dup f@ over + 2swap dup f@ f* f+ over + 2swap  
  LOOP 2drop 2drop ;   
   
 faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth  
 ""vy=ra*vx+vy""  
 for (; ucount>0; ucount--) {  
   *f_y += ra * *f_x;  
   f_x = (Float *)(((Address)f_x)+nstridex);  
   f_y = (Float *)(((Address)f_y)+nstridey);  
 }  
 :  
  >r swap 2swap swap r> 0 ?DO  
      fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap  
  LOOP 2drop 2drop fdrop ;  
   
 \+  
   
 \+file  
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line  
 Cell c;  
 flag=-1;  
 u3=0;  
 for(u2=0; u2<u1; u2++)  
 {  
    c = getc((FILE *)wfileid);  
    u3++;  
    if (c=='\n') break;  
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  
        ungetc(c,(FILE *)wfileid);  
      else  
        u3++;  
      break;  
    }  
    if (c==EOF) {  
         flag=FLAG(u2!=0);  
         break;  
      }  
    c_addr[u2] = (Char)c;  
 }  
 wior=FILEIO(ferror((FILE *)wfileid));  
   
 \+  
   
 (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind  
 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  finish-code ( -- ) gforth finish_code
 #ifdef NO_IP  ""Perform delayed steps in code generation (branch resolution, I-cache
     INST_TAIL;  flushing).""
 #endif  finish_code();
 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  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 #ifdef NO_IP  f = forget_dyncode(c_code);
     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  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 #ifdef NO_IP  ""a_prim is the code address of the primitive that has been
     INST_TAIL;  compile_prim1ed to a_code""
 #endif  a_prim = (Cell *)decompile_code((Label)a_code);
 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  \ set-next-code and call2 do not appear in images and can be
 \ renumbered arbitrarily  \ renumbered arbitrarily
Line 2761  JUMP(a_callee); Line 2425  JUMP(a_callee);
 assert(0);  assert(0);
 #endif  #endif
   
 compile-prim1 ( a_prim -- ) gforth compile_prim1  tag-offsets ( -- a_addr ) gforth tag_offsets
 ""compile prim (incl. immargs) at @var{a_prim}""  extern Cell groups[32];
 compile_prim1(a_prim);  a_addr = groups;
   
 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  \g static_super
 ""a_prim is the code address of the primitive that has been  
 compile_prim1ed to a_code""  
 a_prim = decompile_code(a_code);  
   
 \+  \C #if !defined(GFORTH_DEBUGGING) && !defined(INDIRECT_THREADED) && !defined(DOUBLY_INDIRECT) && !defined(VM_PROFILING)
   
 include(peeprules.vmg)  include(peeprules.vmg)
   
 \+  \C #endif
   
   \g end

Removed from v.1.107  
changed lines
  Added in v.1.136


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