--- gforth/prim 2000/08/11 19:49:39 1.53 +++ gforth/prim 2000/11/10 10:04:20 1.64 @@ -1,6 +1,6 @@ \ Gforth primitives -\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -16,7 +16,7 @@ \ You should have received a copy of the GNU General Public License \ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. \ WARNING: This file is processed by m4. Make sure your identifiers @@ -117,14 +117,14 @@ INC_IP(1); execute ( xt -- ) core ""Perform the semantics represented by the execution token, @i{xt}."" ip=IP; -IF_TOS(TOS = sp[0]); +IF_spTOS(spTOS = sp[0]); EXEC(xt); perform ( a_addr -- ) gforth -""Equivalent to @code{@ execute}."" +""@code{@@ execute}."" /* and pfe */ ip=IP; -IF_TOS(TOS = sp[0]); +IF_spTOS(spTOS = sp[0]); EXEC(*(Xt *)a_addr); : @ execute ; @@ -170,7 +170,7 @@ else condbranch(?branch,( f -- ) f83 question_branch, if (f==0) { - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); ,: 0= dup \ !f !f r> dup @ \ !f !f IP branchoffset @@ -187,7 +187,7 @@ if (f==0) { ""The run-time procedure compiled by @code{?DUP-IF}."" if (f==0) { sp++; - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); NEXT; } @@ -241,7 +241,7 @@ if ((olddiff^(olddiff+n))>=0 /* the li #else *rp = index + n; #endif - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); ,: r> swap r> r> 2dup - >r @@ -262,7 +262,7 @@ if (olddiff>u) { #else *rp = index - u; #endif - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); ,) condbranch((s+loop),( n -- ) gforth paren_symmetric_plus_loop, @@ -283,7 +283,7 @@ if (diff>=0 || newdiff<0) { #else *rp = index + n; #endif - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); ,) \+ @@ -311,7 +311,7 @@ rp += 2; *--rp = nlimit; *--rp = nstart; if (nstart == nlimit) { - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); goto branch; } else { @@ -331,7 +331,7 @@ else { *--rp = nlimit; *--rp = nstart; if (nstart >= nlimit) { - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); goto branch; } else { @@ -351,7 +351,7 @@ else { *--rp = ulimit; *--rp = ustart; if (ustart >= ulimit) { - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); goto branch; } else { @@ -371,7 +371,7 @@ else { *--rp = nlimit; *--rp = nstart; if (nstart <= nlimit) { - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); goto branch; } else { @@ -391,7 +391,7 @@ else { *--rp = ulimit; *--rp = ustart; if (ustart <= ulimit) { - IF_TOS(TOS = sp[0]); + IF_spTOS(spTOS = sp[0]); goto branch; } else { @@ -955,7 +955,7 @@ a_addr = sp+1; sp! ( a_addr -- ) gforth sp_store sp = a_addr; -/* works with and without TOS caching */ +/* works with and without spTOS caching */ rp@ ( -- a_addr ) gforth rp_fetch a_addr = rp; @@ -1066,7 +1066,7 @@ tuck ( w1 w2 -- w2 w1 w2 ) core-ext ""Actually the stack effect is: @code{( w -- 0 | w w )}. It performs a @code{dup} if w is nonzero."" if (w!=0) { - IF_TOS(*sp-- = w;) + IF_spTOS(*sp-- = w;) #ifndef USE_TOS *--sp = w; #endif @@ -1224,8 +1224,8 @@ 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}."" +""@i{c-addr2} is the first character and @i{u} the length of the +counted string at @i{c-addr1}."" u = *c_addr1; c_addr2 = c_addr1+1; : @@ -1379,7 +1379,7 @@ c_addr = (Address)CODE_ADDRESS(xt); @ ; >does-code ( xt -- a_addr ) gforth to_does_code -""If @i{xt} is the execution token of a defining-word-defined word, +""If @i{xt} is the execution token of a child of a @code{DOES>} 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); @@ -1394,16 +1394,16 @@ CACHE_FLUSH(xt,(size_t)PFA(0)); ! ; does-code! ( a_addr xt -- ) gforth does_code_store -""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>}."" +""Create a code field at @i{xt} for a child of a @code{DOES>}-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 -""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points -just behind a @code{DOES>}."" +""Create a @code{DOES>}-handler at address @i{a-addr}. Normally, +@i{a-addr} points just behind a @code{DOES>}."" MAKE_DOES_HANDLER(a_addr); CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); : @@ -1504,8 +1504,8 @@ in length."" c_addr2 = getenv(cstr(c_addr1,u1,1)); u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); -open-pipe ( c_addr u ntype -- wfileid wior ) gforth open_pipe -wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */ +open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe +wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */ wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ close-pipe ( wfileid -- wretval wior ) gforth close_pipe @@ -1584,14 +1584,14 @@ access the stack itself. The stack point variables @code{SP} and @code{FP}."" /* This is a first attempt at support for calls to C. This may change in the future */ -IF_FTOS(fp[0]=FTOS); +IF_fpTOS(fp[0]=fpTOS); FP=fp; SP=sp; ((void (*)())w)(); sp=SP; fp=FP; -IF_TOS(TOS=sp[0]); -IF_FTOS(FTOS=fp[0]); +IF_spTOS(spTOS=sp[0]); +IF_fpTOS(fpTOS=fp[0]); \+ \+file @@ -1599,15 +1599,15 @@ IF_FTOS(FTOS=fp[0]); close-file ( wfileid -- wior ) file close_file wior = IOR(fclose((FILE *)wfileid)==EOF); -open-file ( c_addr u ntype -- wfileid wior ) file open_file -wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); +open-file ( c_addr u wfam -- wfileid wior ) file open_file +wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]); wior = IOR(wfileid == 0); -create-file ( c_addr u ntype -- wfileid wior ) file create_file +create-file ( c_addr u wfam -- wfileid wior ) file create_file Cell fd; -fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666); +fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666); if (fd != -1) { - wfileid = (Cell)fdopen(fd, fileattr[ntype]); + wfileid = (Cell)fdopen(fd, fileattr[wfam]); wior = IOR(wfileid == 0); } else { wfileid = 0; @@ -1647,7 +1647,7 @@ if (wior) clearerr((FILE *)wfileid); read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line -#if 1 +""this is only for backward compatibility"" Cell c; flag=-1; for(u2=0; u20) && (c_addr[u2-1]==NEWLINE)); -} -else { - wior=0; - u2=0; -} -#endif \+ @@ -1710,26 +1696,26 @@ PUTC(c); flush-file ( wfileid -- wior ) file-ext flush_file wior = IOR(fflush((FILE *) wfileid)==EOF); -file-status ( c_addr u -- ntype wior ) file-ext file_status +file-status ( c_addr u -- wfam wior ) file-ext file_status char *filename=tilde_cstr(c_addr, u, 1); if (access (filename, F_OK) != 0) { - ntype=0; + wfam=0; wior=IOR(1); } else if (access (filename, R_OK | W_OK) == 0) { - ntype=2; /* r/w */ + wfam=2; /* r/w */ wior=0; } else if (access (filename, R_OK) == 0) { - ntype=0; /* r/o */ + wfam=0; /* r/o */ wior=0; } else if (access (filename, W_OK) == 0) { - ntype=4; /* w/o */ + wfam=4; /* w/o */ wior=0; } else { - ntype=1; /* well, we cannot access the file, but better deliver a legal + wfam=1; /* well, we cannot access the file, but better deliver a legal access mode (r/o bin), so we get a decent error later upon open. */ wior=0; } @@ -1877,12 +1863,12 @@ 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 floating-point number 0."" +""Actual stack effect: ( c_addr u -- r t | f ). 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); @@ -1906,9 +1892,9 @@ number[u]='\0'; r=strtod(number,&endconv); if((flag=FLAG(!(Cell)*endconv))) { - IF_FTOS(fp[0] = FTOS); + IF_fpTOS(fp[0] = fpTOS); fp += -1; - FTOS = sign ? -r : r; + fpTOS = sign ? -r : r; } else if(*endconv=='d' || *endconv=='D') { @@ -1916,9 +1902,9 @@ else if(*endconv=='d' || *endconv=='D') r=strtod(number,&endconv); if((flag=FLAG(!(Cell)*endconv))) { - IF_FTOS(fp[0] = FTOS); + IF_fpTOS(fp[0] = fpTOS); fp += -1; - FTOS = sign ? -r : r; + fpTOS = sign ? -r : r; } } @@ -2210,12 +2196,12 @@ UP=up=(char *)a_addr; Variable UP wcall ( u -- ) gforth -IF_FTOS(fp[0]=FTOS); +IF_fpTOS(fp[0]=fpTOS); FP=fp; sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP); fp=FP; -IF_TOS(TOS=sp[0];) -IF_FTOS(FTOS=fp[0]); +IF_spTOS(spTOS=sp[0];) +IF_fpTOS(fpTOS=fp[0]); \+file @@ -2261,7 +2247,9 @@ c_addr=newline; u=sizeof(newline); : "newline count ; -Create "newline 1 c, $0A c, +Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c, + +\+os utime ( -- dtime ) gforth ""Report the current time in microseconds since some epoch."" @@ -2284,8 +2272,16 @@ dsystem = timeval2us(&usage.ru_stime); struct timeval time1; gettimeofday(&time1,NULL); duser = timeval2us(&time1); +#ifndef BUGGY_LONG_LONG dsystem = (DCell)0; +#else +dsystem=(DCell){0,0}; #endif +#endif + +\+ + +\+floating v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star ""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the @@ -2296,6 +2292,10 @@ for (r=0.; ucount>0; ucount--) { f_addr1 = (Float *)(((Address)f_addr1)+nstride1); f_addr2 = (Float *)(((Address)f_addr2)+nstride2); } +: + >r swap 2swap swap 0e r> 0 ?DO + dup f@ over + 2swap dup f@ f* f+ over + 2swap + LOOP 2drop 2drop ; faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth ""vy=ra*vx+vy"" @@ -2304,3 +2304,37 @@ for (; ucount>0; ucount--) { f_x = (Float *)(((Address)f_x)+nstridex); f_y = (Float *)(((Address)f_y)+nstridey); } +: + >r swap 2swap swap r> 0 ?DO + fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap + LOOP 2drop 2drop fdrop ; + +\+ + +\+file + +(read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line +Cell c; +flag=-1; +u3=0; +for(u2=0; u2