version 1.68, 2000/12/24 15:54:18
|
version 1.79, 2001/03/18 12:39:33
|
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') |
|
|
noop ( -- ) gforth |
noop ( -- ) gforth |
: |
: |
Line 140 execute ( xt -- ) core
|
Line 144 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 152 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 1186 f83name2=f83name1;
|
Line 1192 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 1423 cache.""
|
Line 1429 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 2157 if(dent == NULL) {
|
Line 2164 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 2175 flag = FLAG(!fnmatch(pattern, string, 0)
|
Line 2184 flag = FLAG(!fnmatch(pattern, string, 0)
|
newline ( -- c_addr u ) gforth |
newline ( -- c_addr u ) gforth |
""String containing the newline sequence of the host OS"" |
""String containing the newline sequence of the host OS"" |
char newline[] = { |
char newline[] = { |
#ifdef unix |
#if defined(unix) || defined(__MACH__) |
|
/* Darwin/MacOS X sets __MACH__, but not unix. */ |
'\n' |
'\n' |
#else |
#else |
'\r','\n' |
'\r','\n' |
Line 2276 for(u2=0; u2<u1; u2++)
|
Line 2286 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 ; |
|
|
|
\+ |
|
|
|
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); |
|
|
|
lit_plus = lit + |
|
|
|
call ( #a_callee -- R:a_retaddr ) |
|
""Call callee (a variant of docol with inline argument)."" |
|
a_retaddr = (Cell *)IP; |
|
SET_IP((Xt *)a_callee); |
|
|
|
useraddr ( #u -- a_addr ) |
|
a_addr = (Cell *)(up+u); |
|
|
|
|
|
|