[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.1 and 1.39

version 1.1, Wed May 21 20:39:36 1997 UTC version 1.39, Sun Aug 29 21:44:46 1999 UTC
Line 1 
Line 1 
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 115 
Line 115 
  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}.""
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 EXEC(xt);  EXEC(xt);
   
 perform         a_addr --       gforth  perform         a_addr --       gforth
 ""equivalent to @code{@ execute}""  ""Equivalent to @code{@ execute}.""
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
Line 128 
Line 129 
 :  :
  @ execute ;   @ execute ;
   
 \+has-locals [IF]  \fhas? skipbranchprims 0= [IF]
   \+glocals
   
 branch-lp+!#    --      gforth  branch_lp_plus_store_number  branch-lp+!#    --      gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
Line 136 
Line 138 
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 \+[THEN]  \+
   
 branch  --              gforth  branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
 NEXT_P0;  
 :  :
  r> dup @ + >r ;   r> dup @ + >r ;
   
Line 149 
Line 150 
 \ 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      $2
 $3      ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
         NEXT_P0;  
         NEXT;          NEXT;
 }  }
 else  else
     INC_IP(1);      INC_IP(1);
 $4  $4
   
 \+has-locals [IF]  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    goto branch_adjust_lp;
Line 165 
Line 165 
 else  else
     INC_IP(2);      INC_IP(2);
   
 \+[THEN]  \+
 )  )
   
 condbranch(?branch,f --         f83     question_branch,  condbranch(?branch,f --         f83     question_branch,
 if (f==0) {  if (f==0) {
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 ,)  ,:
    0= dup     \ !f !f
    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  \ we don't need an lp_plus_store version of the ?dup-stuff, because it
 \ is only used in if's (yet)  \ is only used in if's (yet)
   
 \+has-xconds [IF]  \+xconds
   
 ?dup-?branch    f -- f  new     question_dupe_question_branch  ?dup-?branch    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_TOS(TOS = sp[0]);
   ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);    SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT_P0;  
   NEXT;    NEXT;
 }  }
 else  else
Line 198 
Line 202 
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);    SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT_P0;  
   NEXT;    NEXT;
 }  }
 else  else
   INC_IP(1);    INC_IP(1);
   
 \+[THEN]  \+
   \f[THEN]
   \fhas? skiploopprims 0= [IF]
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
Line 245 
Line 250 
  IF    >r + >r dup @ + >r   IF    >r + >r dup @ + >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+has-xconds [IF]  \+xconds
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 281 
Line 286 
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 ,)  ,)
   
 \+[THEN]  \+
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
Line 320 
Line 325 
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+has-xconds [IF]  \+xconds
   
 (+do)   nlimit nstart --        gforth  paren_plus_do  (+do)   nlimit nstart --        gforth  paren_plus_do
 *--rp = nlimit;  *--rp = nlimit;
Line 402 
Line 407 
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 \+[THEN]  \+
   
   \ don't make any assumptions where the return stack is!!
   \ implement this in machine code if it should run quickly!
   
 i       -- n            core  i       -- n            core
 n = *rp;  n = *rp;
 :  :
  rp@ cell+ @ ;  \ rp@ cell+ @ ;
     r> r> tuck >r >r ;
   
 i'      -- w            gforth          i_tick  i'      -- w            gforth          i_tick
 ""loop end value""  ""loop end value""
 w = rp[1];  w = rp[1];
 :  :
  rp@ cell+ cell+ @ ;  \ rp@ cell+ cell+ @ ;
     r> r> r> dup itmp ! >r >r >r itmp @ ;
   variable itmp
   
 j       -- n            core  j       -- n            core
 n = rp[2];  n = rp[2];
 :  :
  rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
     r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
   [IFUNDEF] itmp variable itmp [THEN]
   
 k       -- n            gforth  k       -- n            gforth
 n = rp[4];  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 @ ;
   [IFUNDEF] itmp variable itmp [THEN]
   
   \f[THEN]
   
 \ 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
   @i{c-to}. @code{move} works correctly even if the two areas overlap.""
 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? */
 :  :
  >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;   >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
   
 cmove   c_from c_to u --        string  cmove   c_from c_to u --        string
   ""Copy the contents of @i{ucount} characters from data space at
   @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
   from low address to high address; i.e., for overlapping areas it is
   safe if @i{c-to}=<@i{c-from}.""
 while (u-- > 0)  while (u-- > 0)
   *c_to++ = *c_from++;    *c_to++ = *c_from++;
 :  :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
 cmove>  c_from c_to u --        string  c_move_up  cmove>  c_from c_to u --        string  c_move_up
   ""Copy the contents of @i{ucount} characters from data space at
   @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
   from high address to low address; i.e., for overlapping areas it is
   safe if @i{c-to}>=@i{c-from}.""
 while (u-- > 0)  while (u-- > 0)
   c_to[u] = c_from[u];    c_to[u] = c_from[u];
 :  :
