Diff for /gforth/prim between versions 1.51 and 1.69

version 1.51, 2000/08/08 12:37:05 version 1.69, 2001/01/09 16:11:35
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 Line 16
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
Line 74 Line 74
 \ xt.*          XT  \ xt.*          XT
 \ wid.*         WID  \ wid.*         WID
 \ f83name.*     F83Name *  \ f83name.*     F83Name *
   
   \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" WID"              single data-stack type-prefix wid
   \E s" struct F83Name *" single data-stack type-prefix f83name
   \E 
   \E return-stack stack-prefix R:
   \E inst-stream  stack-prefix #
   \E 
   \E set-current
   
 \   \ 
 \   \ 
 \   \ 
Line 104  undefine(`index') Line 129  undefine(`index')
 undefine(`shift')  undefine(`shift')
   
 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}.""
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""Equivalent to @code{@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
Line 132  EXEC(*(Xt *)a_addr); Line 154  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;  TAIL;
 }  }
 else  $5
     INC_IP(1);  
 $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));
   TAIL;
 }  }
 else  
     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 200  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;    TAIL;
 }  }
 else  
   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 217  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  
   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 258  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;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
 :  :
   2dup =    2dup =
Line 327  else { Line 311  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;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
 :  :
  swap 2dup   swap 2dup
Line 347  else { Line 326  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;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
 :  :
  swap 2dup   swap 2dup
Line 367  else { Line 341  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;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
 :  :
  swap 2dup   swap 2dup
Line 387  else { Line 356  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;      TAIL;
     }  
 else {  
     INC_IP(1);  
 }  }
 :  :
  swap 2dup   swap 2dup
Line 412  else { Line 376  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 445  n = rp[4]; Line 404  n = rp[4];
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 move    ( c_from c_to ucount -- )               core  move    ( c_from c_to ucount -- )               core
 ""Copy the contents of @i{ucount} address units 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.""
   /* !! note that the standard specifies addr, not c-addr */
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
 /* make an Ifdef for bsd and others? */  /* make an Ifdef for bsd and others? */
 :  :
Line 475  while (u-- > 0) Line 435  while (u-- > 0)
  DO  1- dup c@ I c!  -1 +LOOP  drop ;   DO  1- dup c@ I c!  -1 +LOOP  drop ;
   
 fill    ( c_addr u c -- )       core  fill    ( c_addr u c -- )       core
 "" If @i{u}>0, store character @i{c} in each of @i{u} consecutive  ""Store @i{c} in @i{u} chars starting at @i{c-addr}.""
 @code{char} addresses in memory, starting at address @i{c-addr}.""  
 memset(c_addr,c,u);  memset(c_addr,c,u);
 :  :
  -rot bounds   -rot bounds
Line 600  else Line 559  else
 :  :
  2dup > IF swap THEN drop ;   2dup > IF swap THEN drop ;
   
 abs     ( n1 -- n2 )    core  abs     ( n -- u )      core
 if (n1<0)  if (n<0)
   n2 = -n1;    u = -n;
 else  else
   n2 = n1;    u = n;
 :  :
  dup 0< IF negate THEN ;   dup 0< IF negate THEN ;
   
Line 630  n3 = n1%n2; /* !! is this correct? look Line 589  n3 = n1%n2; /* !! is this correct? look
  >r s>d r> fm/mod ;   >r s>d r> fm/mod ;
   
 2*      ( n1 -- n2 )            core            two_star  2*      ( n1 -- n2 )            core            two_star
   ""Shift left by 1; also works on unsigned numbers""
 n2 = 2*n1;  n2 = 2*n1;
 :  :
  dup + ;   dup + ;
   
 2/      ( n1 -- n2 )            core            two_slash  2/      ( n1 -- n2 )            core            two_slash
 /* !! is this still correct? */  ""Arithmetic shift right by 1.  For signed numbers this is a floored
   division by 2 (note that @code{/} not necessarily floors).""
 n2 = n1>>1;  n2 = n1>>1;
 :  :
  dup MINI and IF 1 ELSE 0 THEN   dup MINI and IF 1 ELSE 0 THEN
Line 777  d2 = -d1; Line 738  d2 = -d1;
  invert swap negate tuck 0= - ;   invert swap negate tuck 0= - ;
   
 d2*     ( d1 -- d2 )            double          d_two_star  d2*     ( d1 -- d2 )            double          d_two_star
   ""Shift left by 1; also works on unsigned numbers""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d2.lo = d1.lo<<1;  d2.lo = d1.lo<<1;
 d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));  d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
Line 787  d2 = 2*d1; Line 749  d2 = 2*d1;
  2dup d+ ;   2dup d+ ;
   
 d2/     ( d1 -- d2 )            double          d_two_slash  d2/     ( d1 -- d2 )            double          d_two_slash
   ""Arithmetic shift right by 1.  For signed numbers this is a floored
   division by 2.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d2.hi = d1.hi>>1;  d2.hi = d1.hi>>1;
 d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));  d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
