Diff for /gforth/prim between versions 1.37 and 1.42

version 1.37, 1999/08/07 21:40:35 version 1.42, 2000/01/17 00:04:29
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 488  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.""
 #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 509  else if (n>0) Line 505  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 776  d = d1-d2; Line 768  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 815  w = w1|w2; Line 807  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 823  w2 = ~w1; Line 815  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 844  f = FLAG($4==$5); Line 836  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 853  f = FLAG($4!=$5); Line 845  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 865  f = FLAG($4<$5); Line 857  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 897  f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); Line 889  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 1034  swap w1 w2 -- w2 w1  core Line 1026  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 1274  while(a_addr != NULL) Line 1266  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 1361  f_addr = (Float *)((((Cell)c_addr)+(size Line 1349  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 1675  else { Line 1665  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 1804  f**  r1 r2 -- r3 float-ext f_star_star Line 1795  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 1835  floor  r1 -- r2 float Line 1826  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 1845  r2 = floor(r1+0.5); Line 1836  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 1873  internal floating-point representation. Line 1864  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 1893  if((flag=FLAG(!(Cell)*endconv))) Line 1890  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 1903  else if(*endconv=='d' || *endconv=='D') Line 1900  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 1943  r2 = expm1(r1); Line 1940  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 1959  r2 = log1p(r1); Line 1956  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.37  
changed lines
  Added in v.1.42


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