Line 448 
Line 475 
  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
   @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
  ?DO  dup I c!  LOOP  drop ;   ?DO  dup I c!  LOOP  drop ;
   
 compare         c_addr1 u1 c_addr2 u2 -- n      string  compare         c_addr1 u1 c_addr2 u2 -- n      string
 ""Compare the strings lexicographically. If they are equal, n is 0; if  ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
 the first string is smaller, n is -1; if the first string is larger, n  the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
 is 1. Currently this is based on the machine's character  is 1. Currently this is based on the machine's character
 comparison. In the future, this may change to considering the current  comparison. In the future, this may change to consider the current
 locale and its collation order.""  locale and its collation order.""
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
 if (n==0)  if (n==0)
Line 489 
Line 518 
  dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;   dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;
   
 toupper c1 -- c2        gforth  toupper c1 -- c2        gforth
   ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
   is the equivalent upper-case character. All other characters are unchanged.""
 c2 = toupper(c1);  c2 = toupper(c1);
 :  :
  dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;   dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
Line 507 
Line 538 
  ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;   ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;
   
 -trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       c_addr u1 -- c_addr u2          string  dash_trailing
   ""Adjust the string specified by @i{c-addr, u1} to remove all trailing
   spaces. @i{u2} is the length of the modified string.""
 u2 = u1;  u2 = u1;
 while (c_addr[u2-1] == ' ')  while (u2>0 && c_addr[u2-1] == ' ')
   u2--;    u2--;
 :  :
  BEGIN  1- 2dup + c@ bl =  WHILE   BEGIN  1- 2dup + c@ bl =  WHILE
         dup  0= UNTIL  ELSE  1+  THEN ;          dup  0= UNTIL  ELSE  1+  THEN ;
   
 /string         c_addr1 u1 n -- c_addr2 u2      string  slash_string  /string         c_addr1 u1 n -- c_addr2 u2      string  slash_string
   ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
   characters from the start of the string.""
 c_addr2 = c_addr1+n;  c_addr2 = c_addr1+n;
 u2 = u1-n;  u2 = u1-n;
 :  :
Line 525 
Line 560 
   
 \ PFE-0.9.14 has it differently, but the next release will have it as follows  \ PFE-0.9.14 has it differently, but the next release will have it as follows
 under+  n1 n2 n3 -- n n2        gforth  under_plus  under+  n1 n2 n3 -- n n2        gforth  under_plus
 ""add @var{n3} to @var{n1} (giving @var{n})""  ""add @i{n3} to @i{n1} (giving @i{n})""
 n = n1+n3;  n = n1+n3;
 :  :
  rot + swap ;   rot + swap ;
Line 607 
Line 642 
 :  :
  dup MINI and IF 1 ELSE 0 THEN   dup MINI and IF 1 ELSE 0 THEN
  [ bits/byte cell * 1- ] literal   [ bits/byte cell * 1- ] literal
  0 DO 2* swap dup 2* >r U-HIGHBIT and   0 DO 2* swap dup 2* >r MINI and
      IF 1 ELSE 0 THEN or r> swap       IF 1 ELSE 0 THEN or r> swap
  LOOP nip ;   LOOP nip ;
   
 fm/mod  d1 n1 -- n2 n3          core            f_m_slash_mod  fm/mod  d1 n1 -- n2 n3          core            f_m_slash_mod
 ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""  ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 DCell r = fmdiv(d1,n1);  DCell r = fmdiv(d1,n1);
 n2=r.hi;  n2=r.hi;
