--- gforth/prim 1999/02/16 06:32:30 1.24 +++ gforth/prim 2000/05/16 09:51:21 1.45 @@ -115,7 +115,7 @@ INC_IP(1); r> dup @ swap cell+ >r ; execute xt -- core -""Perform the semantics represented by the execution token, xt."" +""Perform the semantics represented by the execution token, @i{xt}."" ip=IP; IF_TOS(TOS = sp[0]); EXEC(xt); @@ -129,6 +129,7 @@ EXEC(*(Xt *)a_addr); : @ execute ; +\fhas? skipbranchprims 0= [IF] \+glocals branch-lp+!# -- gforth branch_lp_plus_store_number @@ -208,6 +209,8 @@ else INC_IP(1); \+ +\f[THEN] +\fhas? skiploopprims 0= [IF] condbranch((next),-- cmFORTH paren_next, if ((*rp)--) { @@ -437,30 +440,33 @@ n = rp[4]; r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; [IFUNDEF] itmp variable itmp [THEN] +\f[THEN] + \ digit is high-level: 0/0% move c_from c_to ucount -- core -"" If ucount>0, copy the contents of ucount address units -at c-from to c-to. @code{move} chooses its copy direction -to avoid problems when c-from, c-to overlap."" +""Copy the contents of @i{ucount} address units at @i{c-from} to +@i{c-to}. @code{move} works correctly even if the two areas overlap."" memmove(c_to,c_from,ucount); /* make an Ifdef for bsd and others? */ : >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; -cmove c_from c_to u -- string -"" If u>0, copy the contents of ucount characters from -data space at c-from to c-to. The copy proceeds @code{char}-by-@code{char} -from low address to high address."" +cmove c_from c_to u -- string c_move +""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} +from low address to high address; i.e., for overlapping areas it is +safe if @i{c-to}=<@i{c-from}."" while (u-- > 0) *c_to++ = *c_from++; : bounds ?DO dup c@ I c! 1+ LOOP drop ; cmove> c_from c_to u -- string c_move_up -"" If u>0, copy the contents of ucount characters from -data space at c-from to c-to. The copy proceeds @code{char}-by-@code{char} -from high address to low address."" +""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} +from high address to low address; i.e., for overlapping areas it is +safe if @i{c-to}>=@i{c-from}."" while (u-- > 0) c_to[u] = c_from[u]; : @@ -469,18 +475,18 @@ while (u-- > 0) DO 1- dup c@ I c! -1 +LOOP drop ; fill c_addr u c -- core -"" If u>0, store character c in each of u consecutive -@code{char} addresses in memory, starting at address c-addr."" +"" If @i{u}>0, store character @i{c} in each of @i{u} consecutive +@code{char} addresses in memory, starting at address @i{c-addr}."" memset(c_addr,c,u); : -rot bounds ?DO dup I c! LOOP drop ; compare c_addr1 u1 c_addr2 u2 -- n string -""Compare two strings lexicographically. If they are equal, n is 0; if -the first string is smaller, n is -1; if the first string is larger, n +""Compare two strings lexicographically. If they are equal, @i{n} is 0; if +the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} is 1. Currently this is based on the machine's character -comparison. In the future, this may change to considering the current +comparison. In the future, this may change to consider the current locale and its collation order."" n = memcmp(c_addr1, c_addr2, u10) n = 1; : - rot 2dup - >r min swap -text dup - IF rdrop - ELSE drop r@ 0> - IF rdrop -1 - ELSE r> 1 and - THEN - THEN ; + rot 2dup swap - >r min swap -text dup + IF rdrop ELSE drop r> sgn THEN ; +: sgn ( n -- -1/0/1 ) + dup 0= IF EXIT THEN 0< 2* 1+ ; -text c_addr1 u c_addr2 -- n new dash_text n = memcmp(c_addr1, c_addr2, u); @@ -508,12 +511,12 @@ else if (n>0) swap bounds ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 ELSE c@ I c@ - unloop THEN -text-flag ; -: -text-flag ( n -- -1/0/1 ) - dup 0< IF drop -1 ELSE 0> 1 and THEN ; +: sgn ( n -- -1/0/1 ) + dup 0= IF EXIT THEN 0< 2* 1+ ; toupper c1 -- c2 gforth -""For a character a-z, convert to the equivalent upper-case -character. All other characters are unchanged."" +""If @i{c1} is a lower-case character (in the current locale), @i{c2} +is the equivalent upper-case character. All other characters are unchanged."" c2 = toupper(c1); : dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; @@ -532,6 +535,8 @@ else if (n>0) ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; -trailing c_addr u1 -- c_addr u2 string dash_trailing +""Adjust the string specified by @i{c-addr, u1} to remove all trailing +spaces. @i{u2} is the length of the modified string."" u2 = u1; while (u2>0 && c_addr[u2-1] == ' ') u2--; @@ -540,6 +545,8 @@ while (u2>0 && c_addr[u2-1] == ' ') dup 0= UNTIL ELSE 1+ THEN ; /string c_addr1 u1 n -- c_addr2 u2 string slash_string +""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} +characters from the start of the string."" c_addr2 = c_addr1+n; u2 = u1-n; : @@ -550,7 +557,7 @@ n = n1+n2; \ PFE-0.9.14 has it differently, but the next release will have it as follows under+ n1 n2 n3 -- n n2 gforth under_plus -""add @var{n3} to @var{n1} (giving @var{n})"" +""add @i{n3} to @i{n1} (giving @i{n})"" n = n1+n3; : rot + swap ; @@ -637,7 +644,7 @@ n2 = n1>>1; LOOP nip ; fm/mod d1 n1 -- n2 n3 core f_m_slash_mod -""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1"" +""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}."" #ifdef BUGGY_LONG_LONG DCell r = fmdiv(d1,n1); n2=r.hi; @@ -659,7 +666,7 @@ if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) r> 0< IF swap negate swap THEN ; sm/rem d1 n1 -- n2 n3 core s_m_slash_rem -""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0"" +""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0."" #ifdef BUGGY_LONG_LONG DCell r = smdiv(d1,n1); n2=r.hi; @@ -709,6 +716,7 @@ ud = (UDCell)u1 * (UDCell)u2; and >r >r 2dup d+ swap r> + swap r> ; um/mod ud u1 -- u2 u3 core u_m_slash_mod +""ud=u3*u1+u2, u1>u2>=0"" #ifdef BUGGY_LONG_LONG UDCell r = umdiv(ud,u1); u2=r.hi; @@ -757,7 +765,7 @@ d = d1-d2; : dnegate d+ ; -dnegate d1 -- d2 double +dnegate d1 -- d2 double d_negate /* use dminus as alias */ #ifdef BUGGY_LONG_LONG d2 = dnegate(d1); @@ -796,7 +804,7 @@ w = w1|w2; : invert swap invert and invert ; -xor w1 w2 -- w core +xor w1 w2 -- w core x_or w = w1^w2; invert w1 -- w2 core @@ -804,12 +812,12 @@ w2 = ~w1; : MAXU xor ; -rshift u1 n -- u2 core +rshift u1 n -- u2 core r_shift u2 = u1>>n; : 0 ?DO 2/ MAXI and LOOP ; -lshift u1 n -- u2 core +lshift u1 n -- u2 core l_shift u2 = u1< $2 -- f $7 $3different +$1<> $2 -- f $7 $3not_equals f = FLAG($4!=$5); : [ char $1x char 0 = [IF] @@ -834,7 +842,7 @@ f = FLAG($4!=$5); ] xor 0<> [ [THEN] ] ; -$1< $2 -- f $8 $3less +$1< $2 -- f $8 $3less_than f = FLAG($4<$5); : [ char $1x char 0 = [IF] @@ -846,7 +854,7 @@ f = FLAG($4<$5); [THEN] [THEN] ] ; -$1> $2 -- f $9 $3greater +$1> $2 -- f $9 $3greater_than f = FLAG($4>$5); : [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] @@ -878,21 +886,21 @@ f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); f = FLAG($4==$5); #endif -$1<> $2 -- f $7 $3different +$1<> $2 -- f $7 $3not_equals #ifdef BUGGY_LONG_LONG f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); #else f = FLAG($4!=$5); #endif -$1< $2 -- f $8 $3less +$1< $2 -- f $8 $3less_than #ifdef BUGGY_LONG_LONG f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); #else f = FLAG($4<$5); #endif -$1> $2 -- f $9 $3greater +$1> $2 -- f $9 $3greater_than #ifdef BUGGY_LONG_LONG f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); #else @@ -924,21 +932,28 @@ dcomparisons(du, ud1 ud2, d_u_, ud1, ud2 \+ within u1 u2 u3 -- f core-ext +""u2=r - r> u< ; -sp@ -- a_addr gforth spat +sp@ -- a_addr gforth sp_fetch a_addr = sp+1; -sp! a_addr -- gforth spstore +sp! a_addr -- gforth sp_store sp = a_addr; /* works with and without TOS caching */ -rp@ -- a_addr gforth rpat +rp@ -- a_addr gforth rp_fetch a_addr = rp; -rp! a_addr -- gforth rpstore +rp! a_addr -- gforth rp_store rp = a_addr; \+floating @@ -1008,7 +1023,7 @@ swap w1 w2 -- w2 w1 core >r (swap) ! r> (swap) @ ; Variable (swap) -dup w -- w w core +dup w -- w w core dupe : sp@ @ ; @@ -1079,17 +1094,21 @@ w = sp[u+1]; \ toggle is high-level: 0.11/0.42% @ a_addr -- w core fetch +"" Read from the cell at address @i{a-addr}, and return its contents, @i{w}."" w = *a_addr; ! w a_addr -- core store +"" Write the value @i{w} to the cell at address @i{a-addr}."" *a_addr = w; +! n a_addr -- core plus_store +"" Add @i{n} to the value stored in the cell at address @i{a-addr}."" *a_addr += n; : tuck @ + swap ! ; -c@ c_addr -- c core cfetch +c@ c_addr -- c core c_fetch +"" Read from the char at address @i{c-addr}, and return its contents, @i{c}."" c = *c_addr; : [ bigendian [IF] ] @@ -1114,7 +1133,8 @@ c = *c_addr; ; : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; -c! c c_addr -- core cstore +c! c c_addr -- core c_store +"" Write the value @i{c} to the char at address @i{c-addr}."" *c_addr = c; : [ bigendian [IF] ] @@ -1144,23 +1164,28 @@ c! c c_addr -- core cstore : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; 2! w1 w2 a_addr -- core two_store +"" Write the value @i{w1, w2} to the double at address @i{a-addr}."" a_addr[0] = w2; a_addr[1] = w1; : tuck ! cell+ ! ; 2@ a_addr -- w1 w2 core two_fetch +"" Read from the double at address @i{a-addr}, and return its contents, @i{w1, w2}."" w2 = a_addr[0]; w1 = a_addr[1]; : dup cell+ @ swap @ ; cell+ a_addr1 -- a_addr2 core cell_plus +"" Increment @i{a-addr1} by the number of address units corresponding to the size of +one cell, to give @i{a-addr2}."" a_addr2 = a_addr1+1; : cell + ; cells n1 -- n2 core +"" @i{n2} is the number of address units corresponding to @i{n1} cells."" n2 = n1 * sizeof(Cell); : [ cell @@ -1170,19 +1195,21 @@ n2 = n1 * sizeof(Cell); 2/ dup [IF] ] 2* [ [THEN] drop ] ; -char+ c_addr1 -- c_addr2 core care_plus +char+ c_addr1 -- c_addr2 core char_plus +"" Increment @i{c-addr1} by the number of address units corresponding to the size of +one char, to give @i{c-addr2}."" c_addr2 = c_addr1 + 1; : 1+ ; -(chars) n1 -- n2 gforth paren_cares +(chars) n1 -- n2 gforth paren_chars n2 = n1 * sizeof(Char); : ; count c_addr1 -- c_addr2 u core -"" If c-add1 is the address of a counted string return the length of -the string, u, and the address of its first character, c-addr2."" +"" If @i{c-add1} is the address of a counted string return the length of +the string, @i{u}, and the address of its first character, @i{c-addr2}."" u = *c_addr1; c_addr2 = c_addr1+1; : @@ -1307,60 +1334,67 @@ else { REPEAT THEN nip - ; aligned c_addr -- a_addr core +"" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}."" a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); : [ cell 1- ] Literal + [ -1 cells ] Literal and ; faligned c_addr -- f_addr float f_aligned +"" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}."" f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); : [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; >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); : 2 cells + ; +\ 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 -""c_addr is the code address of the word xt"" +""@i{c-addr} is the code address of the word @i{xt}."" /* !! This behaves installation-dependently for DOES-words */ c_addr = (Address)CODE_ADDRESS(xt); : @ ; >does-code xt -- a_addr gforth to_does_code -""If xt ist the execution token of a defining-word-defined word, -a_addr is the start of the Forth code after the @code{DOES>}; -Otherwise a_addr is 0."" +""If @i{xt} is the execution token of a defining-word-defined word, +@i{a-addr} is the start of the Forth code after the @code{DOES>}; +Otherwise @i{a-addr} is 0."" a_addr = (Cell *)DOES_CODE(xt); : cell+ @ ; code-address! c_addr xt -- gforth code_address_store -""Creates a code field with code address c_addr at xt"" +""Create a code field with code address @i{c-addr} at @i{xt}."" MAKE_CF(xt, c_addr); CACHE_FLUSH(xt,(size_t)PFA(0)); : ! ; does-code! a_addr xt -- gforth does_code_store -""creates a code field at xt for a defining-word-defined word; a_addr -is the start of the Forth code after DOES>"" +""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr} +is the start of the Forth code after @code{DOES>}."" MAKE_DOES_CF(xt, a_addr); CACHE_FLUSH(xt,(size_t)PFA(0)); : dodoes: over ! cell+ ! ; does-handler! a_addr -- gforth does_handler_store -""creates a DOES>-handler at address a_addr. a_addr usually points -just behind a DOES>."" +""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points +just behind a @code{DOES>}."" MAKE_DOES_HANDLER(a_addr); CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); : drop ; /does-handler -- n gforth slash_does_handler -""the size of a does-handler (includes possible padding)"" +""The size of a @code{DOES>}-handler (includes possible padding)."" /* !! a constant or environmental query might be better */ n = DOES_HANDLER_SIZE; : @@ -1381,6 +1415,8 @@ n=1; : 1 ; +\f[THEN] + key-file wfileid -- n gforth paren_key_file #ifdef HAS_FILE fflush(stdout); @@ -1418,7 +1454,7 @@ ucols=cols; flush-icache c_addr u -- gforth flush_icache ""Make sure that the instruction cache of the processor (if there is -one) does not contain stale data at @var{c_addr} and @var{u} bytes +one) does not contain stale data at @i{c-addr} and @i{u} bytes afterwards. @code{END-CODE} performs a @code{flush-icache} automatically. Caveat: @code{flush-icache} might not work on your installation; this is usually the case if direct threading is not @@ -1444,9 +1480,9 @@ if (old_tp) #endif getenv c_addr1 u1 -- c_addr2 u2 gforth -""The string c-addr1 u1 specifies an environment variable. The string c-addr2 u2 +""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2} is the host operating system's expansion of that environment variable. If the -environment variable does not exist, c-addr2 u2 specifies a string 0 characters +environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters in length."" c_addr2 = getenv(cstr(c_addr1,u1,1)); u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); @@ -1460,6 +1496,8 @@ wretval = pclose((FILE *)wfileid); wior = IOR(wretval==-1); 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 timezone zone1; struct tm *ltime; @@ -1473,25 +1511,38 @@ nmin =ltime->tm_min; nsec =ltime->tm_sec; ms n -- facility-ext +""Wait at least @i{n} milli-second."" struct timeval timeout; timeout.tv_sec=n/1000; timeout.tv_usec=1000*(n%1000); (void)select(0,0,0,0,&timeout); allocate u -- a_addr wior memory +""Allocate @i{u} address units of contiguous data space. The initial +contents of the data space is undefined. If the allocation is successful, +@i{a-addr} is the start address of the allocated region and @i{wior} +is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior} +is an implementation-defined I/O result code."" a_addr = (Cell *)malloc(u?u:1); wior = IOR(a_addr==NULL); free a_addr -- wior memory +""Return the region of data space starting at @i{a-addr} to the system. +The regon must originally have been obtained using @code{allocate} or +@code{resize}. If the operational is successful, @i{wior} is 0. +If the operation fails, @i{wior} is an implementation-defined +I/O result code."" free(a_addr); wior = 0; resize a_addr1 u -- a_addr2 wior memory -""Change the size of the allocated area at @i{a_addr1} to @i{u} +""Change the size of the allocated area at @i{a-addr1} to @i{u} address units, possibly moving the contents to a different -area. @i{a_addr2} is the address of the resulting area. If -@code{a_addr1} is 0, Gforth's (but not the standard) @code{resize} -@code{allocate}s @i{u} address units."" +area. @i{a-addr2} is the address of the resulting area. +If the operational is successful, @i{wior} is 0. +If the operation fails, @i{wior} is an implementation-defined +I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard) +@code{resize} @code{allocate}s @i{u} address units."" /* the following check is not necessary on most OSs, but it is needed on SunOS 4.1.2. */ if (a_addr1==NULL) @@ -1556,7 +1607,7 @@ delete-file c_addr u -- wior file delet wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file -""rename file c_addr1 u1 to new name c_addr2 u2"" +""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" char *s1=tilde_cstr(c_addr2, u2, 1); wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); @@ -1585,24 +1636,29 @@ if (wior) clearerr((FILE *)wfileid); read-line c_addr u1 wfileid -- u2 flag wior file read_line -/* +#if 1 Cell c; flag=-1; for(u2=0; u2float c_addr u -- flag float to_float +""Attempt to convert the character string @i{c-addr u} to +internal floating-point representation. If the string +represents a valid floating-point number @i{r} is placed +on the floating-point stack and @i{flag} is true. Otherwise, +@i{flag} is false. A string of blanks is a special case +and represents the floating-point number 0."" /* real signature: c_addr u -- r t / f */ Float r; char *number=cstr(c_addr, u, 1); char *endconv; +int sign = 0; +if(number[0]=='-') { + sign = 1; + number++; + u--; +} while(isspace((unsigned)(number[--u])) && u>0); switch(number[u]) { @@ -1817,7 +1896,7 @@ if((flag=FLAG(!(Cell)*endconv))) { IF_FTOS(fp[0] = FTOS); fp += -1; - FTOS = r; + FTOS = sign ? -r : r; } else if(*endconv=='d' || *endconv=='D') { @@ -1827,34 +1906,34 @@ else if(*endconv=='d' || *endconv=='D') { IF_FTOS(fp[0] = FTOS); fp += -1; - FTOS = r; + FTOS = sign ? -r : r; } } -fabs r1 -- r2 float-ext +fabs r1 -- r2 float-ext f_abs r2 = fabs(r1); -facos r1 -- r2 float-ext +facos r1 -- r2 float-ext f_a_cos r2 = acos(r1); -fasin r1 -- r2 float-ext +fasin r1 -- r2 float-ext f_a_sine r2 = asin(r1); -fatan r1 -- r2 float-ext +fatan r1 -- r2 float-ext f_a_tan r2 = atan(r1); -fatan2 r1 r2 -- r3 float-ext -""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably +fatan2 r1 r2 -- r3 float-ext f_a_tan_two +""@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."" r3 = atan2(r1,r2); -fcos r1 -- r2 float-ext +fcos r1 -- r2 float-ext f_cos r2 = cos(r1); -fexp r1 -- r2 float-ext +fexp r1 -- r2 float-ext f_e_x_p 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"" #ifdef HAVE_EXPM1 extern double @@ -1867,10 +1946,10 @@ r2 = expm1(r1); r2 = exp(r1)-1.; #endif -fln r1 -- r2 float-ext +fln r1 -- r2 float-ext f_l_n r2 = log(r1); -flnp1 r1 -- r2 float-ext +flnp1 r1 -- r2 float-ext f_l_n_p_one ""@i{r2}=ln(@i{r1}+1)"" #ifdef HAVE_LOG1P extern double @@ -1883,74 +1962,82 @@ r2 = log1p(r1); r2 = log(r1+1.); #endif -flog r1 -- r2 float-ext -""the decimal logarithm"" +flog r1 -- r2 float-ext f_log +""The decimal logarithm."" r2 = log10(r1); -falog r1 -- r2 float-ext +falog r1 -- r2 float-ext f_a_log ""@i{r2}=10**@i{r1}"" extern double pow10(double); r2 = pow10(r1); -fsin r1 -- r2 float-ext +fsin r1 -- r2 float-ext f_sine 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})"" r2 = sin(r1); r3 = cos(r1); -fsqrt r1 -- r2 float-ext +fsqrt r1 -- r2 float-ext f_square_root r2 = sqrt(r1); -ftan r1 -- r2 float-ext +ftan r1 -- r2 float-ext f_tan r2 = tan(r1); : fsincos f/ ; -fsinh r1 -- r2 float-ext +fsinh r1 -- r2 float-ext f_cinch r2 = sinh(r1); : 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); : fexp fdup 1/f f+ f2/ ; -ftanh r1 -- r2 float-ext +ftanh r1 -- r2 float-ext f_tan_h r2 = tanh(r1); : f2* fexpm1 fdup 2. d>f f+ f/ ; -fasinh r1 -- r2 float-ext +fasinh r1 -- r2 float-ext f_a_cinch r2 = asinh(r1); : 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); : 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); : fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ r> IF fnegate THEN ; sfloats n1 -- n2 float-ext s_floats +""@i{n2} is the number of address units corresponding to @i{n1} +single-precision IEEE floating-point numbers."" n2 = n1*sizeof(SFloat); dfloats n1 -- n2 float-ext d_floats +""@i{n2} is the number of address units corresponding to @i{n1} +double-precision IEEE floating-point numbers."" n2 = n1*sizeof(DFloat); sfaligned c_addr -- sf_addr float-ext s_f_aligned +"" @i{sf-addr} is the first single-float-aligned address greater +than or equal to @i{c-addr}."" sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); : [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; dfaligned c_addr -- df_addr float-ext d_f_aligned +"" @i{df-addr} is the first double-float-aligned address greater +than or equal to @i{c-addr}."" df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); : [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; @@ -2107,3 +2194,23 @@ UP=up=(char *)a_addr; : 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]); + +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);