--- gforth/prim 1998/07/28 12:29:37 1.10 +++ gforth/prim 1998/12/13 23:29:59 1.19 @@ -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. @@ -128,7 +128,7 @@ EXEC(*(Xt *)a_addr); : @ execute ; -\+has? glocals [IF] +\+glocals branch-lp+!# -- gforth branch_lp_plus_store_number /* this will probably not be used */ @@ -136,7 +136,7 @@ branch_adjust_lp: lp += (Cell)(IP[1]); goto branch; -\+[THEN] +\+ branch -- gforth branch: @@ -157,7 +157,7 @@ else INC_IP(1); $4 -\+has? glocals [IF] +\+glocals $1-lp+!# $2_lp_plus_store_number $3 goto branch_adjust_lp; @@ -165,7 +165,7 @@ $3 goto branch_adjust_lp; else INC_IP(2); -\+[THEN] +\+ ) condbranch(?branch,f -- f83 question_branch, @@ -181,7 +181,7 @@ if (f==0) { \ 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}."" @@ -210,7 +210,7 @@ if (f!=0) { else INC_IP(1); -\+[THEN] +\+ condbranch((next),-- cmFORTH paren_next, if ((*rp)--) { @@ -250,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 */ @@ -286,7 +286,7 @@ if (diff>=0 || newdiff<0) { IF_TOS(TOS = sp[0]); ,) -\+[THEN] +\+ unloop -- core rp += 2; @@ -325,7 +325,7 @@ else { cell+ >r THEN ; \ --> CORE-EXT -\+has? xconds [IF] +\+xconds (+do) nlimit nstart -- gforth paren_plus_do *--rp = nlimit; @@ -407,7 +407,7 @@ 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! @@ -905,13 +905,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); @@ -931,7 +931,7 @@ a_addr = rp; rp! a_addr -- gforth rpstore rp = a_addr; -\+has? floating [IF] +\+floating fp@ -- f_addr gforth fp_fetch f_addr = fp; @@ -939,7 +939,7 @@ f_addr = fp; fp! f_addr -- gforth fp_store fp = f_addr; -\+[THEN] +\+ ;s -- gforth semis ip = (Xt *)(*rp++); @@ -1177,7 +1177,7 @@ 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; @@ -1191,14 +1191,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? */) @@ -1217,11 +1217,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? */) @@ -1272,7 +1272,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? */ @@ -1369,16 +1369,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; @@ -1493,13 +1503,18 @@ fp=FP; IF_TOS(TOS=sp[0]); IF_FTOS(FTOS=fp[0]); -\+[THEN] ( has? os ) has? file [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]); +#if defined(GO32) && defined(MSDOS) +if(w2 && !(ntype & 1)) + setbuf((FILE*)w2, NULL); +#endif wior = IOR(w2 == 0); create-file c_addr u ntype -- w2 wior file create_file @@ -1507,6 +1522,10 @@ 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]); +#if defined(GO32) && defined(MSDOS) + if(w2 && !(ntype & 1)) + setbuf((FILE*)w2, NULL); +#endif wior = IOR(w2 == 0); } else { w2 = 0; @@ -1517,6 +1536,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); @@ -1529,7 +1549,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); @@ -1574,7 +1593,8 @@ else { u2=0; } -\+[THEN] has? file [IF] -1 [ELSE] has? os [THEN] [IF] +\+ +\+file write-file c_addr u1 wfileid -- wior file write_file /* !! fwrite does not guarantee enough */ @@ -1585,12 +1605,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? file [IF] +\+file flush-file wfileid -- wior file-ext flush_file wior = IOR(fflush((FILE *) wfileid)==EOF); @@ -1619,7 +1645,8 @@ else { wior=0; } -\+[THEN] ( has? file ) has? floating [IF] +\+ +\+floating comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) @@ -1914,7 +1941,8 @@ df_addr = (DFloat *)((((Cell)c_addr)+(si \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ \ local variable implementation primitives -\+[THEN] ( has? floats ) has? glocals [IF] +\+ +\+glocals @local# -- w gforth fetch_local_number w = *(Cell *)(lp+(Cell)NEXT_INST); @@ -1932,7 +1960,7 @@ w = *(Cell *)(lp+2*sizeof(Cell)); @local3 -- w new fetch_local_twelve w = *(Cell *)(lp+3*sizeof(Cell)); -\+has? floating [IF] +\+floating f@local# -- r gforth f_fetch_local_number r = *(Float *)(lp+(Cell)NEXT_INST); @@ -1944,7 +1972,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@ */ @@ -1974,15 +2002,21 @@ lp = (Address)c_addr; lp -= sizeof(Cell); *(Cell *)lp = w; -\+has? floating [IF] +\+floating f>l r -- gforth f_to_l lp -= sizeof(Float); *(Float *)lp = r; -\+[THEN] [THEN] \ has? glocals +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')') @@ -2021,7 +2055,7 @@ open-lib c_addr1 u1 -- u2 gforth open_li #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! @@ -2033,7 +2067,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! @@ -2046,11 +2080,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 -