Line 634 
Line 669 
  r> 0< IF  swap negate swap  THEN ;   r> 0< IF  swap negate swap  THEN ;
   
 sm/rem  d1 n1 -- n2 n3          core            s_m_slash_rem  sm/rem  d1 n1 -- n2 n3          core            s_m_slash_rem
 ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""  ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 DCell r = smdiv(d1,n1);  DCell r = smdiv(d1,n1);
 n2=r.hi;  n2=r.hi;
Line 684 
Line 719 
    and >r >r 2dup d+ swap r> + swap r> ;     and >r >r 2dup d+ swap r> + swap r> ;
   
 um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
   ""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 UDCell r = umdiv(ud,u1);  UDCell r = umdiv(ud,u1);
 u2=r.hi;  u2=r.hi;
Line 694 
Line 730 
 #endif  #endif
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0
    ?DO >r /modstep r>     ?DO /modstep
    LOOP drop swap 1 rshift or swap ;     LOOP drop swap 1 rshift or swap ;
 : /modstep ( ud c R: u -- ud-?u c R: u )  : /modstep ( ud c R: u -- ud-?u c R: u )
    over I' u< 0= or IF I' - 1 ELSE 0 THEN  d2*+ ;     >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN  d2*+ r> ;
 : d2*+ ( ud n -- ud+n c )  : d2*+ ( ud n -- ud+n c )
    over MINI     over MINI
    and >r >r 2dup d+ swap r> + swap r> ;     and >r >r 2dup d+ swap r> + swap r> ;
Line 890 
Line 926 
   
 )  )
   
 \+has-dcomps [IF]  \+dcomps
   
 dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)  dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
 dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)  dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
 dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
   
 \+[THEN]  \+
   
 within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
   ""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2).  This works for
   unsigned and signed numbers (but not a mixture).  Another way to think
   about this word is to consider the numbers as a circle (wrapping
   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
   increasing numbers up to and excluding u3 (giving an empty range if
   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< ;
   
 sp@     -- a_addr               gforth          spat  sp@     -- a_addr               gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp+1;
   
 sp!     a_addr --               gforth          spstore  sp!     a_addr --               gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without TOS caching */
   
 rp@     -- a_addr               gforth          rpat  rp@     -- a_addr               gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
   
 rp!     a_addr --               gforth          rpstore  rp!     a_addr --               gforth          rp_store
 rp = a_addr;  rp = a_addr;
   
 \+has-floats [IF]  \+floating
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
Line 924 
Line 967 
 fp!     f_addr --       gforth  fp_store  fp!     f_addr --       gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 \+[THEN]  \+
   
 ;s      --              gforth  semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ""The primitive compiled by @code{EXIT}.""
 NEXT_P0;  SET_IP((Xt *)(*rp++));
   
 >r      w --            core    to_r  >r      w --            core    to_r
 *--rp = w;  *--rp = w;
Line 1002 
Line 1045 
   
 nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
 :  :
  >r drop r> ;   swap drop ;
   
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
 :  :
Line 1054 
Line 1097 
 \ 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}.""
 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}.""
 *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}.""
 *a_addr += n;  *a_addr += n;
 :  :
  tuck @ + swap ! ;   tuck @ + swap ! ;
   
 c@      c_addr -- c             core    cfetch  c@      c_addr -- c             core    c_fetch
   "" Read from the char at address @i{c-addr}, and return its contents, @i{c}.""
 c = *c_addr;  c = *c_addr;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1089 
Line 1136 
 ;  ;
 : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;  : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
   
 c!      c c_addr --             core    cstore  c!      c c_addr --             core    c_store
   "" Write the value @i{c} to the char at address @i{c-addr}.""
 *c_addr = c;  *c_addr = c;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1119 
