version 1.256, 2010/09/01 16:52:12
|
version 1.266, 2012/03/10 20:33:31
|
Line 1
|
Line 1
|
\ Gforth primitives |
\ Gforth primitives |
|
|
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 1103 lshift ( u1 n -- u2 ) core l_shift
|
Line 1103 lshift ( u1 n -- u2 ) core l_shift
|
: |
: |
0 ?DO 2* LOOP ; |
0 ?DO 2* LOOP ; |
|
|
|
umax ( u1 u2 -- u ) core |
|
if (u1<u2) |
|
u = u2; |
|
else |
|
u = u1; |
|
: |
|
2dup u< IF swap THEN drop ; |
|
|
|
umin ( u1 u2 -- u ) core |
|
if (u1<u2) |
|
u = u1; |
|
else |
|
u = u2; |
|
: |
|
2dup u> IF swap THEN drop ; |
|
|
\g compare |
\g compare |
|
|
\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
Line 1804 if (a_addr1==NULL)
|
Line 1820 if (a_addr1==NULL)
|
else |
else |
a_addr2 = (Cell *)realloc(a_addr1, u); |
a_addr2 = (Cell *)realloc(a_addr1, u); |
wior = IOR(a_addr2==NULL); /* !! Define a return code */ |
wior = IOR(a_addr2==NULL); /* !! Define a return code */ |
|
if (a_addr2==NULL) |
|
a_addr2 = a_addr1; |
|
|
strerror ( n -- c_addr u ) gforth |
strerror ( n -- c_addr u ) gforth |
c_addr = (Char *)strerror(n); |
c_addr = (Char *)strerror(n); |
Line 2031 duser = timeval2us(&time1);
|
Line 2049 duser = timeval2us(&time1);
|
dsystem = DZERO; |
dsystem = DZERO; |
#endif |
#endif |
|
|
|
ntime ( -- dtime ) gforth |
|
""Report the current time in nanoseconds since some epoch."" |
|
struct timespec time1; |
|
#ifdef HAVE_CLOCK_GETTIME |
|
clock_gettime(CLOCK_REALTIME,&time1); |
|
#else |
|
struct timeval time2; |
|
gettimeofday(&time2,NULL); |
|
time1.tv_sec = time2.tv_sec;1 |
|
time1.tv_nsec = time2.tv_usec*1000; |
|
#endif |
|
dtime = timespec2ns(&time1); |
|
|
\+ |
\+ |
|
|
\+floating |
\+floating |
Line 2122 r3 = r1/r2;
|
Line 2153 r3 = r1/r2;
|
|
|
f** ( r1 r2 -- r3 ) float-ext f_star_star |
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."" |
|
CLOBBER_TOS_WORKAROUND_START; |
r3 = pow(r1,r2); |
r3 = pow(r1,r2); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fm* ( r1 n -- r2 ) gforth fm_star |
fm* ( r1 n -- r2 ) gforth fm_star |
r2 = r1*n; |
r2 = r1*n; |
Line 2164 n2 = n1*sizeof(Float);
|
Line 2197 n2 = n1*sizeof(Float);
|
floor ( r1 -- r2 ) float |
floor ( r1 -- r2 ) float |
""Round towards the next smaller integral value, i.e., round toward negative infinity."" |
""Round towards the next smaller integral value, i.e., round toward negative infinity."" |
/* !! unclear wording */ |
/* !! unclear wording */ |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = floor(r1); |
r2 = floor(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fround ( r1 -- r2 ) float f_round |
fround ( r1 -- r2 ) float f_round |
""Round to the nearest integral value."" |
""Round to the nearest integral value."" |
Line 2219 fabs ( r1 -- r2 ) float-ext f_abs
|
Line 2254 fabs ( r1 -- r2 ) float-ext f_abs
|
r2 = fabs(r1); |
r2 = fabs(r1); |
|
|
facos ( r1 -- r2 ) float-ext f_a_cos |
facos ( r1 -- r2 ) float-ext f_a_cos |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = acos(r1); |
r2 = acos(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fasin ( r1 -- r2 ) float-ext f_a_sine |
fasin ( r1 -- r2 ) float-ext f_a_sine |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = asin(r1); |
r2 = asin(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fatan ( r1 -- r2 ) float-ext f_a_tan |
fatan ( r1 -- r2 ) float-ext f_a_tan |
r2 = atan(r1); |
r2 = atan(r1); |
Line 2230 r2 = atan(r1);
|
Line 2269 r2 = atan(r1);
|
fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two |
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."" |
|
CLOBBER_TOS_WORKAROUND_START; |
r3 = atan2(r1,r2); |
r3 = atan2(r1,r2); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fcos ( r1 -- r2 ) float-ext f_cos |
fcos ( r1 -- r2 ) float-ext f_cos |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = cos(r1); |
r2 = cos(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fexp ( r1 -- r2 ) float-ext f_e_x_p |
fexp ( r1 -- r2 ) float-ext f_e_x_p |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = exp(r1); |
r2 = exp(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one |
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"" |
Line 2246 extern double
|
Line 2291 extern double
|
const |
const |
#endif |
#endif |
expm1(double); |
expm1(double); |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = expm1(r1); |
r2 = expm1(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
#else |
#else |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = exp(r1)-1.; |
r2 = exp(r1)-1.; |
|
CLOBBER_TOS_WORKAROUND_END; |
#endif |
#endif |
|
|
fln ( r1 -- r2 ) float-ext f_l_n |
fln ( r1 -- r2 ) float-ext f_l_n |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = log(r1); |
r2 = log(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one |
flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one |
""@i{r2}=ln(@i{r1}+1)"" |
""@i{r2}=ln(@i{r1}+1)"" |
Line 2269 r2 = log(r1+1.);
|
Line 2320 r2 = log(r1+1.);
|
|
|
flog ( r1 -- r2 ) float-ext f_log |
flog ( r1 -- r2 ) float-ext f_log |
""The decimal logarithm."" |
""The decimal logarithm."" |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = log10(r1); |
r2 = log10(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
falog ( r1 -- r2 ) float-ext f_a_log |
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); |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = pow10(r1); |
r2 = pow10(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fsin ( r1 -- r2 ) float-ext f_sine |
fsin ( r1 -- r2 ) float-ext f_sine |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = sin(r1); |
r2 = sin(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos |
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})"" |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = sin(r1); |
r2 = sin(r1); |
r3 = cos(r1); |
r3 = cos(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
|
|
fsqrt ( r1 -- r2 ) float-ext f_square_root |
fsqrt ( r1 -- r2 ) float-ext f_square_root |
r2 = sqrt(r1); |
r2 = sqrt(r1); |
|
|
ftan ( r1 -- r2 ) float-ext f_tan |
ftan ( r1 -- r2 ) float-ext f_tan |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = tan(r1); |
r2 = tan(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
fsincos f/ ; |
fsincos f/ ; |
|
|
fsinh ( r1 -- r2 ) float-ext f_cinch |
fsinh ( r1 -- r2 ) float-ext f_cinch |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = sinh(r1); |
r2 = sinh(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
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 f_cosh |
fcosh ( r1 -- r2 ) float-ext f_cosh |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = cosh(r1); |
r2 = cosh(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
fexp fdup 1/f f+ f2/ ; |
fexp fdup 1/f f+ f2/ ; |
|
|
ftanh ( r1 -- r2 ) float-ext f_tan_h |
ftanh ( r1 -- r2 ) float-ext f_tan_h |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = tanh(r1); |
r2 = tanh(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
f2* fexpm1 fdup 2. d>f f+ f/ ; |
f2* fexpm1 fdup 2. d>f f+ f/ ; |
|
|
fasinh ( r1 -- r2 ) float-ext f_a_cinch |
fasinh ( r1 -- r2 ) float-ext f_a_cinch |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = asinh(r1); |
r2 = asinh(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
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 f_a_cosh |
facosh ( r1 -- r2 ) float-ext f_a_cosh |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = acosh(r1); |
r2 = acosh(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
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 f_a_tan_h |
fatanh ( r1 -- r2 ) float-ext f_a_tan_h |
|
CLOBBER_TOS_WORKAROUND_START; |
r2 = atanh(r1); |
r2 = atanh(r1); |
|
CLOBBER_TOS_WORKAROUND_END; |
: |
: |
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/ |
r> IF fnegate THEN ; |
r> IF fnegate THEN ; |
Line 2540 u = (c_addr[0] << 8) | (c_addr[1]);
|
Line 2613 u = (c_addr[0] << 8) | (c_addr[1]);
|
|
|
be-ul@ ( c_addr -- u ) gforth l_fetch_be |
be-ul@ ( c_addr -- u ) gforth l_fetch_be |
""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}."" |
""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}."" |
u = (c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); |
u = ((Cell)c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); |
|
|
le-uw@ ( c_addr -- u ) gforth w_fetch_le |
le-uw@ ( c_addr -- u ) gforth w_fetch_le |
""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" |
""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" |
Line 2548 u = (c_addr[1] << 8) | (c_addr[0]);
|
Line 2621 u = (c_addr[1] << 8) | (c_addr[0]);
|
|
|
le-ul@ ( c_addr -- u ) gforth l_fetch_le |
le-ul@ ( c_addr -- u ) gforth l_fetch_le |
""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}."" |
""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}."" |
u = (c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); |
u = ((Cell)c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); |
|
|
\+64bit |
\+64bit |
|
|