version 1.72, 2001/02/04 22:37:12
|
version 1.87, 2001/12/25 16:55:10
|
Line 72
|
Line 72
|
\ df_.* DFloat * |
\ df_.* DFloat * |
\ sf_.* SFloat * |
\ sf_.* SFloat * |
\ xt.* XT |
\ xt.* XT |
\ wid.* WID |
|
\ f83name.* F83Name * |
\ f83name.* F83Name * |
|
|
|
\E stack data-stack sp Cell |
|
\E stack fp-stack fp Float |
|
\E stack return-stack rp Cell |
|
\E |
\E get-current prefixes set-current |
\E get-current prefixes set-current |
\E |
\E |
\E s" Bool" single data-stack type-prefix f |
\E s" Bool" single data-stack type-prefix f |
Line 91
|
Line 94
|
\E s" DFloat *" single data-stack type-prefix df_ |
\E s" DFloat *" single data-stack type-prefix df_ |
\E s" SFloat *" single data-stack type-prefix sf_ |
\E s" SFloat *" single data-stack type-prefix sf_ |
\E s" Xt" single data-stack type-prefix xt |
\E s" Xt" single data-stack type-prefix xt |
\E s" WID" single data-stack type-prefix wid |
|
\E s" struct F83Name *" single data-stack type-prefix f83name |
\E s" struct F83Name *" single data-stack type-prefix f83name |
\E s" struct Longname *" single data-stack type-prefix longname |
\E s" struct Longname *" single data-stack type-prefix longname |
\E |
\E |
Line 128
|
Line 130
|
\ these m4 macros would collide with identifiers |
\ these m4 macros would collide with identifiers |
undefine(`index') |
undefine(`index') |
undefine(`shift') |
undefine(`shift') |
|
undefine(`symbols') |
|
|
|
\g control |
|
|
noop ( -- ) gforth |
noop ( -- ) gforth |
: |
: |
Line 141 execute ( xt -- ) core
|
Line 146 execute ( xt -- ) core
|
""Perform the semantics represented by the execution token, @i{xt}."" |
""Perform the semantics represented by the execution token, @i{xt}."" |
ip=IP; |
ip=IP; |
IF_spTOS(spTOS = sp[0]); |
IF_spTOS(spTOS = sp[0]); |
|
SUPER_END; |
EXEC(xt); |
EXEC(xt); |
|
|
perform ( a_addr -- ) gforth |
perform ( a_addr -- ) gforth |
Line 148 perform ( a_addr -- ) gforth
|
Line 154 perform ( a_addr -- ) gforth
|
/* and pfe */ |
/* and pfe */ |
ip=IP; |
ip=IP; |
IF_spTOS(spTOS = sp[0]); |
IF_spTOS(spTOS = sp[0]); |
|
SUPER_END; |
EXEC(*(Xt *)a_addr); |
EXEC(*(Xt *)a_addr); |
: |
: |
@ execute ; |
@ execute ; |
Line 174 $1 ( `#'ndisp $2 ) $3
|
Line 181 $1 ( `#'ndisp $2 ) $3
|
$4 SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
$4 SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
$5 |
$5 |
|
|
\+glocals |
\+glocals |
Line 183 $4 lp += nlocals;
|
Line 191 $4 lp += nlocals;
|
SET_IP((Xt *)(((Cell)(IP-2))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-2))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
|
|
\+ |
\+ |
) |
) |
Line 209 if (f==0) {
|
Line 218 if (f==0) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
|
|
?dup-0=-?branch ( #ndisp f -- ) new question_dupe_zero_equals_question_branch |
?dup-0=-?branch ( #ndisp f -- ) new question_dupe_zero_equals_question_branch |
""The run-time procedure compiled by @code{?DUP-0=-IF}."" |
""The run-time procedure compiled by @code{?DUP-0=-IF}."" |
Line 221 if (f!=0) {
|
Line 231 if (f!=0) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
NEXT; |
NEXT; |
} |
} |
|
SUPER_CONTINUE; |
|
|
\+ |
\+ |
\f[THEN] |
\f[THEN] |
Line 302 if (nstart == nlimit) {
|
Line 313 if (nstart == nlimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
2dup = |
2dup = |
IF r> swap rot >r >r |
IF r> swap rot >r >r |
Line 317 if (nstart >= nlimit) {
|
Line 329 if (nstart >= nlimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 332 if (ustart >= ulimit) {
|
Line 345 if (ustart >= ulimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 347 if (nstart <= nlimit) {
|
Line 361 if (nstart <= nlimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 362 if (ustart <= ulimit) {
|
Line 377 if (ustart <= ulimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 404 k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
|
Line 420 k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
|
|
|
\ digit is high-level: 0/0% |
\ digit is high-level: 0/0% |
|
|
|
\g strings |
|
|
move ( c_from c_to ucount -- ) core |
move ( c_from c_to ucount -- ) core |
""Copy the contents of @i{ucount} aus at @i{c-from} to |
""Copy the contents of @i{ucount} aus at @i{c-from} to |
@i{c-to}. @code{move} works correctly even if the two areas overlap."" |
@i{c-to}. @code{move} works correctly even if the two areas overlap."" |
Line 513 u2 = u1-n;
|
Line 531 u2 = u1-n;
|
: |
: |
tuck - >r + r> dup 0< IF - 0 THEN ; |
tuck - >r + r> dup 0< IF - 0 THEN ; |
|
|
|
\g arith |
|
|
+ ( n1 n2 -- n ) core plus |
+ ( n1 n2 -- n ) core plus |
n = n1+n2; |
n = n1+n2; |
|
|
Line 910 f = FLAG(u1-u2 < u3-u2);
|
Line 930 f = FLAG(u1-u2 < u3-u2);
|
: |
: |
over - >r - r> u< ; |
over - >r - r> u< ; |
|
|
|
\g internal |
|
|
sp@ ( -- a_addr ) gforth sp_fetch |
sp@ ( -- a_addr ) gforth sp_fetch |
a_addr = sp+1; |
a_addr = sp+1; |
|
|
Line 937 fp = f_addr;
|
Line 959 fp = f_addr;
|
""The primitive compiled by @code{EXIT}."" |
""The primitive compiled by @code{EXIT}."" |
SET_IP((Xt *)w); |
SET_IP((Xt *)w); |
|
|
|
\g stack |
|
|
>r ( w -- R:w ) core to_r |
>r ( w -- R:w ) core to_r |
: |
: |
(>r) ; |
(>r) ; |
Line 1376 n=1;
|
Line 1400 n=1;
|
|
|
\f[THEN] |
\f[THEN] |
|
|
|
\g hostos |
|
|
key-file ( wfileid -- n ) gforth paren_key_file |
key-file ( wfileid -- n ) gforth paren_key_file |
#ifdef HAS_FILE |
#ifdef HAS_FILE |
fflush(stdout); |
fflush(stdout); |
Line 1424 cache.""
|
Line 1450 cache.""
|
FLUSH_ICACHE(c_addr,u); |
FLUSH_ICACHE(c_addr,u); |
|
|
(bye) ( n -- ) gforth paren_bye |
(bye) ( n -- ) gforth paren_bye |
|
SUPER_END; |
return (Label *)n; |
return (Label *)n; |
|
|
(system) ( c_addr u -- wretval wior ) gforth peren_system |
(system) ( c_addr u -- wretval wior ) gforth peren_system |
Line 1448 c_addr2 = getenv(cstr(c_addr1,u1,1));
|
Line 1475 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 wfam -- 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[wfam]); /* ~ expansion of 1st arg? */ |
wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[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 1590 if (wior)
|
Line 1617 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 |
""this is only for backward compatibility"" |
/* this may one day be replaced with : read-line (read-line) nip ; */ |
Cell c; |
Cell c; |
flag=-1; |
flag=-1; |
for(u2=0; u2<u1; u2++) |
for(u2=0; u2<u1; u2++) |
Line 1666 else {
|
Line 1693 else {
|
\+ |
\+ |
\+floating |
\+floating |
|
|
|
\g floating |
|
|
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) |
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) |
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) |
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) |
|
|
Line 2137 Variable UP
|
Line 2166 Variable UP
|
wcall ( u -- ) gforth |
wcall ( u -- ) gforth |
IF_fpTOS(fp[0]=fpTOS); |
IF_fpTOS(fp[0]=fpTOS); |
FP=fp; |
FP=fp; |
sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP); |
sp=(Cell*)(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP); |
fp=FP; |
fp=FP; |
IF_spTOS(spTOS=sp[0];) |
IF_spTOS(spTOS=sp[0];) |
IF_fpTOS(fpTOS=fp[0]); |
IF_fpTOS(fpTOS=fp[0]); |
Line 2345 while(a_addr != NULL)
|
Line 2374 while(a_addr != NULL)
|
|
|
\+ |
\+ |
|
|
|
\+peephole |
|
|
|
\g peephole |
|
|
|
primtable ( -- wprimtable ) new |
|
""wprimtable is a table containing the xts of the primitives indexed |
|
by sequence-number in prim (for use in prepare-peephole-table)."" |
|
wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1); |
|
|
|
prepare-peephole-table ( wprimtable -- wpeeptable ) new prepare_peephole_opt |
|
""wpeeptable is a data structure used by @code{peephole-opt}; it is |
|
constructed by combining a primitives table with a simple peephole |
|
optimization table."" |
|
wpeeptable = prepare_peephole_table((Xt *)wprimtable); |
|
|
|
peephole-opt ( xt1 xt2 wpeeptable -- xt ) new peephole_opt |
|
""xt is the combination of xt1 and xt2 (according to wpeeptable); if |
|
they cannot be combined, xt is 0."" |
|
xt = peephole_opt(xt1, xt2, wpeeptable); |
|
|
|
call ( #a_callee -- R:a_retaddr ) new |
|
""Call callee (a variant of docol with inline argument)."" |
|
a_retaddr = (Cell *)IP; |
|
SET_IP((Xt *)a_callee); |
|
|
|
useraddr ( #u -- a_addr ) new |
|
a_addr = (Cell *)(up+u); |
|
|
|
compile-prim ( xt1 -- xt2 ) new compile_prim |
|
xt2 = (Xt)compile_prim((Label)xt1); |
|
|
|
include(peeprules.vmg) |
|
|
|
\+ |