Line 814  w2 = ~w1; Line 778  w2 = ~w1;
  MAXU xor ;   MAXU xor ;
   
 rshift  ( u1 n -- u2 )          core    r_shift  rshift  ( u1 n -- u2 )          core    r_shift
   ""Logical shift right by @i{n} bits.""
   u2 = u1>>n;    u2 = u1>>n;
 :  :
     0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
Line 939  about this word is to consider the numbe Line 904  about this word is to consider the numbe
 around from @code{max-u} to 0 for unsigned, and from @code{max-n} to  around from @code{max-u} to 0 for unsigned, and from @code{max-n} to
 min-n for signed numbers); now consider the range from u2 towards  min-n for signed numbers); now consider the range from u2 towards
 increasing numbers up to and excluding u3 (giving an empty range if  increasing numbers up to and excluding u3 (giving an empty range if
 u2=u3; if u1 is in this range, @code{within} returns true.""  u2=u3); if u1 is in this range, @code{within} returns true.""
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
Line 949  a_addr = sp+1; Line 914  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 967  fp = f_addr; Line 932  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++));  SET_IP((Xt *)w);
   
 >r      ( w -- )                core    to_r  >r      ( w -- R:w )            core    to_r
 *--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
 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
 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
 *--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
 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
 w2 = rp[0];  
 w1 = rp[1];  
 :  :
  i' j ;   i' j ;
   
 2rdrop  ( -- )          gforth  two_r_drop  2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop
 rp+=2;  
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1050  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1005  tuck ( w1 w2 -- w2 w1 w2 ) core-ext
  swap over ;   swap over ;
   
 ?dup    ( w -- w )                      core    question_dupe  ?dup    ( w -- w )                      core    question_dupe
   ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
   @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 1060  if (w!=0) { Line 1017  if (w!=0) {
  dup IF dup THEN ;   dup IF dup THEN ;
   
 pick    ( u -- w )                      core-ext  pick    ( u -- w )                      core-ext
   ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
 w = sp[u+1];  w = sp[u+1];
 :  :
  1+ cells sp@ + @ ;   1+ cells sp@ + @ ;
Line 1095  w = sp[u+1]; Line 1053  w = sp[u+1];
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
 @       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
 "" Read from the cell at address @i{a-addr}, and return its contents, @i{w}.""  ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
   
 !       ( w a_addr -- )         core    store  !       ( w a_addr -- )         core    store
 "" Write the value @i{w} to the cell at address @i{a-addr}.""  ""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;  *a_addr = w;
   
 +!      ( n a_addr -- )         core    plus_store  +!      ( n a_addr -- )         core    plus_store
 "" Add @i{n} to the value stored in the cell at address @i{a-addr}.""  ""Add @i{n} to the cell at @i{a-addr}.""
 *a_addr += n;  *a_addr += n;
 :  :
  tuck @ + swap ! ;   tuck @ + swap ! ;
   
 c@      ( c_addr -- c )         core    c_fetch  c@      ( c_addr -- c )         core    c_fetch
 "" Read from the char at address @i{c-addr}, and return its contents, @i{c}.""  ""@i{c} is the char stored at @i{c_addr}.""
 c = *c_addr;  c = *c_addr;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1135  c = *c_addr; Line 1093  c = *c_addr;
 : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;  : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
   
 c!      ( c c_addr -- )         core    c_store  c!      ( c c_addr -- )         core    c_store
 "" Write the value @i{c} to the char at address @i{c-addr}.""  ""Store @i{c} into the char at @i{c-addr}.""
 *c_addr = c;  *c_addr = c;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1165  c! ( c c_addr -- )  core c_store Line 1123  c! ( c c_addr -- )  core c_store
 : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;  : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;
   
 2!      ( w1 w2 a_addr -- )             core    two_store  2!      ( w1 w2 a_addr -- )             core    two_store
 "" Write the value @i{w1, w2} to the double at address @i{a-addr}.""  ""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell.""
 a_addr[0] = w2;  a_addr[0] = w2;
 a_addr[1] = w1;  a_addr[1] = w1;
 :  :
  tuck ! cell+ ! ;   tuck ! cell+ ! ;
   
 2@      ( a_addr -- w1 w2 )             core    two_fetch  2@      ( a_addr -- w1 w2 )             core    two_fetch
 "" Read from the double at address @i{a-addr}, and return its contents, @i{w1, w2}.""  ""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is
   the content of the next cell.""
 w2 = a_addr[0];  w2 = a_addr[0];
 w1 = a_addr[1];  w1 = a_addr[1];
 :  :
  dup cell+ @ swap @ ;   dup cell+ @ swap @ ;
   
 cell+   ( a_addr1 -- a_addr2 )  core    cell_plus  cell+   ( a_addr1 -- a_addr2 )  core    cell_plus
 "" Increment @i{a-addr1} by the number of address units corresponding to the size of  ""@code{1 cells +}""
 one cell, to give @i{a-addr2}.""  
 a_addr2 = a_addr1+1;  a_addr2 = a_addr1+1;
 :  :
  cell + ;   cell + ;
   
 cells   ( n1 -- n2 )            core  cells   ( n1 -- n2 )            core
 "" @i{n2} is the number of address units corresponding to @i{n1} cells.""  "" @i{n2} is the number of address units of @i{n1} cells.""
 n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
 :  :
  [ cell   [ cell
Line 1197  n2 = n1 * sizeof(Cell); Line 1155  n2 = n1 * sizeof(Cell);
  drop ] ;   drop ] ;
   
 char+   ( c_addr1 -- c_addr2 )  core    char_plus  char+   ( c_addr1 -- c_addr2 )  core    char_plus
 "" Increment @i{c-addr1} by the number of address units corresponding to the size of  ""@code{1 chars +}.""
 one char, to give @i{c-addr2}.""  
 c_addr2 = c_addr1 + 1;  c_addr2 = c_addr1 + 1;
 :  :
  1+ ;   1+ ;
Line 1209  n2 = n1 * sizeof(Char); Line 1166  n2 = n1 * sizeof(Char);
  ;   ;
   
 count   ( c_addr1 -- c_addr2 u )        core  count   ( c_addr1 -- c_addr2 u )        core
 "" If @i{c-add1} is the address of a counted string return the length of  ""@i{c-addr2} is the first character and @i{u} the length of the
 the string, @i{u}, and the address of its first character, @i{c-addr2}.""  counted string at @i{c-addr1}.""
 u = *c_addr1;  u = *c_addr1;
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
 :  :
Line 1364  c_addr = (Address)CODE_ADDRESS(xt); Line 1321  c_addr = (Address)CODE_ADDRESS(xt);
     @ ;      @ ;
   
 >does-code      ( xt -- a_addr )                gforth  to_does_code  >does-code      ( xt -- a_addr )                gforth  to_does_code
 ""If @i{xt} is the execution token of a defining-word-defined word,  ""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>};  @i{a-addr} is the start of the Forth code after the @code{DOES>};
 Otherwise @i{a-addr} is 0.""  Otherwise @i{a-addr} is 0.""
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
Line 1379  CACHE_FLUSH(xt,(size_t)PFA(0)); Line 1336  CACHE_FLUSH(xt,(size_t)PFA(0));
     ! ;      ! ;
   
 does-code!      ( a_addr xt -- )                gforth  does_code_store  does-code!      ( a_addr xt -- )                gforth  does_code_store
 ""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}  ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
 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));  CACHE_FLUSH(xt,(size_t)PFA(0));
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
 does-handler!   ( a_addr -- )   gforth  does_handler_store  does-handler!   ( a_addr -- )   gforth  does_handler_store
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points  ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 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);  CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :  :
Line 1489  in length."" Line 1446  in length.""
 c_addr2 = getenv(cstr(c_addr1,u1,1));  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 ntype -- 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[ntype]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[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 1526  allocate ( u -- a_addr wior ) memory Line 1483  allocate ( u -- a_addr wior ) memory
 contents of the data space is undefined. If the allocation is successful,  contents of the data space is undefined. If the allocation is successful,
 @i{a-addr} is the start address of the allocated region and @i{wior}  @i{a-addr} is the start address of the allocated region and @i{wior}
 is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}  is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
 is an implementation-defined I/O result code.""  is a non-zero I/O result code.""
 a_addr = (Cell *)malloc(u?u:1);  a_addr = (Cell *)malloc(u?u:1);
 wior = IOR(a_addr==NULL);  wior = IOR(a_addr==NULL);
   
 free    ( a_addr -- wior )              memory  free    ( a_addr -- wior )              memory
 ""Return the region of data space starting at @i{a-addr} to the system.  ""Return the region of data space starting at @i{a-addr} to the system.
 The regon must originally have been obtained using @code{allocate} or  The region must originally have been obtained using @code{allocate} or
 @code{resize}. If the operational is successful, @i{wior} is 0.  @code{resize}. If the operational is successful, @i{wior} is 0.
 If the operation fails, @i{wior} is an implementation-defined  If the operation fails, @i{wior} is a non-zero I/O result code.""
 I/O result code.""  
 free(a_addr);  free(a_addr);
 wior = 0;  wior = 0;
   
