Diff for /gforth/prim between versions 1.63 and 1.110

version 1.63, 2000/09/23 15:46:58 version 1.110, 2002/12/28 17:18:27
Line 53 Line 53
 \ your code does not fall through, the results are not stored into the  \ your code does not fall through, the results are not stored into the
 \ stack. Use different names on both sides of the '--', if you change a  \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).  \ value (some stores to the stack are optimized away).
 \   \
 \   \ For superinstructions the syntax is:
   \
   \ forth-name [/ c-name] = forth-name forth-name ...
   \
 \   \ 
 \ The stack variables have the following types:  \ The stack variables have the following types:
 \   \ 
 \ name matches  type  \ name matches  type
 \ f.*           Bool  \ f.*           Bool
 \ c.*           Char  \ c.*           Char
 \ [nw].*                Cell  \ [nw].*        Cell
 \ u.*           UCell  \ u.*           UCell
 \ d.*           DCell  \ d.*           DCell
 \ ud.*          UDCell  \ ud.*          UDCell
Line 72 Line 75
 \ df_.*         DFloat *  \ df_.*         DFloat *
 \ sf_.*         SFloat *  \ sf_.*         SFloat *
 \ xt.*          XT  \ xt.*          XT
 \ wid.*         WID  
 \ f83name.*     F83Name *  \ f83name.*     F83Name *
   
   \E stack data-stack   sp Cell
   \E stack fp-stack     fp Float
   \E stack return-stack rp Cell
   \E
   \E get-current prefixes set-current
   \E 
   \E s" Bool"             single data-stack type-prefix f
   \E s" Char"             single data-stack type-prefix c
   \E s" Cell"             single data-stack type-prefix n
   \E s" Cell"             single data-stack type-prefix w
   \E s" UCell"            single data-stack type-prefix u
   \E s" DCell"            double data-stack type-prefix d
   \E s" UDCell"           double data-stack type-prefix ud
   \E s" Float"            single fp-stack   type-prefix r
   \E s" Cell *"           single data-stack type-prefix a_
   \E s" Char *"           single data-stack type-prefix c_
   \E s" Float *"          single data-stack type-prefix f_
   \E s" DFloat *"         single data-stack type-prefix df_
   \E s" SFloat *"         single data-stack type-prefix sf_
   \E s" Xt"               single data-stack type-prefix xt
   \E s" struct F83Name *" single data-stack type-prefix f83name
   \E s" struct Longname *" single data-stack type-prefix longname
   \E 
   \E return-stack stack-prefix R:
   \E inst-stream  stack-prefix #
   \E 
   \E set-current
   \E store-optimization on
   \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
   
 \   \ 
 \   \ 
 \   \ 
