Diff for /gforth/prim between versions 1.28 and 1.37

version 1.28, 1999/05/05 12:07:56 version 1.37, 1999/08/07 21:40:35
Line 115  INC_IP(1); Line 115  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, @var{xt}.""  ""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);
Line 129  EXEC(*(Xt *)a_addr); Line 129  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
   
   \fhas? skipbranchprims 0= [IF]
 \+glocals  \+glocals
   
 branch-lp+!#    --      gforth  branch_lp_plus_store_number  branch-lp+!#    --      gforth  branch_lp_plus_store_number
Line 208  else Line 209  else
   INC_IP(1);    INC_IP(1);
   
 \+  \+
   \f[THEN]
   \fhas? skiploopprims 0= [IF]
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
Line 437  n = rp[4]; Line 440  n = rp[4];
   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 @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [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
 "" If @var{ucount}>0, copy the contents of @var{ucount} address units  ""Copy the contents of @i{ucount} address units at @i{c-from} to
 at @var{c-from} to @var{c-to}. @code{move} chooses its copy direction  @i{c-to}. @code{move} works correctly even if the two areas overlap.""
 to avoid problems when @var{c-from}, @var{c-to} 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
 "" If @var{u}>0, copy the contents of @var{ucount} characters from  ""Copy the contents of @i{ucount} characters from data space at
 data space at @var{c-from} to @var{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from low address to high address.""  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
 "" If @var{u}>0, copy the contents of @var{ucount} characters from  ""Copy the contents of @i{ucount} characters from data space at
 data space at @var{c-from} to @var{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from high address to low address.""  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 469  while (u-- > 0) Line 475  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 @var{u}>0, store character @var{c} in each of @var{u} consecutive  "" If @i{u}>0, store character @i{c} in each of @i{u} consecutive
 @code{char} addresses in memory, starting at address @var{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
  ?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 two strings lexicographically. If they are equal, @var{n} is 0; if  ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
 the first string is smaller, @var{n} is -1; if the first string is larger, @var{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 consider the current  comparison. In the future, this may change to consider the current
 locale and its collation order.""  locale and its collation order.""
   #ifdef MEMCMP_AS_SUBROUTINE
   n = gforth_memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
   #else
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
   #endif
 if (n==0)  if (n==0)
   n = u1-u2;    n = u1-u2;
 if (n<0)  if (n<0)
Line 499  else if (n>0) Line 509  else if (n>0)
  THEN ;   THEN ;
   
 -text           c_addr1 u c_addr2 -- n  new     dash_text  -text           c_addr1 u c_addr2 -- n  new     dash_text
   #ifdef MEMCMP_AS_SUBROUTINE
   n = gforth_memcmp(c_addr1, c_addr2, u);
   #else
 n = memcmp(c_addr1, c_addr2, u);  n = memcmp(c_addr1, c_addr2, u);
   #endif
 if (n<0)  if (n<0)
   n = -1;    n = -1;
 else if (n>0)  else if (n>0)
Line 512  else if (n>0) Line 526  else if (n>0)
  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 @var{c1} is a lower-case character (in the current locale), @var{c2}  ""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.""  is the equivalent upper-case character. All other characters are unchanged.""
 c2 = toupper(c1);  c2 = toupper(c1);
 :  :
Line 532  else if (n>0) Line 546  else if (n>0)
  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 @var{c-addr, u1} to remove all trailing  ""Adjust the string specified by @i{c-addr, u1} to remove all trailing
 spaces. @var{u2} is the length of the modified string.""  spaces. @i{u2} is the length of the modified string.""
 u2 = u1;  u2 = u1;
 while (u2>0 && c_addr[u2-1] == ' ')  while (u2>0 && c_addr[u2-1] == ' ')
   u2--;    u2--;
Line 542  while (u2>0 && c_addr[u2-1] == ' ') Line 556  while (u2>0 && c_addr[u2-1] == ' ')
         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 @var{c-addr1, u1} to remove @var{n}  ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
 characters from the start of the string.""  characters from the start of the string.""
 c_addr2 = c_addr1+n;  c_addr2 = c_addr1+n;
 u2 = u1-n;  u2 = u1-n;
Line 554  n = n1+n2; Line 568  n = n1+n2;
   
 \ PFE-0.9.14 has it differently, but the next release will have it as follows  \ PFE-0.9.14 has it differently, but the next release will have it as follows
 under+  n1 n2 n3 -- n n2        gforth  under_plus  under+  n1 n2 n3 -- n n2        gforth  under_plus
 ""add @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 641  n2 = n1>>1; Line 655  n2 = n1>>1;
  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: @var{d1} = @var{n3}*@var{n1}+@var{n2}, @var{n1}>@var{n2}>=0 or 0>=@var{n2}>@var{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 663  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) Line 677  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
  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: @var{d1} = @var{n3}*@var{n1}+@var{n2}, sign(@var{n2})=sign(@var{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 713  ud = (UDCell)u1 * (UDCell)u2; Line 727  ud = (UDCell)u1 * (UDCell)u2;
    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 928  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2 Line 943  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2
 \+  \+
   
 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< ;
Line 1083  w = sp[u+1]; Line 1105  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}.""
 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    c_fetch  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 1119  c = *c_addr; Line 1145  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}.""
 *c_addr = c;  *c_addr = c;
 :  :
 [ bigendian [IF] ]  [ bigendian [IF] ]
Line 1148  c! c c_addr --  core c_store Line 1175  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}.""
 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 1174  n2 = n1 * sizeof(Cell); Line 1206  n2 = n1 * sizeof(Cell);
  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 @var{c-add1} is the address of a counted string return the length of  "" If @i{c-add1} is the address of a counted string return the length of
 the string, @var{u}, and the address of its first character, @var{c-addr2}.""  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;
 :  :
Line 1240  while(a_addr != NULL) Line 1274  while(a_addr != NULL)
    f83name1=(struct 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 &&
   #ifdef MEMCMP_AS_SUBROUTINE
          gforth_memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
   #else
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
   #endif
      {       {
         f83name2=f83name1;          f83name2=f83name1;
         break;          break;
Line 1311  else { Line 1349  else {
  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 1325  a_addr = PFA(xt); Line 1365  a_addr = PFA(xt);
 :  :
     2 cells + ;      2 cells + ;
   
 \+standardthreading  \ 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
 ""@var{c-addr} is the code address of the word @var{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 @var{xt} is the execution token of a defining-word-defined word,  ""If @i{xt} is the execution token of a defining-word-defined word,
 @var{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 @var{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
 ""Create a code field with code address @var{c-addr} at @var{xt}.""  ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  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 @var{xt} for a defining-word-defined word; @var{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 @code{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,(size_t)PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
Line 1358  CACHE_FLUSH(xt,(size_t)PFA(0)); Line 1399  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 @var{a-addr}. Usually, @var{a-addr} points  ""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points
 just behind a @code{DOES>}.""  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 1387  n=1; Line 1428  n=1;
 :  :
  1 ;   1 ;
   
 \+  \f[THEN]
   
 key-file        wfileid -- n            gforth  paren_key_file  key-file        wfileid -- n            gforth  paren_key_file
 #ifdef HAS_FILE  #ifdef HAS_FILE
Line 1426  ucols=cols; Line 1467  ucols=cols;
   
 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 1452  if (old_tp) Line 1493  if (old_tp)
 #endif  #endif
   
 getenv  c_addr1 u1 -- c_addr2 u2        gforth  getenv  c_addr1 u1 -- c_addr2 u2        gforth
 ""The string @var{c-addr1 u1} specifies an environment variable. The string @var{c-addr2 u2}  ""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  is the host operating system's expansion of that environment variable. If the
 environment variable does not exist, @var{c-addr2 u2} specifies a string 0 characters  environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
 in length.""  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 1487  timeout.tv_usec=1000*(n%1000); Line 1528  timeout.tv_usec=1000*(n%1000);
 (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 @var{u} address units of contiguous data space. The initial  ""Allocate @i{u} address units of contiguous data space. The initial
 contents of the data space is undefined. If the allocation is successful,  contents of the data space is undefined. If the allocation is successful,
 @var{a-addr} is the start address of the allocated region and @var{wior}  @i{a-addr} is the start address of the allocated region and @i{wior}
 is 0. If the allocation fails, @var{a-addr} is undefined and @var{wior}  is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
 is an implementation-defined I/O result code.""  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 @var{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 regon must originally have been obtained using @code{allocate} or
 @code{resize}. If the operational is successful, @var{wior} is 0.  @code{resize}. If the operational is successful, @i{wior} is 0.
 If the operation fails, @var{wior} is an implementation-defined  If the operation fails, @i{wior} is an implementation-defined
 I/O result code.""  I/O result code.""
 free(a_addr);  free(a_addr);
 wior = 0;  wior = 0;
Line 1508  resize  a_addr1 u -- a_addr2 wior memory Line 1549  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.  area. @i{a-addr2} is the address of the resulting area.
 If the operational is successful, @var{wior} is 0.  If the operational is successful, @i{wior} is 0.
 If the operation fails, @var{wior} is an implementation-defined  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)  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
    on SunOS 4.1.2. */     on SunOS 4.1.2. */
Line 1576  delete-file c_addr u -- wior  file delet Line 1617  delete-file c_addr u -- wior  file delet
 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 @var{c_addr1 u1} to new name @var{c_addr2 u2}""  ""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 1622  wior=FILEIO(ferror((FILE *)wfileid)); Line 1663  wior=FILEIO(ferror((FILE *)wfileid));
 */  */
 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 1653  wior = FILEIO(putc(c, (FILE *)wfileid)== Line 1694  wior = FILEIO(putc(c, (FILE *)wfileid)==
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
 #else  #else
 putc(c, stdout);  PUTC(c);
 #endif  #endif
   
 \+file  \+file
Line 1708  d = r; Line 1749  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 1721  r = *df_addr; Line 1765  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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *df_addr = r;  *df_addr = r;
 #else  #else
Line 1728  df!  r df_addr -- float-ext d_f_store Line 1773  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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 r = *sf_addr;  r = *sf_addr;
 #else  #else
Line 1735  r = *sf_addr; Line 1781  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}.""
 #ifdef IEEE_FP  #ifdef IEEE_FP
 *sf_addr = r;  *sf_addr = r;
 #else  #else
Line 1775  fnip  r1 r2 -- r2 gforth Line 1822  fnip  r1 r2 -- r2 gforth
 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
Line 1818  f2=FLAG(isdigit((unsigned)(sig[0]))!=0); Line 1868  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 @var{c-addr u} to  ""Attempt to convert the character string @i{c-addr u} to
 internal floating-point representation. If the string  internal floating-point representation. If the string
 represents a valid floating-point number @var{r} is placed  represents a valid floating-point number @i{r} is placed
 on the floating-point stack and @var{flag} is true. Otherwise,  on the floating-point stack and @i{flag} is true. Otherwise,
 @var{flag} is false. A string of blanks is a special case  @i{flag} is false. A string of blanks is a special case
 and represents the flotaing-point number 0.""  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;
Line 1966  r2 = atanh(r1); Line 2016  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}
   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 2133  UP=up=(char *)a_addr; Line 2191  UP=up=(char *)a_addr;
 :  :
  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]);
   

Removed from v.1.28  
changed lines
  Added in v.1.37


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