Line 1543  resize ( a_addr1 u -- a_addr2 wior ) mem Line 1499  resize ( a_addr1 u -- a_addr2 wior ) mem
 ""Change the size of the allocated area at @i{a-addr1} to @i{u}  ""Change the size of the allocated area at @i{a-addr1} to @i{u}
 address units, possibly moving the contents to a different  address units, possibly moving the contents to a different
 area. @i{a-addr2} is the address of the resulting area.  area. @i{a-addr2} is the address of the resulting area.
 If the operational is successful, @i{wior} is 0.  If the operation is successful, @i{wior} is 0.
 If the operation fails, @i{wior} is an implementation-defined  If the operation fails, @i{wior} is a non-zero
 I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)  I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)
 @code{resize} @code{allocate}s @i{u} address units.""  @code{resize} @code{allocate}s @i{u} address units.""
 /* the following check is not necessary on most OSs, but it is needed  /* the following check is not necessary on most OSs, but it is needed
Line 1570  access the stack itself. The stack point Line 1526  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 1585  IF_FTOS(FTOS=fp[0]); Line 1541  IF_FTOS(FTOS=fp[0]);
 close-file      ( wfileid -- wior )             file    close_file  close-file      ( wfileid -- wior )             file    close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
   
 open-file       ( c_addr u ntype -- wfileid wior )      file    open_file  open-file       ( c_addr u wfam -- wfileid wior )       file    open_file
 wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
 wior =  IOR(wfileid == 0);  wior =  IOR(wfileid == 0);
   
 create-file     ( c_addr u ntype -- wfileid wior )      file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
 Cell    fd;  Cell    fd;
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);  fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
 if (fd != -1) {  if (fd != -1) {
   wfileid = (Cell)fdopen(fd, fileattr[ntype]);    wfileid = (Cell)fdopen(fd, fileattr[wfam]);
   wior = IOR(wfileid == 0);    wior = IOR(wfileid == 0);
 } else {  } else {
   wfileid = 0;    wfileid = 0;
Line 1633  if (wior) Line 1589  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
 #if 1  ""this is only for backward compatibility""
 Cell c;  Cell c;
 flag=-1;  flag=-1;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
Line 1652  for(u2=0; u2<u1; u2++) Line 1608  for(u2=0; u2<u1; u2++)
    c_addr[u2] = (Char)c;     c_addr[u2] = (Char)c;
 }  }
 wior=FILEIO(ferror((FILE *)wfileid));  wior=FILEIO(ferror((FILE *)wfileid));
 #else  
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {  
   wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */  
   if (wior)  
     clearerr((FILE *)wfileid);  
   u2 = strlen(c_addr);  
   u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));  
 }  
 else {  
   wior=0;  
   u2=0;  
 }  
 #endif  
   
 \+  \+
   
