--- gforth/prim 1997/06/15 19:43:28 1.3 +++ gforth/prim 1999/05/20 13:38:02 1.35 @@ -1,6 +1,6 @@ \ Gforth primitives -\ Copyright (C) 1995,1996 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -115,12 +115,13 @@ INC_IP(1); r> dup @ swap cell+ >r ; execute xt -- core +""Perform the semantics represented by the execution token, @i{xt}."" ip=IP; IF_TOS(TOS = sp[0]); EXEC(xt); perform a_addr -- gforth -""equivalent to @code{@ execute}"" +""Equivalent to @code{@ execute}."" /* and pfe */ ip=IP; IF_TOS(TOS = sp[0]); @@ -128,7 +129,8 @@ EXEC(*(Xt *)a_addr); : @ execute ; -\+has-locals [IF] +\fhas? skipbranchprims 0= [IF] +\+glocals branch-lp+!# -- gforth branch_lp_plus_store_number /* this will probably not be used */ @@ -136,12 +138,11 @@ branch_adjust_lp: lp += (Cell)(IP[1]); goto branch; -\+[THEN] +\+ branch -- gforth branch: -ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); -NEXT_P0; +SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); : r> dup @ + >r ; @@ -149,15 +150,14 @@ NEXT_P0; \ this is non-syntactical: code must open a brace that is closed by the macro define(condbranch, $1 $2 -$3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); - NEXT_P0; +$3 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); NEXT; } else INC_IP(1); $4 -\+has-locals [IF] +\+glocals $1-lp+!# $2_lp_plus_store_number $3 goto branch_adjust_lp; @@ -165,26 +165,30 @@ $3 goto branch_adjust_lp; else INC_IP(2); -\+[THEN] +\+ ) condbranch(?branch,f -- f83 question_branch, if (f==0) { IF_TOS(TOS = sp[0]); -,) +,: + 0= dup \ !f !f + r> dup @ \ !f !f IP branchoffset + rot and + \ !f IP|IP+branchoffset + swap 0= cell and + \ IP'' + >r ;) \ we don't need an lp_plus_store version of the ?dup-stuff, because it \ is only used in if's (yet) -\+has-xconds [IF] +\+xconds ?dup-?branch f -- f new question_dupe_question_branch ""The run-time procedure compiled by @code{?DUP-IF}."" if (f==0) { sp++; IF_TOS(TOS = sp[0]); - ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); - NEXT_P0; + SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); NEXT; } else @@ -198,14 +202,15 @@ few cycles in that case, but is easy to invocation */ if (f!=0) { sp--; - ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); - NEXT_P0; + SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); NEXT; } else INC_IP(1); -\+[THEN] +\+ +\f[THEN] +\fhas? skiploopprims 0= [IF] condbranch((next),-- cmFORTH paren_next, if ((*rp)--) { @@ -245,7 +250,7 @@ if ((olddiff^(olddiff+n))>=0 /* the li IF >r + >r dup @ + >r ELSE >r >r drop cell+ >r THEN ;) -\+has-xconds [IF] +\+xconds condbranch((-loop),u -- gforth paren_minus_loop, /* !! check this thoroughly */ @@ -281,7 +286,7 @@ if (diff>=0 || newdiff<0) { IF_TOS(TOS = sp[0]); ,) -\+[THEN] +\+ unloop -- core rp += 2; @@ -320,7 +325,7 @@ else { cell+ >r THEN ; \ --> CORE-EXT -\+has-xconds [IF] +\+xconds (+do) nlimit nstart -- gforth paren_plus_do *--rp = nlimit; @@ -402,44 +407,66 @@ else { cell+ THEN >r ; -\+[THEN] +\+ + +\ don't make any assumptions where the return stack is!! +\ implement this in machine code if it should run quickly! i -- n core n = *rp; : - rp@ cell+ @ ; +\ rp@ cell+ @ ; + r> r> tuck >r >r ; i' -- w gforth i_tick ""loop end value"" w = rp[1]; : - rp@ cell+ cell+ @ ; +\ rp@ cell+ cell+ @ ; + r> r> r> dup itmp ! >r >r >r itmp @ ; +variable itmp j -- n core n = rp[2]; : - rp@ cell+ cell+ cell+ @ ; +\ rp@ cell+ cell+ cell+ @ ; + r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; +[IFUNDEF] itmp variable itmp [THEN] k -- n gforth n = rp[4]; : - rp@ [ 5 cells ] Literal + @ ; +\ rp@ [ 5 cells ] Literal + @ ; + 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 +""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 +""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 +""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]; : @@ -448,16 +475,18 @@ while (u-- > 0) DO 1- dup c@ I c! -1 +LOOP drop ; fill c_addr u c -- core +"" 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 the 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) dup 0< IF drop -1 ELSE 0> 1 and THEN ; toupper c1 -- c2 gforth +""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 - ; @@ -507,14 +538,18 @@ 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 (c_addr[u2-1] == ' ') +while (u2>0 && c_addr[u2-1] == ' ') u2--; : BEGIN 1- 2dup + c@ bl = WHILE 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; : @@ -525,7 +560,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 ; @@ -607,12 +642,12 @@ n2 = n1>>1; : dup MINI and IF 1 ELSE 0 THEN [ bits/byte cell * 1- ] literal - 0 DO 2* swap dup 2* >r U-HIGHBIT and + 0 DO 2* swap dup 2* >r MINI and IF 1 ELSE 0 THEN or r> swap 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; @@ -634,7 +669,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; @@ -684,6 +719,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; @@ -694,10 +730,10 @@ u2 = ud%u1; #endif : 0 swap [ 8 cells 1 + ] literal 0 - ?DO >r /modstep r> + ?DO /modstep LOOP drop swap 1 rshift or swap ; : /modstep ( ud c R: u -- ud-?u c R: u ) - over I' u< 0= or IF I' - 1 ELSE 0 THEN d2*+ ; + >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ; : d2*+ ( ud n -- ud+n c ) over MINI and >r >r 2dup d+ swap r> + swap r> ; @@ -890,33 +926,40 @@ f = FLAG($4>=$5); ) -\+has-dcomps [IF] +\+dcomps dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) -\+[THEN] +\+ 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; -\+has-floats [IF] +\+floating fp@ -- f_addr gforth fp_fetch f_addr = fp; @@ -924,11 +967,11 @@ f_addr = fp; fp! f_addr -- gforth fp_store fp = f_addr; -\+[THEN] +\+ ;s -- gforth semis -ip = (Xt *)(*rp++); -NEXT_P0; +""The primitive compiled by @code{EXIT}."" +SET_IP((Xt *)(*rp++)); >r w -- core to_r *--rp = w; @@ -1002,7 +1045,7 @@ Variable (rot) nip w1 w2 -- w2 core-ext : - >r drop r> ; + swap drop ; tuck w1 w2 -- w2 w1 w2 core-ext : @@ -1054,17 +1097,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] ] @@ -1089,7 +1136,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] ] @@ -1119,23 +1167,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 @@ -1145,24 +1198,28 @@ 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 @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; : dup 1+ swap c@ ; (f83find) c_addr u f83name1 -- f83name2 new paren_f83find -for (; f83name1 != NULL; f83name1 = f83name1->next) +for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) if ((UCell)F83NAME_COUNT(f83name1)==u && memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) break; @@ -1176,14 +1233,14 @@ f83name2=f83name1; : (find-samelen) ( u f83name1 -- u f83name2/0 ) BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; -\+has-hash [IF] +\+hash (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind -F83Name *f83name1; +struct F83Name *f83name1; f83name2=NULL; while(a_addr != NULL) { - f83name1=(F83Name *)(a_addr[1]); + f83name1=(struct F83Name *)(a_addr[1]); a_addr=(Cell *)(a_addr[0]); if ((UCell)F83NAME_COUNT(f83name1)==u && memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) @@ -1202,11 +1259,11 @@ while(a_addr != NULL) (tablefind) c_addr u a_addr -- f83name2 new paren_tablefind ""A case-sensitive variant of @code{(hashfind)}"" -F83Name *f83name1; +struct F83Name *f83name1; f83name2=NULL; while(a_addr != NULL) { - f83name1=(F83Name *)(a_addr[1]); + f83name1=(struct F83Name *)(a_addr[1]); a_addr=(Cell *)(a_addr[0]); if ((UCell)F83NAME_COUNT(f83name1)==u && memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */) @@ -1257,7 +1314,7 @@ Create rot-values 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, -\+[THEN] +\+ (parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white /* use !isgraph instead of isspace? */ @@ -1280,11 +1337,13 @@ 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 ; @@ -1294,46 +1353,49 @@ 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 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,PFA(0)); +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,PFA(0)); +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(a_addr,DOES_HANDLER_SIZE); +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; : @@ -1354,16 +1416,28 @@ n=1; : 1 ; -\+has-os [IF] +\f[THEN] -(key) -- n gforth paren_key +key-file wfileid -- n gforth paren_key_file +#ifdef HAS_FILE fflush(stdout); -/* !! noecho */ -n = key(); +n = key((FILE*)wfileid); +#else +n = key(stdin); +#endif -key? -- n facility key_q +key?-file wfileid -- n facility key_q_file +#ifdef HAS_FILE fflush(stdout); -n = key_query; +n = key_query((FILE*)wfileid); +#else +n = key_query(stdin); +#endif + +\+os + +stdin -- wfileid gforth +wfileid = (Cell)stdin; stdout -- wfileid gforth wfileid = (Cell)stdout; @@ -1381,7 +1455,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 @@ -1395,14 +1469,22 @@ FLUSH_ICACHE(c_addr,u); return (Label *)n; (system) c_addr u -- wretval wior gforth peren_system +#ifndef MSDOS int old_tp=terminal_prepped; deprep_terminal(); +#endif wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); +#ifndef MSDOS if (old_tp) prep_terminal(); +#endif getenv c_addr1 u1 -- c_addr2 u2 gforth +""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, @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)); @@ -1434,19 +1516,31 @@ 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) @@ -1478,23 +1572,32 @@ fp=FP; IF_TOS(TOS=sp[0]); IF_FTOS(FTOS=fp[0]); -\+[THEN] ( has-os ) has-files [IF] +\+ +\+file close-file wfileid -- wior file close_file wior = IOR(fclose((FILE *)wfileid)==EOF); -open-file c_addr u ntype -- w2 wior file open_file -w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); -wior = IOR(w2 == 0); +open-file c_addr u ntype -- wfileid wior file open_file +wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); +#if defined(GO32) && defined(MSDOS) +if(wfileid && !(ntype & 1)) + setbuf((FILE*)wfileid, NULL); +#endif +wior = IOR(wfileid == 0); -create-file c_addr u ntype -- w2 wior file create_file +create-file c_addr u ntype -- wfileid wior file create_file Cell fd; fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666); if (fd != -1) { - w2 = (Cell)fdopen(fd, fileattr[ntype]); - wior = IOR(w2 == 0); + wfileid = (Cell)fdopen(fd, fileattr[ntype]); +#if defined(GO32) && defined(MSDOS) + if(wfileid && !(ntype & 1)) + setbuf((FILE*)wfileid, NULL); +#endif + wior = IOR(wfileid == 0); } else { - w2 = 0; + wfileid = 0; wior = IOR(1); } @@ -1502,6 +1605,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 @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); @@ -1514,7 +1618,6 @@ reposition-file ud wfileid -- wior file wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); file-size wfileid -- ud wior file file_size -#include struct stat buf; wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); ud = LONG2UD(buf.st_size); @@ -1548,7 +1651,7 @@ wior=FILEIO(ferror((FILE *)wfileid)); */ if ((flag=FLAG(!feof((FILE *)wfileid) && fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { - wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */ + wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ if (wior) clearerr((FILE *)wfileid); u2 = strlen(c_addr); @@ -1559,7 +1662,8 @@ else { u2=0; } -\+[THEN] has-files [IF] -1 [ELSE] has-os [THEN] [IF] +\+ +\+file write-file c_addr u1 wfileid -- wior file write_file /* !! fwrite does not guarantee enough */ @@ -1570,12 +1674,18 @@ write-file c_addr u1 wfileid -- wior fil clearerr((FILE *)wfileid); } +\+ + emit-file c wfileid -- wior gforth emit_file +#ifdef HAS_FILE wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); if (wior) clearerr((FILE *)wfileid); +#else +putc(c, stdout); +#endif -\+[THEN] has-files [IF] +\+file flush-file wfileid -- wior file-ext flush_file wior = IOR(fflush((FILE *) wfileid)==EOF); @@ -1604,7 +1714,8 @@ else { wior=0; } -\+[THEN] ( has-files ) has-floats [IF] +\+ +\+floating comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) @@ -1619,19 +1730,22 @@ r = d; f>d r -- d float f_to_d #ifdef BUGGY_LONG_LONG -d.hi = ldexp(r,-CELL_BITS) - (r<0); +d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0); d.lo = r-ldexp((Float)d.hi,CELL_BITS); #else d = r; #endif f! r f_addr -- float f_store +"" Store the floating-point value @i{r} to address @i{f-addr}."" *f_addr = r; f@ f_addr -- r float f_fetch +"" Fetch floating-point value @i{r} from address @i{f-addr}."" r = *f_addr; df@ df_addr -- r float-ext d_f_fetch +"" Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}."" #ifdef IEEE_FP r = *df_addr; #else @@ -1639,6 +1753,7 @@ r = *df_addr; #endif df! r df_addr -- float-ext d_f_store +"" Store the double-precision IEEE floating-point value @i{r} to the address @i{df-addr}."" #ifdef IEEE_FP *df_addr = r; #else @@ -1646,6 +1761,7 @@ df! r df_addr -- float-ext d_f_store #endif sf@ sf_addr -- r float-ext s_f_fetch +"" Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}."" #ifdef IEEE_FP r = *sf_addr; #else @@ -1653,6 +1769,7 @@ r = *sf_addr; #endif sf! r sf_addr -- float-ext s_f_store +"" Store the single-precision IEEE floating-point value @i{r} to the address @i{sf-addr}."" #ifdef IEEE_FP *sf_addr = r; #else @@ -1672,7 +1789,7 @@ f/ r1 r2 -- r3 float f_slash r3 = r1/r2; 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); fnegate r1 -- r2 float @@ -1693,18 +1810,21 @@ fnip r1 r2 -- r2 gforth ftuck r1 r2 -- r2 r1 r2 gforth float+ f_addr1 -- f_addr2 float float_plus +"" Increment @i{f-addr1} by the number of address units corresponding to the size of +one floating-point number, to give @i{f-addr2}."" f_addr2 = f_addr1+1; floats n1 -- n2 float +""@i{n2} is the number of address units corresponding to @i{n1} floating-point numbers."" n2 = n1*sizeof(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 */ r2 = floor(r1); fround r1 -- r2 float -""round to the nearest integral value"" +""Round to the nearest integral value."" /* !! unclear wording */ #ifdef HAVE_RINT r2 = rint(r1); @@ -1732,15 +1852,21 @@ int decpt; sig=ecvt(r, u, &decpt, &flag); n=(r==0 ? 1 : decpt); f1=FLAG(flag!=0); -f2=FLAG(isdigit(sig[0])!=0); +f2=FLAG(isdigit((unsigned)(sig[0]))!=0); memmove(c_addr,sig,u); >float 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 flotaing-point number 0."" /* real signature: c_addr u -- r t / f */ Float r; char *number=cstr(c_addr, u, 1); char *endconv; -while(isspace(number[--u]) && u>0); +while(isspace((unsigned)(number[--u])) && u>0); switch(number[u]) { case 'd': @@ -1782,7 +1908,7 @@ fatan r1 -- r2 float-ext r2 = atan(r1); fatan2 r1 r2 -- r3 float-ext -""@i{r1/r2}=tan@i{r3}. The standard 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."" r3 = atan2(r1,r2); @@ -1822,7 +1948,7 @@ r2 = log(r1+1.); #endif flog r1 -- r2 float-ext -""the decimal logarithm"" +""The decimal logarithm."" r2 = log10(r1); falog r1 -- r2 float-ext @@ -1878,17 +2004,25 @@ r2 = atanh(r1); 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 ; @@ -1899,7 +2033,8 @@ df_addr = (DFloat *)((((Cell)c_addr)+(si \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ \ local variable implementation primitives -\+[THEN] ( has-floats ) has-locals [IF] +\+ +\+glocals @local# -- w gforth fetch_local_number w = *(Cell *)(lp+(Cell)NEXT_INST); @@ -1917,7 +2052,7 @@ w = *(Cell *)(lp+2*sizeof(Cell)); @local3 -- w new fetch_local_twelve w = *(Cell *)(lp+3*sizeof(Cell)); -\+has-floats [IF] +\+floating f@local# -- r gforth f_fetch_local_number r = *(Float *)(lp+(Cell)NEXT_INST); @@ -1929,7 +2064,7 @@ r = *(Float *)(lp+0*sizeof(Float)); f@local1 -- r new f_fetch_local_eight r = *(Float *)(lp+1*sizeof(Float)); -\+[THEN] +\+ laddr# -- c_addr gforth laddr_number /* this can also be used to implement lp@ */ @@ -1959,15 +2094,21 @@ lp = (Address)c_addr; lp -= sizeof(Cell); *(Cell *)lp = w; -\+has-floats [IF] +\+floating f>l r -- gforth f_to_l lp -= sizeof(Float); *(Float *)lp = r; -\+[THEN] [THEN] \ has-locals +fpick u -- r gforth +r = fp[u+1]; /* +1, because update of fp happens before this fragment */ +: + floats fp@ + f@ ; + +\+ +\+ -\+has-OS [IF] +\+OS define(`uploop', `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') @@ -1989,21 +2130,24 @@ define(argclist, \ icall(argnum) define(icall, `icall$1 argflist($1)u -- uret gforth -uret = ((Cell(*)(argdlist($1)))u)(argclist($1)); +uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1)); ') define(fcall, `fcall$1 argflist($1)u -- rret gforth -rret = ((Float(*)(argdlist($1)))u)(argclist($1)); +rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); ') open-lib c_addr1 u1 -- u2 gforth open_lib #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) -u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_LAZY); +#ifndef RTLD_GLOBAL +#define RTLD_GLOBAL 0 +#endif +u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); #else -# ifdef HAVE_LIBKERNEL32 +# ifdef _WIN32 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); # else #warning Define open-lib! @@ -2015,7 +2159,7 @@ lib-sym c_addr1 u1 u2 -- u3 gforth lib_s #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); #else -# ifdef HAVE_LIBKERNEL32 +# ifdef _WIN32 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); # else #warning Define lib-sym! @@ -2028,7 +2172,7 @@ icall(20) uploop(i, 0, 7, `fcall(i)') fcall(20) -\+[THEN] \ has-OS +\+ up! a_addr -- gforth up_store UP=up=(char *)a_addr; @@ -2036,3 +2180,11 @@ 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]); +