Line 1167 
 : 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}.""
 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}.""
 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
   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.""
 n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
 :  :
  [ cell   [ cell
Line 1145 
Line 1198 
  2/ dup [IF] ] 2* [ [THEN]   2/ dup [IF] ] 2* [ [THEN]
  drop ] ;   drop ] ;
   
 char+   c_addr1 -- c_addr2      core    care_plus  char+   c_addr1 -- c_addr2      core    char_plus
   "" Increment @i{c-addr1} by the number of address units corresponding to the size of
   one char, to give @i{c-addr2}.""
 c_addr2 = c_addr1 + 1;  c_addr2 = c_addr1 + 1;
 :  :
  1+ ;   1+ ;
   
 (chars)         n1 -- n2        gforth  paren_cares  (chars)         n1 -- n2        gforth  paren_chars
 n2 = n1 * sizeof(Char);  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
   the string, @i{u}, and the address of its first character, @i{c-addr2}.""
 u = *c_addr1;  u = *c_addr1;
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
Line 1176 
Line 1233 
 : (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 ;
   
 \+has-hash [IF]  \+hash
   
 (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind  (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
 F83Name *f83name1;  struct F83Name *f83name1;
 f83name2=NULL;  f83name2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(struct F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
Line 1202 
Line 1259 
   
 (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind  (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind
 ""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
 F83Name *f83name1;  struct F83Name *f83name1;
 f83name2=NULL;  f83name2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(struct F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
Line 1257 
Line 1314 
   7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,    7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
   7 c, 5 c, 5 c,    7 c, 5 c, 5 c,
   
 \+[THEN]  \+
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white  (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white
 /* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
Line 1280 
Line 1337 
  REPEAT  THEN  nip - ;   REPEAT  THEN  nip - ;
   
 aligned         c_addr -- a_addr        core  aligned         c_addr -- a_addr        core
   "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}.""
 a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));  a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
 :  :
  [ cell 1- ] Literal + [ -1 cells ] Literal and ;   [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   
 faligned        c_addr -- f_addr        float   f_aligned  faligned        c_addr -- f_addr        float   f_aligned
   "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}.""
 f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));  f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
 :  :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
Line 1294 
Line 1353 
 :  :
     2 cells + ;      2 cells + ;
   
   \ threading stuff is currently only interesting if we have a compiler
   \fhas? standardthreading has? compiler and [IF]
   
 >code-address           xt -- c_addr            gforth  to_code_address  >code-address           xt -- c_addr            gforth  to_code_address
 ""c_addr is the code address of the word xt""  ""@i{c-addr} is the code address of the word @i{xt}.""
 /* !! This behaves installation-dependently for DOES-words */  /* !! This behaves installation-dependently for DOES-words */
 c_addr = (Address)CODE_ADDRESS(xt);  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 xt ist the execution token of a defining-word-defined word,  ""If @i{xt} is the execution token of a defining-word-defined word,
 a_addr is the start of the Forth code after the DOES>;  @i{a-addr} is the start of the Forth code after the @code{DOES>};
 Otherwise a_addr is 0.""  Otherwise @i{a-addr} is 0.""
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
 :  :
     cell+ @ ;      cell+ @ ;
   
 code-address!           c_addr xt --            gforth  code_address_store  code-address!           c_addr xt --            gforth  code_address_store
 ""Creates a code field with code address c_addr at 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,PFA(0));  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
 ""creates a code field at xt for a defining-word-defined word; a_addr  ""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}
 is the start of the Forth code after DOES>""  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,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
 ""creates a DOES>-handler at address a_addr. a_addr usually points  ""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points
 just behind a DOES>.""  just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :  :
     drop ;      drop ;
   
 /does-handler   -- n    gforth  slash_does_handler  /does-handler   -- n    gforth  slash_does_handler
 ""the size of a does-handler (includes possible padding)""  ""The size of a @code{DOES>}-handler (includes possible padding).""
 /* !! a constant or environmental query might be better */  /* !! a constant or environmental query might be better */
 n = DOES_HANDLER_SIZE;  n = DOES_HANDLER_SIZE;
 :  :
Line 1354 
Line 1416 
 :  :
  1 ;   1 ;
   
 \+has-os [IF]  \f[THEN]
   
 (key)   -- n            gforth  paren_key  key-file        wfileid -- n            gforth  paren_key_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  n = key((FILE*)wfileid);
 n = key();  #else
   n = key(stdin);
   #endif
   
 key?    -- n            facility        key_q  key?-file       wfileid -- n            facility        key_q_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key_query;  n = key_query((FILE*)wfileid);
   #else
   n = key_query(stdin);
   #endif
   
   \+os
   
   stdin   -- wfileid      gforth
   wfileid = (Cell)stdin;
   
 stdout  -- wfileid      gforth  stdout  -- wfileid      gforth
 wfileid = (Cell)stdout;  wfileid = (Cell)stdout;
Line 1381 
Line 1455 
   
 flush-icache    c_addr u --     gforth  flush_icache  flush-icache    c_addr u --     gforth  flush_icache
 ""Make sure that the instruction cache of the processor (if there is  ""Make sure that the instruction cache of the processor (if there is
 one) does not contain stale data at @var{c_addr} and @var{u} bytes  one) does not contain stale data at @i{c-addr} and @i{u} bytes
 afterwards. @code{END-CODE} performs a @code{flush-icache}  afterwards. @code{END-CODE} performs a @code{flush-icache}
 automatically. Caveat: @code{flush-icache} might not work on your  automatically. Caveat: @code{flush-icache} might not work on your
 installation; this is usually the case if direct threading is not  installation; this is usually the case if direct threading is not
Line 1395 
Line 1469 
 return (Label *)n;  return (Label *)n;
   
 (system)        c_addr u -- wretval wior        gforth  peren_system  (system)        c_addr u -- wretval wior        gforth  peren_system
   #ifndef MSDOS
 int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
 deprep_terminal();  deprep_terminal();
   #endif
 wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
 wior = IOR(wretval==-1 || (wretval==127 && errno != 0));  wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
   #ifndef MSDOS
 if (old_tp)  if (old_tp)
   prep_terminal();    prep_terminal();
   #endif
   
 getenv  c_addr1 u1 -- c_addr2 u2        gforth  getenv  c_addr1 u1 -- c_addr2 u2        gforth
   ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
   is the host operating system's expansion of that environment variable. If the
   environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
   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));
   
Line 1434 
Line 1516 
 (void)select(0,0,0,0,&timeout);  (void)select(0,0,0,0,&timeout);
   
 allocate        u -- a_addr wior        memory  allocate        u -- a_addr wior        memory
   ""Allocate @i{u} address units of contiguous data space. The initial
   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}
   is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
   is an implementation-defined 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.
   The regon must originally have been obtained using @code{allocate} or
   @code{resize}. If the operational is successful, @i{wior} is 0.
   If the operation fails, @i{wior} is an implementation-defined
   I/O result code.""
 free(a_addr);  free(a_addr);
 wior = 0;  wior = 0;
   
 resize          a_addr1 u -- a_addr2 wior       memory  resize          a_addr1 u -- a_addr2 wior       memory
 ""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. If  area. @i{a-addr2} is the address of the resulting area.
 @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}  If the operational is successful, @i{wior} is 0.
 @code{allocate}s @i{u} address units.""  If the operation fails, @i{wior} is an implementation-defined
   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.""
 /* 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
    on SunOS 4.1.2. */     on SunOS 4.1.2. */
 if (a_addr1==NULL)  if (a_addr1==NULL)
Line 1478 
Line 1572 
 IF_TOS(TOS=sp[0]);  IF_TOS(TOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_FTOS(FTOS=fp[0]);
   
 \+[THEN] ( has-os ) has-files [IF]  \+
   \+file
   
 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 -- w2 wior       file    open_file  open-file       c_addr u ntype -- wfileid wior  file    open_file
 w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
 wior =  IOR(w2 == 0);  #if defined(GO32) && defined(MSDOS)
   if(wfileid && !(ntype & 1))
     setbuf((FILE*)wfileid, NULL);
   #endif
   wior =  IOR(wfileid == 0);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- 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[ntype], 0666);
 if (fd != -1) {  if (fd != -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    wfileid = (Cell)fdopen(fd, fileattr[ntype]);
   wior = IOR(w2 == 0);  #if defined(GO32) && defined(MSDOS)
     if(wfileid && !(ntype & 1))
       setbuf((FILE*)wfileid, NULL);
   #endif
     wior = IOR(wfileid == 0);
 } else {  } else {
   w2 = 0;    wfileid = 0;
   wior = IOR(1);    wior = IOR(1);
 }  }
   
Line 1502 
Line 1605 
 wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);  wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
   ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);  char *s1=tilde_cstr(c_addr2, u2, 1);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);  wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
   
