version 1.35, 1999/05/20 13:38:02
|
version 1.46, 2000/05/31 14:37:40
|
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."" |
|
/* close ' to keep fontify happy */ |
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
if (n==0) |
if (n==0) |
n = u1-u2; |
n = u1-u2; |
Line 496 if (n<0)
|
Line 497 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 514 else if (n>0)
|
Line 512 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 768 d = d1-d2;
|
Line 766 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 807 w = w1|w2;
|
Line 805 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 815 w2 = ~w1;
|
Line 813 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 836 f = FLAG($4==$5);
|
Line 834 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 845 f = FLAG($4!=$5);
|
Line 843 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 857 f = FLAG($4<$5);
|
Line 855 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 889 f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
|
Line 887 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 1026 swap w1 w2 -- w2 w1 core
|
Line 1024 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 1349 f_addr = (Float *)((((Cell)c_addr)+(size
|
Line 1347 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 1485 getenv c_addr1 u1 -- c_addr2 u2 gforth
|
Line 1485 getenv c_addr1 u1 -- c_addr2 u2 gforth
|
is the host operating system's expansion of that environment variable. If the |
is the host operating system's expansion of that environment variable. If the |
environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters |
environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters |
in length."" |
in length."" |
|
/* close ' to keep fontify happy */ |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
Line 1497 wretval = pclose((FILE *)wfileid);
|
Line 1498 wretval = pclose((FILE *)wfileid);
|
wior = IOR(wretval==-1); |
wior = IOR(wretval==-1); |
|
|
time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
|
""Report the current time of day. Seconds, minutes and hours are numbered from 0. |
|
Months are numbered from 1."" |
struct timeval time1; |
struct timeval time1; |
struct timezone zone1; |
struct timezone zone1; |
struct tm *ltime; |
struct tm *ltime; |
Line 1510 nmin =ltime->tm_min;
|
Line 1513 nmin =ltime->tm_min;
|
nsec =ltime->tm_sec; |
nsec =ltime->tm_sec; |
|
|
ms n -- facility-ext |
ms n -- facility-ext |
|
""Wait at least @i{n} milli-second."" |
struct timeval timeout; |
struct timeval timeout; |
timeout.tv_sec=n/1000; |
timeout.tv_sec=n/1000; |
timeout.tv_usec=1000*(n%1000); |
timeout.tv_usec=1000*(n%1000); |
Line 1543 I/O result code. If @i{a-addr1} is 0, Gf
|
Line 1547 I/O result code. If @i{a-addr1} is 0, Gf
|
@code{resize} @code{allocate}s @i{u} address units."" |
@code{resize} @code{allocate}s @i{u} address units."" |
/* the following check is not necessary on most OSs, but it is needed |
/* the following check is not necessary on most OSs, but it is needed |
on SunOS 4.1.2. */ |
on SunOS 4.1.2. */ |
|
/* close ' to keep fontify happy */ |
if (a_addr1==NULL) |
if (a_addr1==NULL) |
a_addr2 = (Cell *)malloc(u); |
a_addr2 = (Cell *)malloc(u); |
else |
else |
Line 1634 if (wior)
|
Line 1639 if (wior)
|
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
|
|
read-line c_addr u1 wfileid -- u2 flag wior file read_line |
read-line c_addr u1 wfileid -- u2 flag wior file read_line |
/* |
#if 1 |
Cell c; |
Cell c; |
flag=-1; |
flag=-1; |
for(u2=0; u2<u1; u2++) |
for(u2=0; u2<u1; u2++) |
{ |
{ |
*c_addr++ = (Char)(c = getc((FILE *)wfileid)); |
c = getc((FILE *)wfileid); |
if(c=='\n') break; |
if (c=='\n') break; |
if(c==EOF) |
if (c=='\r') { |
{ |
if ((c = getc((FILE *)wfileid))!='\n') |
|
ungetc(c,(FILE *)wfileid); |
|
break; |
|
} |
|
if (c==EOF) { |
flag=FLAG(u2!=0); |
flag=FLAG(u2!=0); |
break; |
break; |
} |
} |
|
c_addr[u2] = (Char)c; |
} |
} |
wior=FILEIO(ferror((FILE *)wfileid)); |
wior=FILEIO(ferror((FILE *)wfileid)); |
*/ |
#else |
if ((flag=FLAG(!feof((FILE *)wfileid) && |
if ((flag=FLAG(!feof((FILE *)wfileid) && |
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ |
wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ |
Line 1661 else {
|
Line 1671 else {
|
wior=0; |
wior=0; |
u2=0; |
u2=0; |
} |
} |
|
#endif |
|
|
\+ |
\+ |
\+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 1682 wior = FILEIO(putc(c, (FILE *)wfileid)==
|
Line 1694 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 1792 f** r1 r2 -- r3 float-ext f_star_star
|
Line 1804 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 1823 floor r1 -- r2 float
|
Line 1835 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 1833 r2 = floor(r1+0.5);
|
Line 1845 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 1861 internal floating-point representation.
|
Line 1873 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 1881 if((flag=FLAG(!(Cell)*endconv)))
|
Line 1899 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 1891 else if(*endconv=='d' || *endconv=='D')
|
Line 1909 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 1931 r2 = expm1(r1);
|
Line 1949 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 1947 r2 = log1p(r1);
|
Line 1965 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 2139 rret = (SYSCALL(Float(*)(argdlist($1)))u
|
Line 2157 rret = (SYSCALL(Float(*)(argdlist($1)))u
|
|
|
') |
') |
|
|
|
\ close ' to keep fontify happy |
|
|
open-lib c_addr1 u1 -- u2 gforth open_lib |
open-lib c_addr1 u1 -- u2 gforth open_lib |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
Line 2188 fp=FP;
|
Line 2207 fp=FP;
|
IF_TOS(TOS=sp[0];) |
IF_TOS(TOS=sp[0];) |
IF_FTOS(FTOS=fp[0]); |
IF_FTOS(FTOS=fp[0]); |
|
|
|
\+file |
|
|
|
open-dir c_addr u -- wdirid wior gforth open_dir |
|
wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1)); |
|
wior = IOR(wdirid == 0); |
|
|
|
read-dir c_addr u1 wdirid -- u2 flag wior gforth read_dir |
|
struct dirent * dent; |
|
dent = readdir((DIR *)wdirid); |
|
wior = 0; |
|
flag = -1; |
|
if(dent == NULL) { |
|
u2 = 0; |
|
flag = 0; |
|
} else { |
|
u2 = strlen(dent->d_name); |
|
if(u2 > u1) |
|
u2 = u1; |
|
memmove(c_addr, dent->d_name, u2); |
|
} |
|
|
|
close-dir wdirid -- wior gforth close_dir |
|
wior = IOR(closedir((DIR *)wdirid)); |
|
|
|
filename-match c_addr1 u1 c_addr2 u2 -- flag gforth match_file |
|
char * string = cstr(c_addr1, u1, 1); |
|
char * pattern = cstr(c_addr2, u2, 0); |
|
flag = FLAG(!fnmatch(pattern, string, 0)); |
|
|
|
\+ |
|
|
|
newline -- c_addr u gforth |
|
""String containing the newline sequence of the host OS"" |
|
char newline[] = { |
|
#ifdef unix |
|
'\n' |
|
#else |
|
'\r','\n' |
|
#endif |
|
}; |
|
c_addr=newline; |
|
u=sizeof(newline); |