version 1.69, 2001/01/09 16:11:35
|
version 1.91, 2002/01/20 19:04: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 |
\E |
\E return-stack stack-prefix R: |
\E return-stack stack-prefix R: |
\E inst-stream stack-prefix # |
\E inst-stream stack-prefix # |
Line 127
|
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 140 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 147 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 173 $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 182 $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 208 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 220 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 301 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 316 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 331 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 346 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 361 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 403 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 512 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 909 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 936 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 1186 f83name2=f83name1;
|
Line 1211 f83name2=f83name1;
|
r> @ |
r> @ |
REPEAT THEN nip nip ; |
REPEAT THEN nip nip ; |
: (find-samelen) ( u f83name1 -- u f83name2/0 ) |
: (find-samelen) ( u f83name1 -- u f83name2/0 ) |
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
|
|
\+hash |
\+hash |
|
|
Line 1331 a_addr = (Cell *)DOES_CODE(xt);
|
Line 1356 a_addr = (Cell *)DOES_CODE(xt);
|
code-address! ( c_addr xt -- ) gforth code_address_store |
code-address! ( c_addr xt -- ) gforth code_address_store |
""Create a code field with code address @i{c-addr} at @i{xt}."" |
""Create a code field with code address @i{c-addr} at @i{xt}."" |
MAKE_CF(xt, c_addr); |
MAKE_CF(xt, c_addr); |
CACHE_FLUSH(xt,(size_t)PFA(0)); |
|
: |
: |
! ; |
! ; |
|
|
Line 1339 does-code! ( a_addr xt -- ) gforth does
|
Line 1363 does-code! ( a_addr xt -- ) gforth does
|
""Create a code field at @i{xt} for a child of a @code{DOES>}-word; |
""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>}."" |
@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)); |
|
: |
: |
dodoes: over ! cell+ ! ; |
dodoes: over ! cell+ ! ; |
|
|
Line 1347 does-handler! ( a_addr -- ) gforth does_
|
Line 1370 does-handler! ( a_addr -- ) gforth does_
|
""Create a @code{DOES>}-handler at address @i{a-addr}. Normally, |
""Create a @code{DOES>}-handler at address @i{a-addr}. Normally, |
@i{a-addr} points 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); |
|
: |
: |
drop ; |
drop ; |
|
|
Line 1375 n=1;
|
Line 1397 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 1423 cache.""
|
Line 1447 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 1447 c_addr2 = getenv(cstr(c_addr1,u1,1));
|
Line 1472 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 1589 if (wior)
|
Line 1614 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 1665 else {
|
Line 1690 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 2136 Variable UP
|
Line 2163 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 2157 if(dent == NULL) {
|
Line 2184 if(dent == NULL) {
|
flag = 0; |
flag = 0; |
} else { |
} else { |
u2 = strlen(dent->d_name); |
u2 = strlen(dent->d_name); |
if(u2 > u1) |
if(u2 > u1) { |
u2 = u1; |
u2 = u1; |
|
wior = -512-ENAMETOOLONG; |
|
} |
memmove(c_addr, dent->d_name, u2); |
memmove(c_addr, dent->d_name, u2); |
} |
} |
|
|
Line 2277 for(u2=0; u2<u1; u2++)
|
Line 2306 for(u2=0; u2<u1; u2++)
|
wior=FILEIO(ferror((FILE *)wfileid)); |
wior=FILEIO(ferror((FILE *)wfileid)); |
|
|
\+ |
\+ |
|
|
|
(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind |
|
for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next)) |
|
if ((UCell)LONGNAME_COUNT(longname1)==u && |
|
memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) |
|
break; |
|
longname2=longname1; |
|
: |
|
BEGIN dup WHILE (findl-samelen) dup WHILE |
|
>r 2dup r@ cell+ cell+ capscomp 0= |
|
IF 2drop r> EXIT THEN |
|
r> @ |
|
REPEAT THEN nip nip ; |
|
: (findl-samelen) ( u longname1 -- u longname2/0 ) |
|
BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ; |
|
|
|
\+hash |
|
|
|
(hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind |
|
struct Longname *longname1; |
|
longname2=NULL; |
|
while(a_addr != NULL) |
|
{ |
|
longname1=(struct Longname *)(a_addr[1]); |
|
a_addr=(Cell *)(a_addr[0]); |
|
if ((UCell)LONGNAME_COUNT(longname1)==u && |
|
memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) |
|
{ |
|
longname2=longname1; |
|
break; |
|
} |
|
} |
|
: |
|
BEGIN dup WHILE |
|
2@ >r >r dup r@ cell+ @ lcount-mask and = |
|
IF 2dup r@ cell+ cell+ capscomp 0= |
|
IF 2drop r> rdrop EXIT THEN THEN |
|
rdrop r> |
|
REPEAT nip nip ; |
|
|
|
(tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind |
|
""A case-sensitive variant of @code{(hashfind)}"" |
|
struct Longname *longname1; |
|
longname2=NULL; |
|
while(a_addr != NULL) |
|
{ |
|
longname1=(struct Longname *)(a_addr[1]); |
|
a_addr=(Cell *)(a_addr[0]); |
|
if ((UCell)LONGNAME_COUNT(longname1)==u && |
|
memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) |
|
{ |
|
longname2=longname1; |
|
break; |
|
} |
|
} |
|
: |
|
BEGIN dup WHILE |
|
2@ >r >r dup r@ cell+ @ lcount-mask and = |
|
IF 2dup r@ cell+ cell+ -text 0= |
|
IF 2drop r> rdrop EXIT THEN THEN |
|
rdrop r> |
|
REPEAT nip nip ; |
|
|
|
\+ |
|
|
|
\+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)."" |
|
#ifdef DEBUG |
|
{ |
|
CFA_TO_NAME((((Cell *)a_callee)-2)); |
|
fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee, |
|
len,name); |
|
} |
|
#endif |
|
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); |
|
|
|
lit@ ( #a_addr -- w ) new lit_fetch |
|
w = *a_addr; |
|
|
|
lit-perform ( #a_addr -- ) new lit_perform |
|
ip=IP; |
|
SUPER_END; |
|
EXEC(*(Xt *)a_addr); |
|
|
|
lit+ ( #n1 n2 -- n3 ) new lit_plus |
|
n3 = n1 + n2; |
|
|
|
does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec |
|
a_pfa = PFA(a_cfa); |
|
nest = (Cell)ip; |
|
IF_spTOS(spTOS = sp[0]); |
|
#ifdef DEBUG |
|
{ |
|
CFA_TO_NAME(a_cfa); |
|
fprintf(stderr,"%08lx: does %08lx %.*s\n", |
|
(Cell)ip,(Cell)a_cfa,len,name); |
|
} |
|
#endif |
|
SET_IP(DOES_CODE1(a_cfa)); |
|
|
|
include(peeprules.vmg) |
|
|
|
\+ |