Line 1696  PUTC(c); Line 1638  PUTC(c);
 flush-file      ( wfileid -- wior )             file-ext        flush_file  flush-file      ( wfileid -- wior )             file-ext        flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 file-status     ( c_addr u -- ntype wior )      file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
 char *filename=tilde_cstr(c_addr, u, 1);  char *filename=tilde_cstr(c_addr, u, 1);
 if (access (filename, F_OK) != 0) {  if (access (filename, F_OK) != 0) {
   ntype=0;    wfam=0;
   wior=IOR(1);    wior=IOR(1);
 }  }
 else if (access (filename, R_OK | W_OK) == 0) {  else if (access (filename, R_OK | W_OK) == 0) {
   ntype=2; /* r/w */    wfam=2; /* r/w */
   wior=0;    wior=0;
 }  }
 else if (access (filename, R_OK) == 0) {  else if (access (filename, R_OK) == 0) {
   ntype=0; /* r/o */    wfam=0; /* r/o */
   wior=0;    wior=0;
 }  }
 else if (access (filename, W_OK) == 0) {  else if (access (filename, W_OK) == 0) {
   ntype=4; /* w/o */    wfam=4; /* w/o */
   wior=0;    wior=0;
 }  }
 else {  else {
   ntype=1; /* well, we cannot access the file, but better deliver a legal    wfam=1; /* well, we cannot access the file, but better deliver a legal
             access mode (r/o bin), so we get a decent error later upon open. */              access mode (r/o bin), so we get a decent error later upon open. */
   wior=0;    wior=0;
 }  }