Line 1514 
Line 1618 
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);  wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
   
 file-size       wfileid -- ud wior      file    file_size  file-size       wfileid -- ud wior      file    file_size
 #include <sys/stat.h>  
 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 = LONG2UD(buf.st_size);
Line 1548 
Line 1651 
 */  */
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  if ((flag=FLAG(!feof((FILE *)wfileid) &&
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {                 fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
   wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */    wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */
   if (wior)    if (wior)
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
   u2 = strlen(c_addr);    u2 = strlen(c_addr);
Line 1559 
Line 1662 
   u2=0;    u2=0;
 }  }
   
 \+[THEN]  has-files [IF] -1 [ELSE] has-os [THEN] [IF]  \+
   
 write-file      c_addr u1 wfileid -- wior       file    write_file  write-file      c_addr u1 wfileid -- wior       file    write_file
 /* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
   #ifdef HAS_FILE
 {  {
   UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);    UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));    wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
   if (wior)    if (wior)
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
 }  }
   #else
   TYPE(c_addr, u1);
   #endif
   
 emit-file       c wfileid -- wior       gforth  emit_file  emit-file       c wfileid -- wior       gforth  emit_file
   #ifdef HAS_FILE
 wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);  wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   #else
   PUTC(c);
   #endif
   
 \+[THEN]  has-files [IF]  \+file
   
 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);
Line 1604 
Line 1715 
   wior=0;    wior=0;
 }  }
   
 \+[THEN] ( has-files ) has-floats [IF]  \+
   \+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 1619 
Line 1731 
   
 f>d             r -- d          float   f_to_d  f>d             r -- d          float   f_to_d
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d.hi = ldexp(r,-CELL_BITS) - (r<0);  d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  d.lo = r-ldexp((Float)d.hi,CELL_BITS);
 #else  #else
 d = r;  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}.""
 *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}.""
 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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *df_addr;  r = *df_addr;
 #else  #else
Line 1639 
Line 1754 
 #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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *df_addr = r;  *df_addr = r;
 #else  #else
Line 1646 
Line 1762 
 #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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *sf_addr;  r = *sf_addr;
 #else  #else
Line 1653 
Line 1770 
 #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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *sf_addr = r;  *sf_addr = r;
 #else  #else
Line 1672 
Line 1790 
 r3 = r1/r2;  r3 = r1/r2;
   
 f**             r1 r2 -- r3     float-ext       f_star_star  f**             r1 r2 -- r3     float-ext       f_star_star
 ""@i{r3} is @i{r1} raised to the @i{r2}th power""  ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
 r3 = pow(r1,r2);  r3 = pow(r1,r2);
   
 fnegate         r1 -- r2        float  fnegate         r1 -- r2        float
Line 1693 
Line 1811 
 ftuck           r1 r2 -- r2 r1 r2       gforth  ftuck           r1 r2 -- r2 r1 r2       gforth
   
 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
   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.""
 n2 = n1*sizeof(Float);  n2 = n1*sizeof(Float);
   
 floor           r1 -- r2        float  floor           r1 -- r2        float
 ""round towards the next smaller integral value, i.e., round toward negative infinity""  ""Round towards the next smaller integral value, i.e., round toward negative infinity.""
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround          r1 -- r2        float  fround          r1 -- r2        float
 ""round to the nearest integral value""  ""Round to the nearest integral value.""
 /* !! unclear wording */  /* !! unclear wording */
 #ifdef HAVE_RINT  #ifdef HAVE_RINT
 r2 = rint(r1);  r2 = rint(r1);
Line 1732 
Line 1853 
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &flag);
 n=(r==0 ? 1 : decpt);  n=(r==0 ? 1 : decpt);
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);  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
   internal floating-point representation. If the string
   represents a valid floating-point number @i{r} is placed
   on the floating-point stack and @i{flag} is true. Otherwise,
   @i{flag} is false. A string of blanks is a special case
   and represents the flotaing-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);
 char *endconv;  char *endconv;
 while(isspace(number[--u]) && u>0);  while(isspace((unsigned)(number[--u])) && u>0);
 switch(number[u])  switch(number[u])
 {  {
    case 'd':     case 'd':
Line 1782 
Line 1909 
 r2 = atan(r1);  r2 = atan(r1);
   
 fatan2          r1 r2 -- r3     float-ext  fatan2          r1 r2 -- r3     float-ext
 ""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably  ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably
 intends this to be the inverse of @code{fsincos}. In gforth it is.""  intends this to be the inverse of @code{fsincos}. In gforth it is.""
 r3 = atan2(r1,r2);  r3 = atan2(r1,r2);
   
Line 1795 
Line 1922 
 fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 #ifdef HAVE_EXPM1  #ifdef HAVE_EXPM1
 extern double expm1(double);  extern double
   #ifdef NeXT
                 const
   #endif
                       expm1(double);
 r2 = expm1(r1);  r2 = expm1(r1);
 #else  #else
 r2 = exp(r1)-1.;  r2 = exp(r1)-1.;
Line 1807 
Line 1938 
 flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
 ""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
 #ifdef HAVE_LOG1P  #ifdef HAVE_LOG1P
 extern double log1p(double);  extern double
   #ifdef NeXT
                 const
   #endif
                       log1p(double);
 r2 = log1p(r1);  r2 = log1p(r1);
 #else  #else
 r2 = log(r1+1.);  r2 = log(r1+1.);
 #endif  #endif
   
 flog            r1 -- r2        float-ext  flog            r1 -- r2        float-ext
 ""the decimal logarithm""  ""The decimal logarithm.""
 r2 = log10(r1);  r2 = log10(r1);
   
 falog           r1 -- r2        float-ext  falog           r1 -- r2        float-ext
Line 1870 
Line 2005 
  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}
   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}
   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
   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
   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)));
 :  :
  [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
Line 1891 
Line 2034 
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+[THEN] ( has-floats ) has-locals [IF]  \+
   \+glocals
   
 @local#         -- w    gforth  fetch_local_number  @local#         -- w    gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+(Cell)NEXT_INST);
Line 1909 
Line 2053 
 @local3 -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = *(Cell *)(lp+3*sizeof(Cell));
   
 \+has-floats [IF]  \+floating
   
 f@local#        -- r    gforth  f_fetch_local_number  f@local#        -- r    gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+(Cell)NEXT_INST);
Line 1921 
Line 2065 
 f@local1        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  r = *(Float *)(lp+1*sizeof(Float));
   
 \+[THEN]  \+
   
 laddr#          -- c_addr       gforth  laddr_number  laddr#          -- c_addr       gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
Line 1951 
Line 2095 
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 \+has-floats [IF]  \+floating
   
 f>l     r --    gforth  f_to_l  f>l     r --    gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 \+[THEN]  [THEN] \ has-locals  fpick   u -- r          gforth
   r = fp[u+1]; /* +1, because update of fp happens before this fragment */
   :
    floats fp@ + f@ ;
   
   \+
   \+
   
 \+has-OS [IF]  \+OS
   
 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')')
