Diff for /gforth/prim between versions 1.30 and 1.46

version 1.30, 1999/05/09 21:21:55 version 1.46, 2000/05/31 14:37:40
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 @i{ucount}>0, copy the contents of @i{ucount} address units  ""Copy the contents of @i{ucount} address units at @i{c-from} to
 at @i{c-from} to @i{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 @i{c-from}, @i{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  c_move
 "" If @i{u}>0, copy the contents of @i{ucount} characters from  ""Copy the contents of @i{ucount} characters from data space at
 data space at @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from low address to high address.""  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 @i{u}>0, copy the contents of @i{ucount} characters from  ""Copy the contents of @i{ucount} characters from data space at
 data space at @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from high address to low address.""  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 482  the first string is smaller, @i{n} is -1 Line 488  the first string is smaller, @i{n} is -1
 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.""
   /* close ' to keep fontify happy */ 
 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)
   n = u1-u2;    n = u1-u2;
Line 490  if (n<0) Line 497  if (n<0)
 else if (n>0)  else if (n>0)
   n = 1;    n = 1;
 :  :
  rot 2dup - >r min swap -text dup   rot 2dup swap - >r min swap -text dup
  IF    rdrop   IF  rdrop  ELSE  drop r> sgn  THEN ;
  ELSE  drop r@ 0>  : sgn ( n -- -1/0/1 )
        IF    rdrop -1   dup 0= IF EXIT THEN  0< 2* 1+ ;
        ELSE  r> 1 and  
        THEN  
  THEN ;  
   
 -text           c_addr1 u c_addr2 -- n  new     dash_text  -text           c_addr1 u c_addr2 -- n  new     dash_text
 n = memcmp(c_addr1, c_addr2, u);  n = memcmp(c_addr1, c_addr2, u);
Line 508  else if (n>0) Line 512  else if (n>0)
  swap bounds   swap bounds
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
  ELSE  c@ I c@ - unloop  THEN  -text-flag ;   ELSE  c@ I c@ - unloop  THEN  -text-flag ;
 : -text-flag ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
  dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 toupper c1 -- c2        gforth  toupper c1 -- c2        gforth
 ""If @i{c1} is a lower-case character (in the current locale), @i{c2}  ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
Line 713  ud = (UDCell)u1 * (UDCell)u2; Line 717  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 761  d = d1-d2; Line 766  d = d1-d2;
 :  :
  dnegate d+ ;   dnegate d+ ;
   
 dnegate d1 -- d2                double  dnegate d1 -- d2                double  d_negate
 /* use dminus as alias */  /* use dminus as alias */
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d2 = dnegate(d1);  d2 = dnegate(d1);
Line 800  w = w1|w2; Line 805  w = w1|w2;
 :  :
  invert swap invert and invert ;   invert swap invert and invert ;
   
 xor     w1 w2 -- w              core  xor     w1 w2 -- w              core    x_or
 w = w1^w2;  w = w1^w2;
   
 invert  w1 -- w2                core  invert  w1 -- w2                core
Line 808  w2 = ~w1; Line 813  w2 = ~w1;
 :  :
  MAXU xor ;   MAXU xor ;
   
 rshift  u1 n -- u2              core  rshift  u1 n -- u2              core    r_shift
   u2 = u1>>n;    u2 = u1>>n;
 :  :
     0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
   
 lshift  u1 n -- u2              core  lshift  u1 n -- u2              core    l_shift
   u2 = u1<<n;    u2 = u1<<n;
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
Line 829  f = FLAG($4==$5); Line 834  f = FLAG($4==$5);
         ] xor 0= [          ] xor 0= [
     [THEN] ] ;      [THEN] ] ;
   
 $1<>    $2 -- f         $7      $3different  $1<>    $2 -- f         $7      $3not_equals
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
 :  :
     [ char $1x char 0 = [IF]      [ char $1x char 0 = [IF]
Line 838  f = FLAG($4!=$5); Line 843  f = FLAG($4!=$5);
         ] xor 0<> [          ] xor 0<> [
     [THEN] ] ;      [THEN] ] ;
   
 $1<     $2 -- f         $8      $3less  $1<     $2 -- f         $8      $3less_than
 f = FLAG($4<$5);  f = FLAG($4<$5);
 :  :
     [ char $1x char 0 = [IF]      [ char $1x char 0 = [IF]
Line 850  f = FLAG($4<$5); Line 855  f = FLAG($4<$5);
         [THEN]          [THEN]
     [THEN] ] ;      [THEN] ] ;
   
 $1>     $2 -- f         $9      $3greater  $1>     $2 -- f         $9      $3greater_than
 f = FLAG($4>$5);  f = FLAG($4>$5);
 :  :
     [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]      [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
Line 882  f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); Line 887  f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
 f = FLAG($4==$5);  f = FLAG($4==$5);
 #endif  #endif
   
 $1<>    $2 -- f         $7      $3different  $1<>    $2 -- f         $7      $3not_equals
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);  f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
 #else  #else
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
 #endif  #endif
   
 $1<     $2 -- f         $8      $3less  $1<     $2 -- f         $8      $3less_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
 #else  #else
 f = FLAG($4<$5);  f = FLAG($4<$5);
 #endif  #endif
   
 $1>     $2 -- f         $9      $3greater  $1>     $2 -- f         $9      $3greater_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
 #else  #else
