### Diff for /gforth/prim between versions 1.32 and 1.41

version 1.32, 1999/05/15 20:00:21 version 1.41, 1999/12/03 18:24:22
Line 445  n = rp[4]; Line 445  n = rp[4];
\ 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}
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}
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 767  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 806  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 814  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 835  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 844  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 856  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 888  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 1025  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@ @ ;

[ 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).""
:  :
2 cells + ;      2 cells + ;

\+standardthreading  \ threading stuff is currently only interesting if we have a compiler
\fhas? standardthreading has? compiler and [IF]

Line 1414  n=1; Line 1418  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 1661  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
#endif

emit-file       c wfileid -- wior       gforth  emit_file  emit-file       c wfileid -- wior       gforth  emit_file
#ifdef HAS_FILE  #ifdef HAS_FILE
Line 1680  wior = FILEIO(putc(c, (FILE *)wfileid)== Line 1685  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 1790  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

"" 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 1821  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 1831  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 1859  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;
Line 1893  else if(*endconv=='d' || *endconv=='D') Line 1898  else if(*endconv=='d' || *endconv=='D')
}       }
}  }

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 1929  r2 = expm1(r1); Line 1934  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 1945  r2 = log1p(r1); Line 1950  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/
:  :
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.32 changed lines Added in v.1.41

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