Diff for /gforth/prim between versions 1.35 and 1.43

version 1.35, 1999/05/20 13:38:02 version 1.43, 2000/03/11 20:35:05
Line 452  memmove(c_to,c_from,ucount); Line 452  memmove(c_to,c_from,ucount);
 :  :
  >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
 ""Copy the contents of @i{ucount} characters from data space at  ""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}  @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  from low address to high address; i.e., for overlapping areas it is
Line 496  if (n<0) Line 496  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 514  else if (n>0) Line 511  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 768  d = d1-d2; Line 765  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 807  w = w1|w2; Line 804  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 815  w2 = ~w1; Line 812  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 836  f = FLAG($4==$5); Line 833  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 845  f = FLAG($4!=$5); Line 842  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 857  f = FLAG($4<$5); Line 854  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 889  f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); Line 886  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 1026  swap w1 w2 -- w2 w1  core Line 1023  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 1349  f_addr = (Float *)((((Cell)c_addr)+(size Line 1346  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 + ;
Line 1663  else { Line 1662  else {
 }  }
   
 \+  \+
 \+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 1682  wior = FILEIO(putc(c, (FILE *)wfileid)== Line 1682  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 1792  f**  r1 r2 -- r3 float-ext f_star_star Line 1792  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 1823  floor  r1 -- r2 float Line 1823  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 1833  r2 = floor(r1+0.5); Line 1833  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 1861  internal floating-point representation. Line 1861  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 1881  if((flag=FLAG(!(Cell)*endconv))) Line 1887  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 1891  else if(*endconv=='d' || *endconv=='D') Line 1897  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 1931  r2 = expm1(r1); Line 1937  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 1947  r2 = log1p(r1); Line 1953  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/

Removed from v.1.35  
changed lines
  Added in v.1.43


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