version 1.53, 2000/08/11 19:49:39
|
version 1.61, 2000/09/11 20:56:39
|
Line 121 IF_TOS(TOS = sp[0]);
|
Line 121 IF_TOS(TOS = sp[0]);
|
EXEC(xt); |
EXEC(xt); |
|
|
perform ( a_addr -- ) gforth |
perform ( a_addr -- ) gforth |
""Equivalent to @code{@ execute}."" |
""@code{@@ execute}."" |
/* and pfe */ |
/* and pfe */ |
ip=IP; |
ip=IP; |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
Line 1224 n2 = n1 * sizeof(Char);
|
Line 1224 n2 = n1 * sizeof(Char);
|
; |
; |
|
|
count ( c_addr1 -- c_addr2 u ) core |
count ( c_addr1 -- c_addr2 u ) core |
"" If @i{c-add1} is the address of a counted string return the length of |
""@i{c-addr2} is the first character and @i{u} the length of the |
the string, @i{u}, and the address of its first character, @i{c-addr2}."" |
counted string at @i{c-addr1}."" |
u = *c_addr1; |
u = *c_addr1; |
c_addr2 = c_addr1+1; |
c_addr2 = c_addr1+1; |
: |
: |
Line 1379 c_addr = (Address)CODE_ADDRESS(xt);
|
Line 1379 c_addr = (Address)CODE_ADDRESS(xt);
|
@ ; |
@ ; |
|
|
>does-code ( xt -- a_addr ) gforth to_does_code |
>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>}; |
@i{a-addr} is the start of the Forth code after the @code{DOES>}; |
Otherwise @i{a-addr} is 0."" |
Otherwise @i{a-addr} is 0."" |
a_addr = (Cell *)DOES_CODE(xt); |
a_addr = (Cell *)DOES_CODE(xt); |
Line 1394 CACHE_FLUSH(xt,(size_t)PFA(0));
|
Line 1394 CACHE_FLUSH(xt,(size_t)PFA(0));
|
! ; |
! ; |
|
|
does-code! ( a_addr xt -- ) gforth does_code_store |
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} |
""Create a code field at @i{xt} for a child of a @code{DOES>}-word; |
is the start of the Forth code after @code{DOES>}."" |
@i{a-addr} is the start of the Forth code after @code{DOES>}."" |
MAKE_DOES_CF(xt, a_addr); |
MAKE_DOES_CF(xt, a_addr); |
CACHE_FLUSH(xt,(size_t)PFA(0)); |
CACHE_FLUSH(xt,(size_t)PFA(0)); |
: |
: |
dodoes: over ! cell+ ! ; |
dodoes: over ! cell+ ! ; |
|
|
does-handler! ( a_addr -- ) gforth does_handler_store |
does-handler! ( a_addr -- ) gforth does_handler_store |
""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points |
""Create a @code{DOES>}-handler at address @i{a-addr}. Normally, |
just behind a @code{DOES>}."" |
@i{a-addr} points just behind a @code{DOES>}."" |
MAKE_DOES_HANDLER(a_addr); |
MAKE_DOES_HANDLER(a_addr); |
CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); |
CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); |
: |
: |
Line 1504 in length.""
|
Line 1504 in length.""
|
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
open-pipe ( c_addr u ntype -- wfileid wior ) gforth open_pipe |
open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe |
wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */ |
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 */ |
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
|
|
close-pipe ( wfileid -- wretval wior ) gforth close_pipe |
close-pipe ( wfileid -- wretval wior ) gforth close_pipe |
Line 1599 IF_FTOS(FTOS=fp[0]);
|
Line 1599 IF_FTOS(FTOS=fp[0]);
|
close-file ( wfileid -- wior ) file close_file |
close-file ( wfileid -- wior ) file close_file |
wior = IOR(fclose((FILE *)wfileid)==EOF); |
wior = IOR(fclose((FILE *)wfileid)==EOF); |
|
|
open-file ( c_addr u ntype -- wfileid wior ) file open_file |
open-file ( c_addr u wfam -- wfileid wior ) file open_file |
wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); |
wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]); |
wior = IOR(wfileid == 0); |
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; |
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) { |
if (fd != -1) { |
wfileid = (Cell)fdopen(fd, fileattr[ntype]); |
wfileid = (Cell)fdopen(fd, fileattr[wfam]); |
wior = IOR(wfileid == 0); |
wior = IOR(wfileid == 0); |
} else { |
} else { |
wfileid = 0; |
wfileid = 0; |
Line 1647 if (wior)
|
Line 1647 if (wior)
|
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
|
|
read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line |
read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line |
#if 1 |
""this is only for backward compatibility"" |
Cell c; |
Cell c; |
flag=-1; |
flag=-1; |
for(u2=0; u2<u1; u2++) |
for(u2=0; u2<u1; u2++) |
Line 1666 for(u2=0; u2<u1; u2++)
|
Line 1666 for(u2=0; u2<u1; u2++)
|
c_addr[u2] = (Char)c; |
c_addr[u2] = (Char)c; |
} |
} |
wior=FILEIO(ferror((FILE *)wfileid)); |
wior=FILEIO(ferror((FILE *)wfileid)); |
#else |
|
if ((flag=FLAG(!feof((FILE *)wfileid) && |
|
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
|
wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ |
|
if (wior) |
|
clearerr((FILE *)wfileid); |
|
u2 = strlen(c_addr); |
|
u2-=((u2>0) && (c_addr[u2-1]==NEWLINE)); |
|
} |
|
else { |
|
wior=0; |
|
u2=0; |
|
} |
|
#endif |
|
|
|
\+ |
\+ |
|
|
Line 1710 PUTC(c);
|
Line 1696 PUTC(c);
|
flush-file ( wfileid -- wior ) file-ext flush_file |
flush-file ( wfileid -- wior ) file-ext flush_file |
wior = IOR(fflush((FILE *) wfileid)==EOF); |
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); |
char *filename=tilde_cstr(c_addr, u, 1); |
if (access (filename, F_OK) != 0) { |
if (access (filename, F_OK) != 0) { |
ntype=0; |
wfam=0; |
wior=IOR(1); |
wior=IOR(1); |
} |
} |
else if (access (filename, R_OK | W_OK) == 0) { |
else if (access (filename, R_OK | W_OK) == 0) { |
ntype=2; /* r/w */ |
wfam=2; /* r/w */ |
wior=0; |
wior=0; |
} |
} |
else if (access (filename, R_OK) == 0) { |
else if (access (filename, R_OK) == 0) { |
ntype=0; /* r/o */ |
wfam=0; /* r/o */ |
wior=0; |
wior=0; |
} |
} |
else if (access (filename, W_OK) == 0) { |
else if (access (filename, W_OK) == 0) { |
ntype=4; /* w/o */ |
wfam=4; /* w/o */ |
wior=0; |
wior=0; |
} |
} |
else { |
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. */ |
access mode (r/o bin), so we get a decent error later upon open. */ |
wior=0; |
wior=0; |
} |
} |
Line 1877 f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
|
Line 1863 f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
|
memmove(c_addr,sig,u); |
memmove(c_addr,sig,u); |
|
|
>float ( c_addr u -- flag ) float to_float |
>float ( c_addr u -- flag ) float to_float |
""Attempt to convert the character string @i{c-addr u} to |
""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the |
internal floating-point representation. If the string |
character string @i{c-addr u} to internal floating-point |
represents a valid floating-point number @i{r} is placed |
representation. If the string represents a valid floating-point number |
on the floating-point stack and @i{flag} is true. Otherwise, |
@i{r} is placed on the floating-point stack and @i{flag} is |
@i{flag} is false. A string of blanks is a special case |
true. Otherwise, @i{flag} is false. A string of blanks is a special |
and represents the floating-point number 0."" |
case and represents the floating-point number 0."" |
/* real signature: c_addr u -- r t / f */ |
/* real signature: c_addr u -- r t / f */ |
Float r; |
Float r; |
char *number=cstr(c_addr, u, 1); |
char *number=cstr(c_addr, u, 1); |
Line 2261 c_addr=newline;
|
Line 2247 c_addr=newline;
|
u=sizeof(newline); |
u=sizeof(newline); |
: |
: |
"newline count ; |
"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 |
utime ( -- dtime ) gforth |
""Report the current time in microseconds since some epoch."" |
""Report the current time in microseconds since some epoch."" |
Line 2284 dsystem = timeval2us(&usage.ru_stime);
|
Line 2272 dsystem = timeval2us(&usage.ru_stime);
|
struct timeval time1; |
struct timeval time1; |
gettimeofday(&time1,NULL); |
gettimeofday(&time1,NULL); |
duser = timeval2us(&time1); |
duser = timeval2us(&time1); |
|
#ifndef BUGGY_LONG_LONG |
dsystem = (DCell)0; |
dsystem = (DCell)0; |
|
#else |
|
dsystem=(DCell){0,0}; |
#endif |
#endif |
|
#endif |
|
|
|
\+ |
|
|
|
\+floating |
|
|
v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star |
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 |
""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the |
Line 2296 for (r=0.; ucount>0; ucount--) {
|
Line 2292 for (r=0.; ucount>0; ucount--) {
|
f_addr1 = (Float *)(((Address)f_addr1)+nstride1); |
f_addr1 = (Float *)(((Address)f_addr1)+nstride1); |
f_addr2 = (Float *)(((Address)f_addr2)+nstride2); |
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 |
faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth |
""vy=ra*vx+vy"" |
""vy=ra*vx+vy"" |
Line 2304 for (; ucount>0; ucount--) {
|
Line 2304 for (; ucount>0; ucount--) {
|
f_x = (Float *)(((Address)f_x)+nstridex); |
f_x = (Float *)(((Address)f_x)+nstridex); |
f_y = (Float *)(((Address)f_y)+nstridey); |
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<u1; u2++) |
|
{ |
|
c = getc((FILE *)wfileid); |
|
u3++; |
|
if (c=='\n') break; |
|
if (c=='\r') { |
|
if ((c = getc((FILE *)wfileid))!='\n') |
|
ungetc(c,(FILE *)wfileid); |
|
else |
|
u3++; |
|
break; |
|
} |
|
if (c==EOF) { |
|
flag=FLAG(u2!=0); |
|
break; |
|
} |
|
c_addr[u2] = (Char)c; |
|
} |
|
wior=FILEIO(ferror((FILE *)wfileid)); |
|
|
|
\+ |