version 1.30, 1999/05/09 21:21:55
|
version 1.43, 2000/03/11 20:35:05
|
Line 129 EXEC(*(Xt *)a_addr);
|
Line 129 EXEC(*(Xt *)a_addr);
|
: |
: |
@ execute ; |
@ execute ; |
|
|
|
\fhas? skipbranchprims 0= [IF] |
\+glocals |
\+glocals |
|
|
branch-lp+!# -- gforth branch_lp_plus_store_number |
branch-lp+!# -- gforth branch_lp_plus_store_number |
Line 208 else
|
Line 209 else
|
INC_IP(1); |
INC_IP(1); |
|
|
\+ |
\+ |
|
\f[THEN] |
|
\fhas? skiploopprims 0= [IF] |
|
|
condbranch((next),-- cmFORTH paren_next, |
condbranch((next),-- cmFORTH paren_next, |
if ((*rp)--) { |
if ((*rp)--) { |
Line 437 n = rp[4];
|
Line 440 n = rp[4];
|
r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; |
r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; |
[IFUNDEF] itmp variable itmp [THEN] |
[IFUNDEF] itmp variable itmp [THEN] |
|
|
|
\f[THEN] |
|
|
\ 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} |
from low address to high address."" |
from low address to high address; i.e., for overlapping areas it is |
|
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} |
from high address to low address."" |
from high address to low address; i.e., for overlapping areas it is |
|
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 490 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 508 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 713 ud = (UDCell)u1 * (UDCell)u2;
|
Line 716 ud = (UDCell)u1 * (UDCell)u2;
|
and >r >r 2dup d+ swap r> + swap r> ; |
and >r >r 2dup d+ swap r> + swap r> ; |
|
|
um/mod ud u1 -- u2 u3 core u_m_slash_mod |
um/mod ud u1 -- u2 u3 core u_m_slash_mod |
|
""ud=u3*u1+u2, u1>u2>=0"" |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
UDCell r = umdiv(ud,u1); |
UDCell r = umdiv(ud,u1); |
u2=r.hi; |
u2=r.hi; |
Line 761 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 800 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 808 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 829 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 838 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 850 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 882 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 928 dcomparisons(du, ud1 ud2, d_u_, ud1, ud2
|
Line 932 dcomparisons(du, ud1 ud2, d_u_, ud1, ud2
|
\+ |
\+ |
|
|
within u1 u2 u3 -- f core-ext |
within u1 u2 u3 -- f core-ext |
|
""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for |
|
unsigned and signed numbers (but not a mixture). Another way to think |
|
about this word is to consider the numbers as a circle (wrapping |
|
around from @code{max-u} to 0 for unsigned, and from @code{max-n} to |
|
min-n for signed numbers); now consider the range from u2 towards |
|
increasing numbers up to and excluding u3 (giving an empty range if |
|
u2=u3; if u1 is in this range, @code{within} returns true."" |
f = FLAG(u1-u2 < u3-u2); |
f = FLAG(u1-u2 < u3-u2); |
: |
: |
over - >r - r> u< ; |
over - >r - r> u< ; |
Line 1012 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 1335 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 + ; |
|
|
\+standardthreading |
\ threading stuff is currently only interesting if we have a compiler |
|
\fhas? standardthreading has? compiler and [IF] |
|
|
>code-address xt -- c_addr gforth to_code_address |
>code-address xt -- c_addr gforth to_code_address |
""@i{c-addr} is the code address of the word @i{xt}."" |
""@i{c-addr} is the code address of the word @i{xt}."" |
Line 1401 n=1;
|
Line 1415 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 1648 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 1667 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 1777 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 1808 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 1818 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 1846 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 1866 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 1876 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 1916 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 1932 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/ |
Line 2164 UP=up=(char *)a_addr;
|
Line 2185 UP=up=(char *)a_addr;
|
: |
: |
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]); |
|
|