Line 1743  d = r; Line 1685  d = r;
 #endif  #endif
   
 f!      ( r f_addr -- ) float   f_store  f!      ( r f_addr -- ) float   f_store
 "" Store the floating-point value @i{r} to address @i{f-addr}.""  ""Store @i{r} into the float at address @i{f-addr}.""
 *f_addr = r;  *f_addr = r;
   
 f@      ( f_addr -- r ) float   f_fetch  f@      ( f_addr -- r ) float   f_fetch
 "" Fetch floating-point value @i{r} from address @i{f-addr}.""  ""@i{r} is the float at address @i{f-addr}.""
 r = *f_addr;  r = *f_addr;
   
 df@     ( df_addr -- r )        float-ext       d_f_fetch  df@     ( df_addr -- r )        float-ext       d_f_fetch
 "" Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""  ""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *df_addr;  r = *df_addr;
 #else  #else
Line 1759  r = *df_addr; Line 1701  r = *df_addr;
 #endif  #endif
   
 df!     ( r df_addr -- )        float-ext       d_f_store  df!     ( r df_addr -- )        float-ext       d_f_store
 "" Store the double-precision IEEE floating-point value @i{r} to the address @i{df-addr}.""  ""Store @i{r} as double-precision IEEE floating-point value to the
   address @i{df-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *df_addr = r;  *df_addr = r;
 #else  #else
Line 1767  df! ( r df_addr -- ) float-ext d_f_store Line 1710  df! ( r df_addr -- ) float-ext d_f_store
 #endif  #endif
   
 sf@     ( sf_addr -- r )        float-ext       s_f_fetch  sf@     ( sf_addr -- r )        float-ext       s_f_fetch
 "" Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""  ""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *sf_addr;  r = *sf_addr;
 #else  #else
Line 1775  r = *sf_addr; Line 1718  r = *sf_addr;
 #endif  #endif
   
 sf!     ( r sf_addr -- )        float-ext       s_f_store  sf!     ( r sf_addr -- )        float-ext       s_f_store
 "" Store the single-precision IEEE floating-point value @i{r} to the address @i{sf-addr}.""  ""Store @i{r} as single-precision IEEE floating-point value to the
   address @i{sf-addr}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *sf_addr = r;  *sf_addr = r;
 #else  #else
Line 1816  fnip ( r1 r2 -- r2 ) gforth f_nip Line 1760  fnip ( r1 r2 -- r2 ) gforth f_nip
 ftuck   ( r1 r2 -- r2 r1 r2 )   gforth  f_tuck  ftuck   ( r1 r2 -- r2 r1 r2 )   gforth  f_tuck
   
 float+  ( f_addr1 -- f_addr2 )  float   float_plus  float+  ( f_addr1 -- f_addr2 )  float   float_plus
 "" Increment @i{f-addr1} by the number of address units corresponding to the size of  ""@code{1 floats +}.""
 one floating-point number, to give @i{f-addr2}.""  
 f_addr2 = f_addr1+1;  f_addr2 = f_addr1+1;
   
 floats  ( n1 -- n2 )    float  floats  ( n1 -- n2 )    float
 ""@i{n2} is the number of address units corresponding to @i{n1} floating-point numbers.""  ""@i{n2} is the number of address units of @i{n1} floats.""
 n2 = n1*sizeof(Float);  n2 = n1*sizeof(Float);
   
 floor   ( r1 -- r2 )    float  floor   ( r1 -- r2 )    float
Line 1862  f2=FLAG(isdigit((unsigned)(sig[0]))!=0); Line 1805  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);  memmove(c_addr,sig,u);
   
 >float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- flag )    float   to_float
 ""Attempt to convert the character string @i{c-addr u} to  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
 internal floating-point representation. If the string  character string @i{c-addr u} to internal floating-point
 represents a valid floating-point number @i{r} is placed  representation. If the string represents a valid floating-point number
 on the floating-point stack and @i{flag} is true. Otherwise,  @i{r} is placed on the floating-point stack and @i{flag} is
 @i{flag} is false. A string of blanks is a special case  true. Otherwise, @i{flag} is false. A string of blanks is a special
 and represents the floating-point number 0.""  case and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  char *number=cstr(c_addr, u, 1);
