--- gforth/prim 1997/06/06 17:27:57 1.2 +++ gforth/prim 1999/02/21 11:43:12 1.25 @@ -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, 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,7 @@ EXEC(*(Xt *)a_addr); : @ execute ; -\+has-locals [IF] +\+glocals branch-lp+!# -- gforth branch_lp_plus_store_number /* this will probably not be used */ @@ -136,12 +137,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 +149,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 +164,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 +201,13 @@ 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] +\+ condbranch((next),-- cmFORTH paren_next, if ((*rp)--) { @@ -245,7 +247,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 +283,7 @@ if (diff>=0 || newdiff<0) { IF_TOS(TOS = sp[0]); ,) -\+[THEN] +\+ unloop -- core rp += 2; @@ -320,7 +322,7 @@ else { cell+ >r THEN ; \ --> CORE-EXT -\+has-xconds [IF] +\+xconds (+do) nlimit nstart -- gforth paren_plus_do *--rp = nlimit; @@ -402,44 +404,63 @@ 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] \ 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."" 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."" 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."" while (u-- > 0) c_to[u] = c_from[u]; : @@ -448,13 +469,15 @@ 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."" 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 +""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 is 1. Currently this is based on the machine's character comparison. In the future, this may change to considering the current @@ -489,6 +512,8 @@ else if (n>0) dup 0< IF drop -1 ELSE 0> 1 and THEN ; toupper c1 -- c2 gforth +""If @var{c1} is a lower-case character (in the current locale), @var{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 - ; @@ -508,7 +533,7 @@ else if (n>0) -trailing c_addr u1 -- c_addr u2 string dash_trailing u2 = u1; - while (u2>0 && c_addr[u2-1] == ' ') +while (u2>0 && c_addr[u2-1] == ' ') u2--; : BEGIN 1- 2dup + c@ bl = WHILE @@ -607,7 +632,7 @@ 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 ; @@ -694,10 +719,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,13 +915,13 @@ 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 f = FLAG(u1-u2 < u3-u2); @@ -916,7 +941,7 @@ a_addr = rp; rp! a_addr -- gforth rpstore rp = a_addr; -\+has-floats [IF] +\+floating fp@ -- f_addr gforth fp_fetch f_addr = fp; @@ -924,11 +949,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 +1027,7 @@ Variable (rot) nip w1 w2 -- w2 core-ext : - >r drop r> ; + swap drop ; tuck w1 w2 -- w2 w1 w2 core-ext : @@ -1156,13 +1181,15 @@ 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."" 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 +1203,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 +1229,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 +1284,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? */ @@ -1303,7 +1330,7 @@ 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>; +a_addr is the start of the Forth code after the @code{DOES>}; Otherwise a_addr is 0."" a_addr = (Cell *)DOES_CODE(xt); : @@ -1312,7 +1339,7 @@ a_addr = (Cell *)DOES_CODE(xt); code-address! c_addr xt -- gforth code_address_store ""Creates a code field with code address c_addr at xt"" MAKE_CF(xt, c_addr); -CACHE_FLUSH(xt,PFA(0)); +CACHE_FLUSH(xt,(size_t)PFA(0)); : ! ; @@ -1320,7 +1347,7 @@ does-code! a_addr xt -- gforth does_cod ""creates a code field at xt for a defining-word-defined word; a_addr is the start of the Forth code after DOES>"" MAKE_DOES_CF(xt, a_addr); -CACHE_FLUSH(xt,PFA(0)); +CACHE_FLUSH(xt,(size_t)PFA(0)); : dodoes: over ! cell+ ! ; @@ -1328,7 +1355,7 @@ does-handler! a_addr -- gforth does_hand ""creates a DOES>-handler at address a_addr. a_addr usually points just behind a DOES>."" MAKE_DOES_HANDLER(a_addr); -CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE); +CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); : drop ; @@ -1354,16 +1381,26 @@ n=1; : 1 ; -\+has-os [IF] - -(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; @@ -1395,14 +1432,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 c-addr1 u1 specifies an environment variable. The string 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 +in length."" c_addr2 = getenv(cstr(c_addr1,u1,1)); u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); @@ -1478,23 +1523,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 +1556,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"" char *s1=tilde_cstr(c_addr2, u2, 1); wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); @@ -1514,7 +1569,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); @@ -1559,7 +1613,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 +1625,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 +1665,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,7 +1681,7 @@ 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; @@ -1732,7 +1794,7 @@ 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 @@ -1740,7 +1802,7 @@ memmove(c_addr,sig,u); 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': @@ -1795,7 +1857,11 @@ r2 = exp(r1); fexpm1 r1 -- r2 float-ext ""@i{r2}=@i{e}**@i{r1}@minus{}1"" #ifdef HAVE_EXPM1 -extern double expm1(double); +extern double +#ifdef NeXT + const +#endif + expm1(double); r2 = expm1(r1); #else r2 = exp(r1)-1.; @@ -1807,7 +1873,11 @@ r2 = log(r1); flnp1 r1 -- r2 float-ext ""@i{r2}=ln(@i{r1}+1)"" #ifdef HAVE_LOG1P -extern double log1p(double); +extern double +#ifdef NeXT + const +#endif + log1p(double); r2 = log1p(r1); #else r2 = log(r1+1.); @@ -1891,7 +1961,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); @@ -1909,7 +1980,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); @@ -1921,7 +1992,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@ */ @@ -1951,15 +2022,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')') @@ -1981,21 +2058,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! @@ -2007,7 +2087,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! @@ -2020,11 +2100,10 @@ icall(20) uploop(i, 0, 7, `fcall(i)') fcall(20) -\+[THEN] \ has-OS +\+ up! a_addr -- gforth up_store UP=up=(char *)a_addr; : up ! ; Variable UP -