Line 928  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2 Line 933  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 1012  swap w1 w2 -- w2 w1  core Line 1024  swap w1 w2 -- w2 w1  core
  >r (swap) ! r> (swap) @ ;   >r (swap) ! r> (swap) @ ;
 Variable (swap)  Variable (swap)
   
 dup     w -- w w                core  dup     w -- w w                core    dupe
 :  :
  sp@ @ ;   sp@ @ ;
   
Line 1335  f_addr = (Float *)((((Cell)c_addr)+(size Line 1347  f_addr = (Float *)((((Cell)c_addr)+(size
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 >body           xt -- a_addr    core    to_body  >body           xt -- a_addr    core    to_body
   "" Get the address of the body of the word represented by @i{xt} (the address
   of the word's data field).""
 a_addr = PFA(xt);  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
 ""@i{c-addr} is the code address of the word @i{xt}.""  ""@i{c-addr} is the code address of the word @i{xt}.""
Line 1401  n=1; Line 1416  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 1470  getenv c_addr1 u1 -- c_addr2 u2 gforth Line 1485  getenv c_addr1 u1 -- c_addr2 u2 gforth
 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, @i{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.""
   /* close ' to keep fontify happy */
 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 1482  wretval = pclose((FILE *)wfileid); Line 1498  wretval = pclose((FILE *)wfileid);
 wior = IOR(wretval==-1);  wior = IOR(wretval==-1);
   
 time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
   ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
   Months are numbered from 1.""
 struct timeval time1;  struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
Line 1495  nmin  =ltime->tm_min; Line 1513  nmin  =ltime->tm_min;
 nsec  =ltime->tm_sec;  nsec  =ltime->tm_sec;
   
 ms      n --    facility-ext  ms      n --    facility-ext
   ""Wait at least @i{n} milli-second.""
 struct timeval timeout;  struct timeval timeout;
 timeout.tv_sec=n/1000;  timeout.tv_sec=n/1000;
 timeout.tv_usec=1000*(n%1000);  timeout.tv_usec=1000*(n%1000);
Line 1528  I/O result code. If @i{a-addr1} is 0, Gf Line 1547  I/O result code. If @i{a-addr1} is 0, Gf
 @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. */
   /* close ' to keep fontify happy */
 if (a_addr1==NULL)  if (a_addr1==NULL)
   a_addr2 = (Cell *)malloc(u);    a_addr2 = (Cell *)malloc(u);
 else  else
Line 1619  if (wior) Line 1639  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
 Cell c;  Cell c;
 flag=-1;  flag=-1;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
 {  {
    *c_addr++ = (Char)(c = getc((FILE *)wfileid));     c = getc((FILE *)wfileid);
    if(c=='\n') break;     if (c=='\n') break;
    if(c==EOF)     if (c=='\r') {
      {       if ((c = getc((FILE *)wfileid))!='\n')
          ungetc(c,(FILE *)wfileid);
        break;
      }
      if (c==EOF) {
         flag=FLAG(u2!=0);          flag=FLAG(u2!=0);
         break;          break;
      }       }
      c_addr[u2] = (Char)c;
 }  }
 wior=FILEIO(ferror((FILE *)wfileid));  wior=FILEIO(ferror((FILE *)wfileid));
 */  #else
 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)!=0); /* !! ior? */    wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */
Line 1646  else { Line 1671  else {
   wior=0;    wior=0;
   u2=0;    u2=0;
 }  }
   #endif
   
 \+  \+
 \+file  
   
 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  #ifdef HAS_FILE
Line 1667  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 1777  f**  r1 r2 -- r3 float-ext f_star_star Line 1804  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   f_negate
 r2 = - r1;  r2 = - r1;
   
 fdrop           r --            float  fdrop           r --            float   f_drop
   
 fdup            r -- r r        float  fdup            r -- r r        float   f_dupe
   
 fswap           r1 r2 -- r2 r1  float  fswap           r1 r2 -- r2 r1  float   f_swap
   
 fover           r1 r2 -- r1 r2 r1       float  fover           r1 r2 -- r1 r2 r1       float   f_over
   
 frot            r1 r2 r3 -- r2 r3 r1    float  frot            r1 r2 r3 -- r2 r3 r1    float   f_rote
   
 fnip            r1 r2 -- r2     gforth  fnip            r1 r2 -- r2     gforth  f_nip
   
 ftuck           r1 r2 -- r2 r1 r2       gforth  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  "" Increment @i{f-addr1} by the number of address units corresponding to the size of
Line 1808  floor  r1 -- r2 float Line 1835  floor  r1 -- r2 float
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround          r1 -- r2        float  fround          r1 -- r2        float   f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
 /* !! unclear wording */  /* !! unclear wording */
 #ifdef HAVE_RINT  #ifdef HAVE_RINT
Line 1818  r2 = floor(r1+0.5); Line 1845  r2 = floor(r1+0.5);
 /* !! This is not quite true to the rounding rules given in the standard */  /* !! This is not quite true to the rounding rules given in the standard */
 #endif  #endif
   
 fmax            r1 r2 -- r3     float  fmax            r1 r2 -- r3     float   f_max
 if (r1<r2)  if (r1<r2)
   r3 = r2;    r3 = r2;
 else  else
   r3 = r1;    r3 = r1;
   
 fmin            r1 r2 -- r3     float  fmin            r1 r2 -- r3     float   f_min
 if (r1<r2)  if (r1<r2)
   r3 = r1;    r3 = r1;
 else  else
Line 1846  internal floating-point representation. Line 1873  internal floating-point representation.
 represents a valid floating-point number @i{r} is placed  represents a valid floating-point number @i{r} is placed
 on the floating-point stack and @i{flag} is true. Otherwise,  on the floating-point stack and @i{flag} is true. Otherwise,
 @i{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 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);
 char *endconv;  char *endconv;
   int sign = 0;
   if(number[0]=='-') {
      sign = 1;
      number++;
      u--;
   }
 while(isspace((unsigned)(number[--u])) && u>0);  while(isspace((unsigned)(number[--u])) && u>0);
 switch(number[u])  switch(number[u])
 {  {
Line 1866  if((flag=FLAG(!(Cell)*endconv))) Line 1899  if((flag=FLAG(!(Cell)*endconv)))
 {  {
    IF_FTOS(fp[0] = FTOS);     IF_FTOS(fp[0] = FTOS);
    fp += -1;     fp += -1;
    FTOS = r;     FTOS = sign ? -r : r;
 }  }
 else if(*endconv=='d' || *endconv=='D')  else if(*endconv=='d' || *endconv=='D')
 {  {
Line 1876  else if(*endconv=='d' || *endconv=='D') Line 1909  else if(*endconv=='d' || *endconv=='D')
      {       {
         IF_FTOS(fp[0] = FTOS);          IF_FTOS(fp[0] = FTOS);
         fp += -1;          fp += -1;
         FTOS = r;          FTOS = sign ? -r : r;
      }       }
 }  }
   
 fabs            r1 -- r2        float-ext  fabs            r1 -- r2        float-ext       f_abs
 r2 = fabs(r1);  r2 = fabs(r1);
   
 facos           r1 -- r2        float-ext  facos           r1 -- r2        float-ext       f_a_cos
 r2 = acos(r1);  r2 = acos(r1);
   
 fasin           r1 -- r2        float-ext  fasin           r1 -- r2        float-ext       f_a_sine
 r2 = asin(r1);  r2 = asin(r1);
   
 fatan           r1 -- r2        float-ext  fatan           r1 -- r2        float-ext       f_a_tan
 r2 = atan(r1);  r2 = atan(r1);
   
 fatan2          r1 r2 -- r3     float-ext  fatan2          r1 r2 -- r3     float-ext       f_a_tan_two
 ""@i{r1/r2}=tan(@i{r3}). ANS Forth 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);
   
 fcos            r1 -- r2        float-ext  fcos            r1 -- r2        float-ext       f_cos
 r2 = cos(r1);  r2 = cos(r1);
   
 fexp            r1 -- r2        float-ext  fexp            r1 -- r2        float-ext       f_e_x_p
 r2 = exp(r1);  r2 = exp(r1);
   
 fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext       f_e_x_p_m_one
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 #ifdef HAVE_EXPM1  #ifdef HAVE_EXPM1
 extern double  extern double
Line 1916  r2 = expm1(r1); Line 1949  r2 = expm1(r1);
 r2 = exp(r1)-1.;  r2 = exp(r1)-1.;
 #endif  #endif
   
 fln             r1 -- r2        float-ext  fln             r1 -- r2        float-ext       f_l_n
 r2 = log(r1);  r2 = log(r1);
   
 flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext       f_l_n_p_one
 ""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
 #ifdef HAVE_LOG1P  #ifdef HAVE_LOG1P
 extern double  extern double
Line 1932  r2 = log1p(r1); Line 1965  r2 = log1p(r1);
 r2 = log(r1+1.);  r2 = log(r1+1.);
 #endif  #endif
   
 flog            r1 -- r2        float-ext  flog            r1 -- r2        float-ext       f_log
 ""The decimal logarithm.""  ""The decimal logarithm.""
 r2 = log10(r1);  r2 = log10(r1);
   
 falog           r1 -- r2        float-ext  falog           r1 -- r2        float-ext       f_a_log
 ""@i{r2}=10**@i{r1}""  ""@i{r2}=10**@i{r1}""
 extern double pow10(double);  extern double pow10(double);
 r2 = pow10(r1);  r2 = pow10(r1);
   
 fsin            r1 -- r2        float-ext  fsin            r1 -- r2        float-ext       f_sine
 r2 = sin(r1);  r2 = sin(r1);
   
 fsincos         r1 -- r2 r3     float-ext  fsincos         r1 -- r2 r3     float-ext       f_sine_cos
 ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""  ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
 r2 = sin(r1);  r2 = sin(r1);
 r3 = cos(r1);  r3 = cos(r1);
   
 fsqrt           r1 -- r2        float-ext  fsqrt           r1 -- r2        float-ext       f_square_root
 r2 = sqrt(r1);  r2 = sqrt(r1);
   
 ftan            r1 -- r2        float-ext  ftan            r1 -- r2        float-ext       f_tan
 r2 = tan(r1);  r2 = tan(r1);
 :  :
  fsincos f/ ;   fsincos f/ ;
   
 fsinh           r1 -- r2        float-ext  fsinh           r1 -- r2        float-ext       f_cinch
 r2 = sinh(r1);  r2 = sinh(r1);
 :  :
  fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;   fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
   
 fcosh           r1 -- r2        float-ext  fcosh           r1 -- r2        float-ext       f_cosh
 r2 = cosh(r1);  r2 = cosh(r1);
 :  :
  fexp fdup 1/f f+ f2/ ;   fexp fdup 1/f f+ f2/ ;
   
 ftanh           r1 -- r2        float-ext  ftanh           r1 -- r2        float-ext       f_tan_h
 r2 = tanh(r1);  r2 = tanh(r1);
 :  :
  f2* fexpm1 fdup 2. d>f f+ f/ ;   f2* fexpm1 fdup 2. d>f f+ f/ ;
   
 fasinh          r1 -- r2        float-ext  fasinh          r1 -- r2        float-ext       f_a_cinch
 r2 = asinh(r1);  r2 = asinh(r1);
 :  :
  fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;   fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
   
 facosh          r1 -- r2        float-ext  facosh          r1 -- r2        float-ext       f_a_cosh
 r2 = acosh(r1);  r2 = acosh(r1);
 :  :
  fdup fdup f* 1. d>f f- fsqrt f+ fln ;   fdup fdup f* 1. d>f f- fsqrt f+ fln ;
   
 fatanh          r1 -- r2        float-ext  fatanh          r1 -- r2        float-ext       f_a_tan_h
 r2 = atanh(r1);  r2 = atanh(r1);
 :  :
  fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/   fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
Line 2124  rret = (SYSCALL(Float(*)(argdlist($1)))u Line 2157  rret = (SYSCALL(Float(*)(argdlist($1)))u
   
 ')  ')
   
   \ close ' to keep fontify happy
   
 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)
Line 2164  UP=up=(char *)a_addr; Line 2198  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]);
   
   \+file
   
   open-dir        c_addr u -- wdirid wior gforth  open_dir
   wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
   wior =  IOR(wdirid == 0);
   
   read-dir        c_addr u1 wdirid -- u2 flag wior        gforth  read_dir
   struct dirent * dent;
   dent = readdir((DIR *)wdirid);
   wior = 0;
   flag = -1;
   if(dent == NULL) {
     u2 = 0;
     flag = 0;
   } else {
     u2 = strlen(dent->d_name);
     if(u2 > u1)
       u2 = u1;
     memmove(c_addr, dent->d_name, u2);
   }
   
   close-dir       wdirid -- wior  gforth  close_dir
   wior = IOR(closedir((DIR *)wdirid));
   
   filename-match  c_addr1 u1 c_addr2 u2 -- flag   gforth  match_file
   char * string = cstr(c_addr1, u1, 1);
   char * pattern = cstr(c_addr2, u2, 0);
   flag = FLAG(!fnmatch(pattern, string, 0));
   
   \+
   
   newline -- c_addr u     gforth
   ""String containing the newline sequence of the host OS""
   char newline[] = {
   #ifdef unix
   '\n'
   #else
   '\r','\n'
   #endif
   };
   c_addr=newline;
   u=sizeof(newline);

Removed from v.1.30  
changed lines
  Added in v.1.46


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