Line 1891  number[u]='\0'; Line 1834  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 1901  else if(*endconv=='d' || *endconv=='D') Line 1844  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 2016  r2 = atanh(r1); Line 1959  r2 = atanh(r1);
  r> IF  fnegate  THEN ;   r> IF  fnegate  THEN ;
   
 sfloats ( n1 -- n2 )    float-ext       s_floats  sfloats ( n1 -- n2 )    float-ext       s_floats
 ""@i{n2} is the number of address units corresponding to @i{n1}  ""@i{n2} is the number of address units of @i{n1}
 single-precision IEEE floating-point numbers.""  single-precision IEEE floating-point numbers.""
 n2 = n1*sizeof(SFloat);  n2 = n1*sizeof(SFloat);
   
 dfloats ( n1 -- n2 )    float-ext       d_floats  dfloats ( n1 -- n2 )    float-ext       d_floats
 ""@i{n2} is the number of address units corresponding to @i{n1}  ""@i{n2} is the number of address units of @i{n1}
 double-precision IEEE floating-point numbers.""  double-precision IEEE floating-point numbers.""
 n2 = n1*sizeof(DFloat);  n2 = n1*sizeof(DFloat);
   
 sfaligned       ( c_addr -- sf_addr )   float-ext       s_f_aligned  sfaligned       ( c_addr -- sf_addr )   float-ext       s_f_aligned
 "" @i{sf-addr} is the first single-float-aligned address greater  ""@i{sf-addr} is the first single-float-aligned address greater
 than or equal to @i{c-addr}.""  than or equal to @i{c-addr}.""
 sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));  sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
 :  :
  [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;   [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
   
 dfaligned       ( c_addr -- df_addr )   float-ext       d_f_aligned  dfaligned       ( c_addr -- df_addr )   float-ext       d_f_aligned
 "" @i{df-addr} is the first double-float-aligned address greater  ""@i{df-addr} is the first double-float-aligned address greater
 than or equal to @i{c-addr}.""  than or equal to @i{c-addr}.""
 df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));  df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
 :  :
