version 1.252, 2010/07/11 19:56:00
|
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 612 SET_IP((Xt *)a_target);
|
Line 612 SET_IP((Xt *)a_target);
|
cell+ |
cell+ |
THEN >r ; |
THEN >r ; |
|
|
|
(try1) ( ... a_oldhandler a_recovery -- R:a_recovery R:a_sp R:f_fp R:c_lp R:a_oldhandler a_newhandler ) gforth paren_try1 |
|
a_sp = sp-1; |
|
f_fp = fp; |
|
c_lp = lp; |
|
a_newhandler = rp-5; |
|
|
|
(throw1) ( ... wball a_handler -- ... wball ) gforth paren_throw1 |
|
rp = a_handler; |
|
lp = (Address)rp[1]; |
|
fp = (Float *)rp[2]; |
|
sp = (Cell *)rp[3]; |
|
#ifndef NO_IP |
|
ip=IP; |
|
#endif |
|
SUPER_END; |
|
VM_JUMP(EXEC1(*(Xt *)rp[4])); |
|
|
|
|
\+ |
\+ |
|
|
\ don't make any assumptions where the return stack is!! |
\ don't make any assumptions where the return stack is!! |
Line 1085 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 1786 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 2013 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 2104 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 2146 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 2201 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 2212 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 2228 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 2251 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 2504 c_addr[1] = w >> 16;
|
Line 2595 c_addr[1] = w >> 16;
|
c_addr[2] = w >> 8; |
c_addr[2] = w >> 8; |
c_addr[3] = w; |
c_addr[3] = w; |
|
|
be-x! ( w c_addr -- ) gforth x_store_be |
|
""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" |
|
c_addr[0] = w >> 56; |
|
c_addr[1] = w >> 48; |
|
c_addr[2] = w >> 40; |
|
c_addr[3] = w >> 32; |
|
c_addr[4] = w >> 24; |
|
c_addr[5] = w >> 16; |
|
c_addr[6] = w >> 8; |
|
c_addr[7] = w; |
|
|
|
le-w! ( w c_addr -- ) gforth w_store_le |
le-w! ( w c_addr -- ) gforth w_store_le |
""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" |
""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" |
c_addr[1] = w >> 8; |
c_addr[1] = w >> 8; |
Line 2527 c_addr[2] = w >> 16;
|
Line 2607 c_addr[2] = w >> 16;
|
c_addr[1] = w >> 8; |
c_addr[1] = w >> 8; |
c_addr[0] = w; |
c_addr[0] = w; |
|
|
le-x! ( w c_addr -- ) gforth x_store_le |
be-uw@ ( c_addr -- u ) gforth w_fetch_be |
|
""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}."" |
|
u = (c_addr[0] << 8) | (c_addr[1]); |
|
|
|
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}."" |
|
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 |
|
""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" |
|
u = (c_addr[1] << 8) | (c_addr[0]); |
|
|
|
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}."" |
|
u = ((Cell)c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); |
|
|
|
\+64bit |
|
|
|
x! ( w c_addr -- ) gforth x_store |
|
""Store the bottom 64 bits of @i{w} at 64-bit-aligned @i{c_addr}."" |
|
*(UOctabyte *)c_addr = w; |
|
|
|
ux@ ( c_addr -- u ) gforth u_x_fetch |
|
""@i{u} is the zero-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" |
|
u = *(UOctabyte *)c_addr; |
|
|
|
sx@ ( c_addr -- n ) gforth s_x_fetch |
|
""@i{u} is the sign-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" |
|
n = *(Octabyte *)c_addr; |
|
|
|
be-x! ( w c_addr -- ) gforth b_e_x_store |
|
""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" |
|
c_addr[0] = w >> 56; |
|
c_addr[1] = w >> 48; |
|
c_addr[2] = w >> 40; |
|
c_addr[3] = w >> 32; |
|
c_addr[4] = w >> 24; |
|
c_addr[5] = w >> 16; |
|
c_addr[6] = w >> 8; |
|
c_addr[7] = w; |
|
|
|
le-x! ( w c_addr -- ) gforth l_e_x_store |
""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" |
""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" |
c_addr[7] = w >> 56; |
c_addr[7] = w >> 56; |
c_addr[6] = w >> 48; |
c_addr[6] = w >> 48; |
Line 2538 c_addr[2] = w >> 16;
|
Line 2659 c_addr[2] = w >> 16;
|
c_addr[1] = w >> 8; |
c_addr[1] = w >> 8; |
c_addr[0] = w; |
c_addr[0] = w; |
|
|
be-w@ ( c_addr -- u ) gforth w_fetch_be |
be-ux@ ( c_addr -- u ) gforth b_e_u_x_fetch |
""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}."" |
|
u = (c_addr[0] << 8) | (c_addr[1]); |
|
|
|
be-l@ ( c_addr -- u ) gforth l_fetch_be |
|
""@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]); |
|
|
|
be-x@ ( c_addr -- u ) gforth x_fetch_be |
|
""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" |
""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" |
u = (((Cell)(c_addr[0]) << 56) | |
u = (((Cell)(c_addr[0]) << 56) | |
((Cell)(c_addr[1]) << 48) | |
((Cell)(c_addr[1]) << 48) | |
Line 2557 u = (((Cell)(c_addr[0]) << 56) |
|
Line 2670 u = (((Cell)(c_addr[0]) << 56) |
|
((Cell)(c_addr[6]) << 8) | |
((Cell)(c_addr[6]) << 8) | |
((Cell)(c_addr[7]))); |
((Cell)(c_addr[7]))); |
|
|
le-w@ ( c_addr -- u ) gforth w_fetch_le |
le-ux@ ( c_addr -- u ) gforth l_e_u_x_fetch |
""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" |
|
u = (c_addr[1] << 8) | (c_addr[0]); |
|
|
|
le-l@ ( c_addr -- u ) gforth l_fetch_le |
|
""@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]); |
|
|
|
le-x@ ( c_addr -- u ) gforth x_fetch_le |
|
""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}."" |
""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}."" |
u = (((Cell)(c_addr[7]) << 56) | |
u = (((Cell)(c_addr[7]) << 56) | |
((Cell)(c_addr[6]) << 48) | |
((Cell)(c_addr[6]) << 48) | |
Line 2577 u = (((Cell)(c_addr[7]) << 56) |
|
Line 2682 u = (((Cell)(c_addr[7]) << 56) |
|
((Cell)(c_addr[0]))); |
((Cell)(c_addr[0]))); |
|
|
\+ |
\+ |
|
\+ |
\g peephole |
\g peephole |
|
|
\+peephole |
\+peephole |