version 1.52, 2000/08/09 20:04:06
|
version 1.57, 2000/08/21 20:08:01
|
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 819 w2 = ~w1;
|
Line 819 w2 = ~w1;
|
MAXU xor ; |
MAXU xor ; |
|
|
rshift ( u1 n -- u2 ) core r_shift |
rshift ( u1 n -- u2 ) core r_shift |
|
""Logical shift right by @i{n} bits."" |
u2 = u1>>n; |
u2 = u1>>n; |
: |
: |
0 ?DO 2/ MAXI and LOOP ; |
0 ?DO 2/ MAXI and LOOP ; |
Line 1223 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 1503 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 1598 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 1709 PUTC(c);
|
Line 1710 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 1876 f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
|
Line 1877 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 2260 c_addr=newline;
|
Line 2261 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 2283 dsystem = timeval2us(&usage.ru_stime);
|
Line 2286 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 2295 for (r=0.; ucount>0; ucount--) {
|
Line 2306 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 2303 for (; ucount>0; ucount--) {
|
Line 2318 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 ; |
|
|
|
\+ |