Line 2048  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 1991  df_addr = (DFloat *)((((Cell)c_addr)+(si
 \+  \+
 \+glocals  \+glocals
   
 @local# ( -- w )        gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+noffset);
 INC_IP(1);  
   
 @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 2066  w = *(Cell *)(lp+3*sizeof(Cell)); Line 2008  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 2078  r = *(Float *)(lp+1*sizeof(Float)); Line 2019  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 2113  lp -= sizeof(Float); Line 2052  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 fpick   ( u -- r )              gforth  fpick   ( u -- r )              gforth
   ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
 r = fp[u+1]; /* +1, because update of fp happens before this fragment */  r = fp[u+1]; /* +1, because update of fp happens before this fragment */
 :  :
  floats fp@ + f@ ;   floats fp@ + f@ ;
Line 2194  UP=up=(char *)a_addr; Line 2134  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=(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
   
Line 2235  flag = FLAG(!fnmatch(pattern, string, 0) Line 2175  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 2245  c_addr=newline; Line 2186  c_addr=newline;
 u=sizeof(newline);  u=sizeof(newline);
 :  :
  "newline count ;   "newline count ;
 Create "newline 1 c, $0A c,  Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
   
   \+os
   
 utime   ( -- dtime )    gforth  utime   ( -- dtime )    gforth
 ""Report the current time in microseconds since some epoch.""  ""Report the current time in microseconds since some epoch.""
Line 2268  dsystem = timeval2us(&usage.ru_stime); Line 2211  dsystem = timeval2us(&usage.ru_stime);
 struct timeval time1;  struct timeval time1;
 gettimeofday(&time1,NULL);  gettimeofday(&time1,NULL);
 duser = timeval2us(&time1);  duser = timeval2us(&time1);
   #ifndef BUGGY_LONG_LONG
 dsystem = (DCell)0;  dsystem = (DCell)0;
   #else
   dsystem=(DCell){0,0};
 #endif  #endif
   #endif
   
   \+
   
   \+floating
   
 v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star  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  ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
Line 2280  for (r=0.; ucount>0; ucount--) { Line 2231  for (r=0.; ucount>0; ucount--) {
   f_addr1 = (Float *)(((Address)f_addr1)+nstride1);    f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
   f_addr2 = (Float *)(((Address)f_addr2)+nstride2);    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  faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
 ""vy=ra*vx+vy""  ""vy=ra*vx+vy""
Line 2288  for (; ucount>0; ucount--) { Line 2243  for (; ucount>0; ucount--) {
   f_x = (Float *)(((Address)f_x)+nstridex);    f_x = (Float *)(((Address)f_x)+nstridex);
   f_y = (Float *)(((Address)f_y)+nstridey);    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));
   
   \+

Removed from v.1.51  
changed lines
  Added in v.1.69


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