Line 1981 
Line 2131 
 \ icall(argnum)  \ icall(argnum)
 define(icall,  define(icall,
 `icall$1        argflist($1)u -- uret   gforth  `icall$1        argflist($1)u -- uret   gforth
 uret = ((Cell(*)(argdlist($1)))u)(argclist($1));  uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
 define(fcall,  define(fcall,
 `fcall$1        argflist($1)u -- rret   gforth  `fcall$1        argflist($1)u -- rret   gforth
 rret = ((Float(*)(argdlist($1)))u)(argclist($1));  rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
   
   
 open-lib        c_addr1 u1 -- u2        gforth  open_lib  open-lib        c_addr1 u1 -- u2        gforth  open_lib
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_LAZY);  #ifndef RTLD_GLOBAL
   #define RTLD_GLOBAL 0
   #endif
   u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef _WIN32
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define open-lib!  #warning Define open-lib!
Line 2007 
Line 2160 
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef _WIN32
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define lib-sym!  #warning Define lib-sym!
Line 2020 
Line 2173 
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+[THEN] \ has-OS  \+
   
 up!     a_addr --       gforth  up_store  up!     a_addr --       gforth  up_store
 UP=up=(char *)a_addr;  UP=up=(char *)a_addr;
Line 2028 
Line 2181 
  up ! ;   up ! ;
 Variable UP  Variable UP
   
   wcall   u --    gforth
   IF_FTOS(fp[0]=FTOS);
   FP=fp;
   sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
   fp=FP;
   IF_TOS(TOS=sp[0];)
   IF_FTOS(FTOS=fp[0]);
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help