Line 102 Line 135
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   undefine(`symbols')
   
   \g control
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
 ;  
 :  :
  ;   ;
   
 lit     ( -- w )                gforth  lit     ( #w -- w )             gforth
 w = (Cell)NEXT_INST;  
 INC_IP(1);  
 :  :
  r> dup @ swap cell+ >r ;   r> dup @ swap cell+ >r ;
   
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
   #ifndef NO_IP
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  #endif
   IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
   #ifndef NO_IP
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  #endif
   IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
Line 132  EXEC(*(Xt *)a_addr); Line 171  EXEC(*(Xt *)a_addr);
 \fhas? skipbranchprims 0= [IF]  \fhas? skipbranchprims 0= [IF]
 \+glocals  \+glocals
   
 branch-lp+!#    ( -- )  gforth  branch_lp_plus_store_number  branch-lp+!#    ( #ndisp #nlocals -- )  gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  lp += nlocals;
 lp += (Cell)(IP[1]);  SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
 goto branch;  
   
 \+  \+
   
 branch  ( -- )          gforth  branch  ( #ndisp -- )           gforth
 branch:  SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  
 :  :
  r> dup @ + >r ;   r> dup @ + >r ;
   
 \ condbranch(forthname,restline,code,forthcode)  \ condbranch(forthname,stackeffect,restline,code,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1      $2  $1 ( `#'ndisp $2 ) $3
 $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  $4      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
         NEXT;  INST_TAIL;
 }  }
 else  SUPER_CONTINUE;
     INC_IP(1);  $5
 $4  
   
 \+glocals  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number
 $3    goto branch_adjust_lp;  $4    lp += nlocals;
   SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
   INST_TAIL;
 }  }
 else  SUPER_CONTINUE;
     INC_IP(2);  
   
 \+  \+
 )  )
   
 condbranch(?branch,( f -- )             f83     question_branch,  condbranch(?branch,f --,f83     question_branch,
 if (f==0) {  if (f==0) {
     IF_TOS(TOS = sp[0]);  
 ,:  ,:
  0= dup     \ !f !f   0= dup     \ !f !f
  r> dup @   \ !f !f IP branchoffset   r> dup @   \ !f !f IP branchoffset
Line 183  if (f==0) { Line 219  if (f==0) {
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( f -- f )      new     question_dupe_question_branch  ?dup-?branch    ( #ndisp 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_TOS(TOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT;    INST_TAIL;
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 ?dup-0=-?branch ( f -- )        new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #ndisp 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 202  few cycles in that case, but is easy to Line 237  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT;    NEXT;
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 \+  \+
 \f[THEN]  \f[THEN]
 \fhas? skiploopprims 0= [IF]  \fhas? skiploopprims 0= [IF]
   
 condbranch((next),( -- )                cmFORTH paren_next,  condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,
 if ((*rp)--) {  n2=n1-1;
   if (n1) {
 ,:  ,:
  r> r> dup 1- >r   r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)   IF dup @ + >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),( -- )                gforth  paren_loop,  condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
 Cell index = *rp+1;  n2=n1+1;
 Cell limit = rp[1];  if (n2 != nlimit) {
 if (index != limit) {  
     *rp = index;  
 ,:  ,:
  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 dup @ + >r THEN ;)
   
 condbranch((+loop),( n -- )             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 */
 Cell index = *rp;  
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = index-rp[1];  Cell olddiff = n1-nlimit;
   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 */) {
 #ifdef i386  
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
Line 252  if ((olddiff^(olddiff+n))>=0   /* the li Line 279  if ((olddiff^(olddiff+n))>=0   /* the li
   
 \+xconds  \+xconds
   
 condbranch((-loop),( u -- )             gforth  paren_minus_loop,  condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
 /* !! check this thoroughly */  UCell olddiff = n1-nlimit;
 Cell index = *rp;  n2=n1-u;
 UCell olddiff = index-rp[1];  
 if (olddiff>u) {  if (olddiff>u) {
 #ifdef i386  
     *rp -= u;  
 #else  
     *rp = index - u;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,)  ,)
   
 condbranch((s+loop),( n -- )            gforth  paren_symmetric_plus_loop,  condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     paren_symmetric_plus_loop,
 ""The run-time procedure compiled by S+LOOP. It loops until the index  ""The run-time procedure compiled by S+LOOP. It loops until the index
 crosses the boundary between limit and limit-sign(n). I.e. a symmetric  crosses the boundary between limit and limit-sign(n). I.e. a symmetric
 version of (+LOOP).""  version of (+LOOP).""
 /* !! check this thoroughly */  /* !! check this thoroughly */
 Cell index = *rp;  Cell diff = n1-nlimit;
 Cell diff = index-rp[1];  
 Cell newdiff = diff+n;  Cell newdiff = diff+n;
 if (n<0) {  if (n<0) {
     diff = -diff;      diff = -diff;
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
   n2=n1+n;
 if (diff>=0 || newdiff<0) {  if (diff>=0 || newdiff<0) {
 #ifdef i386  
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,)  ,)
   
 \+  \+
   
 unloop  ( -- )  core  unloop  ( R:w1 R:w2 -- )        core
 rp += 2;  /* !! alias for 2rdrop */
 :  :
  r> rdrop rdrop >r ;   r> rdrop rdrop >r ;
   
 (for)   ( 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! */
 *--rp = 0;  nlimit=0;
 *--rp = ncount;  
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    ( nlimit nstart -- )            gforth          paren_do  (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do
 /* or do it in high-level? 0.09/0.23% */  
 *--rp = nlimit;  
 *--rp = nstart;  
 :  :
  r> swap rot >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   ( nlimit nstart -- )    gforth  paren_question_do  (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart == nlimit) {  if (nstart == nlimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      INST_TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
Line 327  else { Line 333  else {
   
 \+xconds  \+xconds
   
 (+do)   ( nlimit nstart -- )    gforth  paren_plus_do  (+do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_plus_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      INST_TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 347  else { Line 349  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u+do)  ( ulimit ustart -- )    gforth  paren_u_plus_do  (u+do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_plus_do
 *--rp = ulimit;  
 *--rp = ustart;  
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      INST_TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 367  else { Line 365  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (-do)   ( nlimit nstart -- )    gforth  paren_minus_do  (-do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_minus_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      INST_TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 387  else { Line 381  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u-do)  ( ulimit ustart -- )    gforth  paren_u_minus_do  (u-do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_minus_do
 *--rp = ulimit;  
 *--rp = ustart;  
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
     IF_TOS(TOS = sp[0]);      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     goto branch;      INST_TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 412  else { Line 402  else {
 \ don't make any assumptions where the return stack is!!  \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!  \ implement this in machine code if it should run quickly!
   
 i       ( -- n )                core  i       ( R:n -- R:n n )                core
 n = *rp;  
 :  :
 \ rp@ cell+ @ ;  \ rp@ cell+ @ ;
   r> r> tuck >r >r ;    r> r> tuck >r >r ;
   
 i'      ( -- w )                gforth          i_tick  i'      ( R:w R:w2 -- R:w R:w2 w )              gforth          i_tick
 ""loop end value""  
 w = rp[1];  
 :  :
 \ rp@ cell+ cell+ @ ;  \ rp@ cell+ cell+ @ ;
   r> r> r> dup itmp ! >r >r >r itmp @ ;    r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp  variable itmp
   
 j       ( -- n )                core  j       ( R:n R:d1 -- n R:n R:d1 )              core
 n = rp[2];  
 :  :
 \ rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;    r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [IFUNDEF] itmp variable itmp [THEN]
   
 k       ( -- n )                gforth  k       ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )            gforth
 n = rp[4];  
 :  :
 \ rp@ [ 5 cells ] Literal + @ ;  \ rp@ [ 5 cells ] Literal + @ ;
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;    r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
Line 444  n = rp[4]; Line 429  n = rp[4];
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
   \g strings
   
 move    ( c_from c_to ucount -- )               core  move    ( c_from c_to ucount -- )               core
 ""Copy the contents of @i{ucount} aus at @i{c-from} to  ""Copy the contents of @i{ucount} aus at @i{c-from} to
 @i{c-to}. @code{move} works correctly even if the two areas overlap.""  @i{c-to}. @code{move} works correctly even if the two areas overlap.""
Line 553  u2 = u1-n; Line 540  u2 = u1-n;
 :  :
  tuck - >r + r> dup 0< IF  - 0  THEN ;   tuck - >r + r> dup 0< IF  - 0  THEN ;
   
   \g arith
   
 +       ( n1 n2 -- n )          core    plus  +       ( n1 n2 -- n )          core    plus
 n = n1+n2;  n = n1+n2;
   
Line 829  lshift ( u1 n -- u2 )  core l_shift Line 818  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 955  a_addr = sp+1; Line 946  a_addr = sp+1;
   
 sp!     ( a_addr -- )           gforth          sp_store  sp!     ( a_addr -- )           gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without spTOS caching */
   
 rp@     ( -- a_addr )           gforth          rp_fetch  rp@     ( -- a_addr )           gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
Line 973  fp = f_addr; Line 964  fp = f_addr;
   
 \+  \+
   
 ;s      ( -- )          gforth  semis  ;s      ( R:w -- )              gforth  semis
 ""The primitive compiled by @code{EXIT}.""  ""The primitive compiled by @code{EXIT}.""
 SET_IP((Xt *)(*rp++));  #ifdef NO_IP
   INST_TAIL;
   goto *(void *)w;
   #else
   SET_IP((Xt *)w);
   #endif
   
   \g stack
   
 >r      ( w -- )                core    to_r  >r      ( w -- R:w )            core    to_r
 ""@code{( R: -- w )}""  
 *--rp = w;  
 :  :
  (>r) ;   (>r) ;
 : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;  : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
   
 r>      ( -- w )                core    r_from  r>      ( R:w -- w )            core    r_from
 ""@code{( R: w -- )}""  
 w = *rp++;  
 :  :
  rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;   rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 Create (rdrop) ' ;s A,  Create (rdrop) ' ;s A,
   
 rdrop   ( -- )          gforth  rdrop   ( R:w -- )              gforth
 ""@code{( R: w -- )}""  
 rp++;  
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     ( w1 w2 -- )    core-ext        two_to_r  2>r     ( w1 w2 -- R:w1 R:w2 )  core-ext        two_to_r
 ""@code{( R: -- w1 w2 )}""  
 *--rp = w1;  
 *--rp = w2;  
 :  :
  swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;
   
 2r>     ( -- w1 w2 )    core-ext        two_r_from  2r>     ( R:w1 R:w2 -- w1 w2 )  core-ext        two_r_from
 ""@code{( R: w1 w2 -- )}""  
 w2 = *rp++;  
 w1 = *rp++;  
 :  :
  r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;
   
 2r@     ( -- w1 w2 )    core-ext        two_r_fetch  2r@     ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )        core-ext        two_r_fetch
 ""@code{( R: w1 w2 -- w1 w2 )}""  
 w2 = rp[0];  
 w1 = rp[1];  
 :  :
  i' j ;   i' j ;
   
 2rdrop  ( -- )          gforth  two_r_drop  2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop
 ""@code{( R: w1 w2 -- )}""  
 rp+=2;  
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1066  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1047  tuck ( w1 w2 -- w2 w1 w2 ) core-ext
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a  ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""  @code{dup} if w is nonzero.""
 if (w!=0) {  if (w!=0) {
   IF_TOS(*sp-- = w;)    IF_spTOS(*sp-- = w;)
 #ifndef USE_TOS  #ifndef USE_TOS
   *--sp = w;    *--sp = w;
 #endif  #endif
Line 1110  w = sp[u+1]; Line 1091  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;
Line 1231  c_addr2 = c_addr1+1; Line 1214  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
   \g compiler
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
Line 1244  f83name2=f83name1; Line 1229  f83name2=f83name1;
         r> @          r> @
     REPEAT  THEN  nip nip ;      REPEAT  THEN  nip nip ;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (find-samelen) ( u f83name1 -- u f83name2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;      BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL THEN ;
   
 \+hash  \+hash
   
Line 1308  while(u1--) Line 1293  while(u1--)
    ASCII strings (larger if ubits is large), and should share no     ASCII strings (larger if ubits is large), and should share no
    divisors with ubits.     divisors with ubits.
 */  */
 unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits];  static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5};
   unsigned rot = rot_values[ubits];
 Char *cp = c_addr;  Char *cp = c_addr;
 for (ukey=0; cp<c_addr+u; cp++)  for (ukey=0; cp<c_addr+u; cp++)
     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))       ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) 
Line 1389  a_addr = (Cell *)DOES_CODE(xt); Line 1375  a_addr = (Cell *)DOES_CODE(xt);
 code-address!   ( c_addr xt -- )                gforth  code_address_store  code-address!   ( c_addr xt -- )                gforth  code_address_store
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  :
     ! ;      ! ;
   
Line 1397  does-code! ( a_addr xt -- )  gforth does Line 1382  does-code! ( a_addr xt -- )  gforth does
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;  ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
 @i{a-addr} is the start of the Forth code after @code{DOES>}.""  @i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
Line 1405  does-handler! ( a_addr -- ) gforth does_ Line 1389  does-handler! ( a_addr -- ) gforth does_
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 @i{a-addr} points just behind a @code{DOES>}.""  @i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  
 :  :
     drop ;      drop ;
   
Line 1433  n=1; Line 1416  n=1;
   
 \f[THEN]  \f[THEN]
   
   \g hostos
   
 key-file        ( wfileid -- n )                gforth  paren_key_file  key-file        ( wfileid -- n )                gforth  paren_key_file
 #ifdef HAS_FILE  #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
Line 1481  cache."" Line 1466  cache.""
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE(c_addr,u);
   
 (bye)   ( n -- )        gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
   SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  peren_system
Line 1505  c_addr2 = getenv(cstr(c_addr1,u1,1)); Line 1491  c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
 wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
Line 1584  access the stack itself. The stack point Line 1570  access the stack itself. The stack point
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{FP}.""
 /* This is a first attempt at support for calls to C. This may change in  /* This is a first attempt at support for calls to C. This may change in
    the future */     the future */
 IF_FTOS(fp[0]=FTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 SP=sp;  SP=sp;
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  sp=SP;
 fp=FP;  fp=FP;
 IF_TOS(TOS=sp[0]);  IF_spTOS(spTOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+  \+
 \+file  \+file
Line 1624  wior = IOR(rename(tilde_cstr(c_addr1, u1 Line 1610  wior = IOR(rename(tilde_cstr(c_addr1, u1
   
 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 1647  if (wior) Line 1633  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 wior )   file    read_line
 ""this is only for backward compatibility""  /* this may one day be replaced with : read-line (read-line) nip ; */
 Cell c;  Cell c;
 flag=-1;  flag=-1;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
Line 1723  else { Line 1709  else {
 \+  \+
 \+floating  \+floating
   
   \g floating
   
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)  comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)  comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
   
Line 1735  r = d; Line 1723  r = d;
 #endif  #endif
   
 f>d     ( r -- d )              float   f_to_d  f>d     ( r -- d )              float   f_to_d
 #ifdef BUGGY_LONG_LONG  extern DCell double2ll(Float r);
 d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);  d = double2ll(r);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  
 #else  
 d = r;  
 #endif  
   
 f!      ( r f_addr -- ) float   f_store  f!      ( r f_addr -- ) float   f_store
 ""Store @i{r} into the float at address @i{f-addr}.""  ""Store @i{r} into the float at address @i{f-addr}.""
Line 1830  floor ( r1 -- r2 ) float Line 1814  floor ( r1 -- r2 ) float
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround  ( r1 -- r2 )    float   f_round  fround  ( r1 -- r2 )    gforth  f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
 /* !! unclear wording */  
 #ifdef HAVE_RINT  
 r2 = rint(r1);  r2 = rint(r1);
 #else  
 r2 = floor(r1+0.5);  
 /* !! This is not quite true to the rounding rules given in the standard */  
 #endif  
   
 fmax    ( r1 r2 -- r3 ) float   f_max  fmax    ( r1 r2 -- r3 ) float   f_max
 if (r1<r2)  if (r1<r2)
Line 1892  number[u]='\0'; Line 1870  number[u]='\0';
 r=strtod(number,&endconv);  r=strtod(number,&endconv);
 if((flag=FLAG(!(Cell)*endconv)))  if((flag=FLAG(!(Cell)*endconv)))
 {  {
    IF_FTOS(fp[0] = FTOS);     IF_fpTOS(fp[0] = fpTOS);
    fp += -1;     fp += -1;
    FTOS = sign ? -r : r;     fpTOS = sign ? -r : r;
 }  }
 else if(*endconv=='d' || *endconv=='D')  else if(*endconv=='d' || *endconv=='D')
 {  {
Line 1902  else if(*endconv=='d' || *endconv=='D') Line 1880  else if(*endconv=='d' || *endconv=='D')
    r=strtod(number,&endconv);     r=strtod(number,&endconv);
    if((flag=FLAG(!(Cell)*endconv)))     if((flag=FLAG(!(Cell)*endconv)))
      {       {
         IF_FTOS(fp[0] = FTOS);          IF_fpTOS(fp[0] = fpTOS);
         fp += -1;          fp += -1;
         FTOS = sign ? -r : r;          fpTOS = sign ? -r : r;
      }       }
 }  }
   
Line 2049  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2027  df_addr = (DFloat *)((((Cell)c_addr)+(si
 \+  \+
 \+glocals  \+glocals
   
 @local# ( -- w )        gforth  fetch_local_number  \g locals
 w = *(Cell *)(lp+(Cell)NEXT_INST);  
 INC_IP(1);  @local# ( #noffset -- w )       gforth  fetch_local_number
   w = *(Cell *)(lp+noffset);
   
 @local0 ( -- w )        new     fetch_local_zero  @local0 ( -- w )        new     fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));  w = *(Cell *)(lp+0*sizeof(Cell));
Line 2067  w = *(Cell *)(lp+3*sizeof(Cell)); Line 2046  w = *(Cell *)(lp+3*sizeof(Cell));
   
 \+floating  \+floating
   
 f@local#        ( -- r )        gforth  f_fetch_local_number  f@local#        ( #noffset -- r )       gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+noffset);
 INC_IP(1);  
   
 f@local0        ( -- r )        new     f_fetch_local_zero  f@local0        ( -- r )        new     f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));  r = *(Float *)(lp+0*sizeof(Float));
Line 2079  r = *(Float *)(lp+1*sizeof(Float)); Line 2057  r = *(Float *)(lp+1*sizeof(Float));
   
 \+  \+
   
 laddr#  ( -- c_addr )   gforth  laddr_number  laddr#  ( #noffset -- c_addr )  gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(Cell)NEXT_INST);  c_addr = (Char *)(lp+noffset);
 INC_IP(1);  
   
 lp+!#   ( -- )  gforth  lp_plus_store_number  lp+!#   ( #noffset -- ) gforth  lp_plus_store_number
 ""used with negative immediate values it allocates memory on the  ""used with negative immediate values it allocates memory on the
 local stack, a positive immediate argument drops memory from the local  local stack, a positive immediate argument drops memory from the local
 stack""  stack""
 lp += (Cell)NEXT_INST;  lp += noffset;
 INC_IP(1);  
   
 lp-     ( -- )  new     minus_four_lp_plus_store  lp-     ( -- )  new     minus_four_lp_plus_store
 lp += -sizeof(Cell);  lp += -sizeof(Cell);
Line 2124  r = fp[u+1]; /* +1, because update of fp Line 2100  r = fp[u+1]; /* +1, because update of fp
   
 \+OS  \+OS
   
   \g syslib
   
 define(`uploop',  define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')         `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
 define(`_uploop',  define(`_uploop',
Line 2196  UP=up=(char *)a_addr; Line 2174  UP=up=(char *)a_addr;
 Variable UP  Variable UP
   
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_FTOS(fp[0]=FTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);  sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;  fp=FP;
 IF_TOS(TOS=sp[0];)  IF_spTOS(spTOS=sp[0];)
 IF_FTOS(FTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+file  \+file
   
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  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));  wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
 wior =  IOR(wdirid == 0);  wior =  IOR(wdirid == 0);
   
 read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir  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;  struct dirent * dent;
 dent = readdir((DIR *)wdirid);  dent = readdir((DIR *)wdirid);
 wior = 0;  wior = 0;
Line 2219  if(dent == NULL) { Line 2210  if(dent == NULL) {
   flag = 0;    flag = 0;
 } else {  } else {
   u2 = strlen(dent->d_name);    u2 = strlen(dent->d_name);
   if(u2 > u1)    if(u2 > u1) {
     u2 = u1;      u2 = u1;
       wior = -512-ENAMETOOLONG;
     }
   memmove(c_addr, dent->d_name, u2);    memmove(c_addr, dent->d_name, u2);
 }  }
   
 close-dir       ( wdirid -- wior )      gforth  close_dir  close-dir       ( wdirid -- wior )      gforth  close_dir
   ""Close the directory specified by @i{dir-id}.""
 wior = IOR(closedir((DIR *)wdirid));  wior = IOR(closedir((DIR *)wdirid));
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file
Line 2237  flag = FLAG(!fnmatch(pattern, string, 0) Line 2231  flag = FLAG(!fnmatch(pattern, string, 0)
 newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
 ""String containing the newline sequence of the host OS""  ""String containing the newline sequence of the host OS""
 char newline[] = {  char newline[] = {
 #ifdef unix  #if defined(unix) || defined(__MACH__)
   /* Darwin/MacOS X sets __MACH__, but not unix. */
 '\n'  '\n'
 #else  #else
 '\r','\n'  '\r','\n'
Line 2338  for(u2=0; u2<u1; u2++) Line 2333  for(u2=0; u2<u1; u2++)
 wior=FILEIO(ferror((FILE *)wfileid));  wior=FILEIO(ferror((FILE *)wfileid));
   
 \+  \+
   
   (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
   for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
     if ((UCell)LONGNAME_COUNT(longname1)==u &&
         memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
       break;
   longname2=longname1;
   :
       BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
           >r 2dup r@ cell+ cell+ capscomp  0=
           IF  2drop r>  EXIT  THEN
           r> @
       REPEAT  THEN  nip nip ;
   : (findl-samelen) ( u longname1 -- u longname2/0 )
       BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
   
   \+hash
   
   (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind
   struct Longname *longname1;
   longname2=NULL;
   while(a_addr != NULL)
   {
      longname1=(struct Longname *)(a_addr[1]);
      a_addr=(Cell *)(a_addr[0]);
      if ((UCell)LONGNAME_COUNT(longname1)==u &&
          memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
        {
           longname2=longname1;
           break;
        }
   }
   :
    BEGIN  dup  WHILE
           2@ >r >r dup r@ cell+ @ lcount-mask and =
           IF  2dup r@ cell+ cell+ capscomp 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
   (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind
   ""A case-sensitive variant of @code{(hashfind)}""
   struct Longname *longname1;
   longname2=NULL;
   while(a_addr != NULL)
   {
      longname1=(struct Longname *)(a_addr[1]);
      a_addr=(Cell *)(a_addr[0]);
      if ((UCell)LONGNAME_COUNT(longname1)==u &&
          memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)
        {
           longname2=longname1;
           break;
        }
   }
   :
    BEGIN  dup  WHILE
           2@ >r >r dup r@ cell+ @ lcount-mask and =
           IF  2dup r@ cell+ cell+ -text 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
   \+
   
   \+peephole
   
   \g peephole
   
   primtable       ( -- wprimtable )       new
   ""wprimtable is a table containing the xts of the primitives indexed
   by sequence-number in prim (for use in prepare-peephole-table).""
   wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);
   
   prepare-peephole-table  ( wprimtable -- wpeeptable ) new prepare_peephole_opt
   ""wpeeptable is a data structure used by @code{peephole-opt}; it is
   constructed by combining a primitives table with a simple peephole
   optimization table.""
   wpeeptable = prepare_peephole_table((Xt *)wprimtable);
   
   peephole-opt    ( xt1 xt2 wpeeptable -- xt )    new     peephole_opt
   ""xt is the combination of xt1 and xt2 (according to wpeeptable); if
   they cannot be combined, xt is 0.""
   xt = peephole_opt(xt1, xt2, wpeeptable);
   
   call    ( #a_callee -- R:a_retaddr )    new
   ""Call callee (a variant of docol with inline argument).""
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_callee);
   #else
   #ifdef DEBUG
       {
         CFA_TO_NAME((((Cell *)a_callee)-2));
         fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
                 len,name);
       }
   #endif
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)a_callee);
   #endif
   
   useraddr        ( #u -- a_addr )        new
   a_addr = (Cell *)(up+u);
   
   compile-prim ( xt1 -- xt2 )     obsolete        compile_prim
   xt2 = (Xt)compile_prim((Label)xt1);
   
   \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
   lit-perform     ( #a_addr -- )  new     lit_perform
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   EXEC(*(Xt *)a_addr);
   
   \ lit+ / lit_plus = lit +
   
   lit+    ( n1 #n2 -- n )         new     lit_plus
   n=n1+n2;
   
   does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
   #ifdef NO_IP
   /* compiled to LIT CALL by compile_prim */
   assert(0);
   #else
   a_pfa = PFA(a_cfa);
   nest = (Cell)IP;
   IF_spTOS(spTOS = sp[0]);
   #ifdef DEBUG
       {
         CFA_TO_NAME(a_cfa);
         fprintf(stderr,"%08lx: does %08lx %.*s\n",
                 (Cell)ip,(Cell)a_cfa,len,name);
       }
   #endif
   SET_IP(DOES_CODE1(a_cfa));
   #endif
   
   abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number
   /* this will probably not be used */
   lp += nlocals;
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   
   \+
   
   abranch ( #a_target -- )        gforth
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   :
    r> @ >r ;
   
   \ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)
   \ this is non-syntactical: code must open a brace that is closed by the macro
   define(acondbranch,
   $1 ( `#'a_target $2 ) $3
   $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   $6
   
   \+glocals
   
   $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
   $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   
   \+
   )
   
   acondbranch(a?branch,f --,f83   aquestion_branch,
   ,if (f==0) {
   ,:
    0= dup     \ !f !f \ !! still uses relative addresses
    r> dup @   \ !f !f IP branchoffset
    rot and +  \ !f IP|IP+branchoffset
    swap 0= cell and + \ IP''
    >r ;)
   
   \ we don't need an lp_plus_store version of the ?dup-stuff, because it
   \ is only used in if's (yet)
   
   \+xconds
   
   a?dup-?branch   ( #a_target f -- f )    new     aquestion_dupe_question_branch
   ""The run-time procedure compiled by @code{?DUP-IF}.""
   if (f==0) {
     sp++;
     IF_spTOS(spTOS = sp[0]);
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   
   a?dup-0=-?branch ( #a_target f -- ) new aquestion_dupe_zero_equals_question_branch
   ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
   /* the approach taken here of declaring the word as having the stack
   effect ( f -- ) and correcting for it in the branch-taken case costs a
   few cycles in that case, but is easy to convert to a CONDBRANCH
   invocation */
   if (f!=0) {
     sp--;
   #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
     NEXT;
   #endif
   }
   SUPER_CONTINUE;
   
   \+
   \f[THEN]
   \fhas? skiploopprims 0= [IF]
   
   acondbranch(a(next),R:n1 -- R:n2,cmFORTH        aparen_next,
   n2=n1-1;
   ,if (n1) {
   ,:
    r> r> dup 1- >r
    IF @ >r ELSE cell+ >r THEN ;)
   
   acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth       aparen_loop,
   n2=n1+1;
   ,if (n2 != nlimit) {
   ,:
    r> r> 1+ r> 2dup =
    IF >r 1- >r cell+ >r
    ELSE >r >r @ >r THEN ;)
   
   acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,
   /* !! check this thoroughly */
   /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
   /* dependent upon two's complement arithmetic */
   Cell olddiff = n1-nlimit;
   n2=n1+n;        
   ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
       || (olddiff^n)>=0          /* it is a wrap-around effect */) {
   ,:
    r> swap
    r> r> 2dup - >r
    2 pick r@ + r@ xor 0< 0=
    3 pick r> xor 0< 0= or
    IF    >r + >r @ >r
    ELSE  >r >r drop cell+ >r THEN ;)
   
   \+xconds
   
   acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,
   UCell olddiff = n1-nlimit;
   n2=n1-u;
   ,if (olddiff>u) {
   ,)
   
   acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth   aparen_symmetric_plus_loop,
   ""The run-time procedure compiled by S+LOOP. It loops until the index
   crosses the boundary between limit and limit-sign(n). I.e. a symmetric
   version of (+LOOP).""
   /* !! check this thoroughly */
   Cell diff = n1-nlimit;
   Cell newdiff = diff+n;
   if (n<0) {
       diff = -diff;
       newdiff = -newdiff;
   }
   n2=n1+n;
   ,if (diff>=0 || newdiff<0) {
   ,)
   
   a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth  aparen_question_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
   if (nstart == nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
       INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   :
     2dup =
     IF   r> swap rot >r >r
          @ >r
     ELSE r> swap rot >r >r
          cell+ >r
     THEN ;                                \ --> CORE-EXT
   
   \+xconds
   
   a(+do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
   if (nstart >= nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
       SET_IP((Xt *)a_target);
       INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   :
    swap 2dup
    r> swap >r swap >r
    >=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
   if (ustart >= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   :
    swap 2dup
    r> swap >r swap >r
    u>=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   a(-do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
   if (nstart <= nlimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   :
    swap 2dup
    r> swap >r swap >r
    <=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
   if (ustart <= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   :
    swap 2dup
    r> swap >r swap >r
    u<=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   \ set-next-code and call2 do not appear in images and can be
   \ renumbered arbitrarily
   
   set-next-code ( #w -- ) gforth set_next_code
   #ifdef NO_IP
   next_code = (Label)w;
   #endif
   
   call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
   /* call with explicit return address */
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_callee);
   #else
   assert(0);
   #endif
   
   compile-prim1 ( a_prim -- ) gforth compile_prim1
   ""compile prim (incl. immargs) at @var{a_prim}""
   compile_prim1(a_prim);
   
   finish-code ( -- ) gforth finish_code
   ""Perform delayed steps in code generation (branch resolution, I-cache
   flushing).""
   finish_code();
   
   forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
   f = forget_dyncode(c_code);
   
   decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
   ""a_prim is the code address of the primitive that has been
   compile_prim1ed to a_code""
   a_prim = decompile_code(a_code);
   
   \+
   
   include(peeprules.vmg)
   
   \g end
   
   \+

Removed from v.1.63  
changed lines
  Added in v.1.110


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