version 1.100, 2002/10/04 19:17:05
|
version 1.108, 2002/12/24 23:40:29
|
Line 148 lit ( #w -- w ) gforth
|
Line 148 lit ( #w -- w ) gforth
|
|
|
execute ( xt -- ) core |
execute ( xt -- ) core |
""Perform the semantics represented by the execution token, @i{xt}."" |
""Perform the semantics represented by the execution token, @i{xt}."" |
|
#ifndef NO_IP |
ip=IP; |
ip=IP; |
|
#endif |
IF_spTOS(spTOS = sp[0]); |
IF_spTOS(spTOS = sp[0]); |
SUPER_END; |
SUPER_END; |
EXEC(xt); |
EXEC(xt); |
Line 156 EXEC(xt);
|
Line 158 EXEC(xt);
|
perform ( a_addr -- ) gforth |
perform ( a_addr -- ) gforth |
""@code{@@ execute}."" |
""@code{@@ execute}."" |
/* and pfe */ |
/* and pfe */ |
|
#ifndef NO_IP |
ip=IP; |
ip=IP; |
|
#endif |
IF_spTOS(spTOS = sp[0]); |
IF_spTOS(spTOS = sp[0]); |
SUPER_END; |
SUPER_END; |
EXEC(*(Xt *)a_addr); |
EXEC(*(Xt *)a_addr); |
Line 961 fp = f_addr;
|
Line 965 fp = f_addr;
|
|
|
;s ( R:w -- ) gforth semis |
;s ( R:w -- ) gforth semis |
""The primitive compiled by @code{EXIT}."" |
""The primitive compiled by @code{EXIT}."" |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
goto *(void *)w; |
|
#else |
SET_IP((Xt *)w); |
SET_IP((Xt *)w); |
|
#endif |
|
|
\g stack |
\g stack |
|
|
Line 1279 while(u1--)
|
Line 1288 while(u1--)
|
ASCII strings (larger if ubits is large), and should share no |
ASCII strings (larger if ubits is large), and should share no |
divisors with ubits. |
divisors with ubits. |
*/ |
*/ |
unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits]; |
static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5}; |
|
unsigned rot = rot_values[ubits]; |
Char *cp = c_addr; |
Char *cp = c_addr; |
for (ukey=0; cp<c_addr+u; cp++) |
for (ukey=0; cp<c_addr+u; cp++) |
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) |
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) |
Line 1595 wior = IOR(rename(tilde_cstr(c_addr1, u1
|
Line 1605 wior = IOR(rename(tilde_cstr(c_addr1, u1
|
|
|
file-position ( wfileid -- ud wior ) file file_position |
file-position ( wfileid -- ud wior ) file file_position |
/* !! use tell and lseek? */ |
/* !! use tell and lseek? */ |
ud = LONG2UD(ftell((FILE *)wfileid)); |
ud = OFF2UD(ftello((FILE *)wfileid)); |
wior = IOR(UD2LONG(ud)==-1); |
wior = IOR(UD2OFF(ud)==-1); |
|
|
reposition-file ( ud wfileid -- wior ) file reposition_file |
reposition-file ( ud wfileid -- wior ) file reposition_file |
wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); |
wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); |
|
|
file-size ( wfileid -- ud wior ) file file_size |
file-size ( wfileid -- ud wior ) file file_size |
struct stat buf; |
struct stat buf; |
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); |
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); |
ud = LONG2UD(buf.st_size); |
ud = OFF2UD(buf.st_size); |
|
|
resize-file ( ud wfileid -- wior ) file resize_file |
resize-file ( ud wfileid -- wior ) file resize_file |
wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1); |
wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); |
|
|
read-file ( c_addr u1 wfileid -- u2 wior ) file read_file |
read-file ( c_addr u1 wfileid -- u2 wior ) file read_file |
/* !! fread does not guarantee enough */ |
/* !! fread does not guarantee enough */ |
Line 1799 floor ( r1 -- r2 ) float
|
Line 1809 floor ( r1 -- r2 ) float
|
/* !! unclear wording */ |
/* !! unclear wording */ |
r2 = floor(r1); |
r2 = floor(r1); |
|
|
fround ( r1 -- r2 ) float f_round |
fround ( r1 -- r2 ) gforth f_round |
""Round to the nearest integral value."" |
""Round to the nearest integral value."" |
/* !! unclear wording */ |
|
#ifdef HAVE_RINT |
|
r2 = rint(r1); |
r2 = rint(r1); |
#else |
|
r2 = floor(r1+0.5); |
|
/* !! This is not quite true to the rounding rules given in the standard */ |
|
#endif |
|
|
|
fmax ( r1 r2 -- r3 ) float f_max |
fmax ( r1 r2 -- r3 ) float f_max |
if (r1<r2) |
if (r1<r2) |
Line 2407 xt = peephole_opt(xt1, xt2, wpeeptable);
|
Line 2411 xt = peephole_opt(xt1, xt2, wpeeptable);
|
|
|
call ( #a_callee -- R:a_retaddr ) new |
call ( #a_callee -- R:a_retaddr ) new |
""Call callee (a variant of docol with inline argument)."" |
""Call callee (a variant of docol with inline argument)."" |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
JUMP(a_callee); |
|
#else |
#ifdef DEBUG |
#ifdef DEBUG |
{ |
{ |
CFA_TO_NAME((((Cell *)a_callee)-2)); |
CFA_TO_NAME((((Cell *)a_callee)-2)); |
Line 2416 call ( #a_callee -- R:a_retaddr ) new
|
Line 2424 call ( #a_callee -- R:a_retaddr ) new
|
#endif |
#endif |
a_retaddr = (Cell *)IP; |
a_retaddr = (Cell *)IP; |
SET_IP((Xt *)a_callee); |
SET_IP((Xt *)a_callee); |
|
#endif |
|
|
useraddr ( #u -- a_addr ) new |
useraddr ( #u -- a_addr ) new |
a_addr = (Cell *)(up+u); |
a_addr = (Cell *)(up+u); |
|
|
compile-prim ( xt1 -- xt2 ) new compile_prim |
compile-prim ( xt1 -- xt2 ) obsolete compile_prim |
xt2 = (Xt)compile_prim((Label)xt1); |
xt2 = (Xt)compile_prim((Label)xt1); |
|
|
\ lit@ / lit_fetch = lit @ |
\ lit@ / lit_fetch = lit @ |
Line 2429 lit@ ( #a_addr -- w ) new lit_fetch
|
Line 2438 lit@ ( #a_addr -- w ) new lit_fetch
|
w = *a_addr; |
w = *a_addr; |
|
|
lit-perform ( #a_addr -- ) new lit_perform |
lit-perform ( #a_addr -- ) new lit_perform |
|
#ifndef NO_IP |
ip=IP; |
ip=IP; |
|
#endif |
SUPER_END; |
SUPER_END; |
EXEC(*(Xt *)a_addr); |
EXEC(*(Xt *)a_addr); |
|
|
Line 2439 lit+ ( n1 #n2 -- n ) new lit_plus
|
Line 2450 lit+ ( n1 #n2 -- n ) new lit_plus
|
n=n1+n2; |
n=n1+n2; |
|
|
does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec |
does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec |
|
#ifdef NO_IP |
|
/* compiled to LIT CALL by compile_prim */ |
|
assert(0); |
|
#else |
a_pfa = PFA(a_cfa); |
a_pfa = PFA(a_cfa); |
nest = (Cell)ip; |
nest = (Cell)IP; |
IF_spTOS(spTOS = sp[0]); |
IF_spTOS(spTOS = sp[0]); |
#ifdef DEBUG |
#ifdef DEBUG |
{ |
{ |
Line 2450 IF_spTOS(spTOS = sp[0]);
|
Line 2465 IF_spTOS(spTOS = sp[0]);
|
} |
} |
#endif |
#endif |
SET_IP(DOES_CODE1(a_cfa)); |
SET_IP(DOES_CODE1(a_cfa)); |
|
#endif |
|
|
abranch-lp+!# ( #a_target #nlocals -- ) gforth abranch_lp_plus_store_number |
abranch-lp+!# ( #a_target #nlocals -- ) gforth abranch_lp_plus_store_number |
/* this will probably not be used */ |
/* this will probably not be used */ |
lp += nlocals; |
lp += nlocals; |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
JUMP(a_target); |
|
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
|
#endif |
|
|
\+ |
\+ |
|
|
abranch ( #a_target -- ) gforth |
abranch ( #a_target -- ) gforth |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
JUMP(a_target); |
|
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
|
#endif |
: |
: |
r> @ >r ; |
r> @ >r ; |
|
|
\ acondbranch(forthname,stackeffect,restline,code,forthcode) |
\ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode) |
\ this is non-syntactical: code must open a brace that is closed by the macro |
\ this is non-syntactical: code must open a brace that is closed by the macro |
define(acondbranch, |
define(acondbranch, |
$1 ( `#'a_target $2 ) $3 |
$1 ( `#'a_target $2 ) $3 |
$4 SET_IP((Xt *)a_target); |
$4 #ifdef NO_IP |
INST_TAIL; |
INST_TAIL; |
|
#endif |
|
$5 #ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
$5 |
$6 |
|
|
\+glocals |
\+glocals |
|
|
$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number |
$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number |
$4 lp += nlocals; |
$4 #ifdef NO_IP |
SET_IP((Xt *)a_target); |
|
INST_TAIL; |
INST_TAIL; |
|
#endif |
|
$5 lp += nlocals; |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
|
|
Line 2486 SUPER_CONTINUE;
|
Line 2526 SUPER_CONTINUE;
|
) |
) |
|
|
acondbranch(a?branch,f --,f83 aquestion_branch, |
acondbranch(a?branch,f --,f83 aquestion_branch, |
if (f==0) { |
,if (f==0) { |
,: |
,: |
0= dup \ !f !f \ !! still uses relative addresses |
0= dup \ !f !f \ !! still uses relative addresses |
r> dup @ \ !f !f IP branchoffset |
r> dup @ \ !f !f IP branchoffset |
Line 2504 a?dup-?branch ( #a_target f -- f ) new a
|
Line 2544 a?dup-?branch ( #a_target f -- f ) new a
|
if (f==0) { |
if (f==0) { |
sp++; |
sp++; |
IF_spTOS(spTOS = sp[0]); |
IF_spTOS(spTOS = sp[0]); |
SET_IP((Xt *)a_target); |
#ifdef NO_IP |
INST_TAIL; |
INST_TAIL; |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
|
|
Line 2517 few cycles in that case, but is easy to
|
Line 2562 few cycles in that case, but is easy to
|
invocation */ |
invocation */ |
if (f!=0) { |
if (f!=0) { |
sp--; |
sp--; |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
NEXT; |
NEXT; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
|
|
Line 2528 SUPER_CONTINUE;
|
Line 2577 SUPER_CONTINUE;
|
|
|
acondbranch(a(next),R:n1 -- R:n2,cmFORTH aparen_next, |
acondbranch(a(next),R:n1 -- R:n2,cmFORTH aparen_next, |
n2=n1-1; |
n2=n1-1; |
if (n1) { |
,if (n1) { |
,: |
,: |
r> r> dup 1- >r |
r> r> dup 1- >r |
IF @ >r ELSE cell+ >r THEN ;) |
IF @ >r ELSE cell+ >r THEN ;) |
|
|
acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_loop, |
acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_loop, |
n2=n1+1; |
n2=n1+1; |
if (n2 != nlimit) { |
,if (n2 != nlimit) { |
,: |
,: |
r> r> 1+ r> 2dup = |
r> r> 1+ r> 2dup = |
IF >r 1- >r cell+ >r |
IF >r 1- >r cell+ >r |
Line 2547 acondbranch(a(+loop),n R:nlimit R:n1 --
|
Line 2596 acondbranch(a(+loop),n R:nlimit R:n1 --
|
/* dependent upon two's complement arithmetic */ |
/* dependent upon two's complement arithmetic */ |
Cell olddiff = n1-nlimit; |
Cell olddiff = n1-nlimit; |
n2=n1+n; |
n2=n1+n; |
if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ |
,if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ |
|| (olddiff^n)>=0 /* it is a wrap-around effect */) { |
|| (olddiff^n)>=0 /* it is a wrap-around effect */) { |
,: |
,: |
r> swap |
r> swap |
Line 2562 if ((olddiff^(olddiff+n))>=0 /* the li
|
Line 2611 if ((olddiff^(olddiff+n))>=0 /* the li
|
acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop, |
acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop, |
UCell olddiff = n1-nlimit; |
UCell olddiff = n1-nlimit; |
n2=n1-u; |
n2=n1-u; |
if (olddiff>u) { |
,if (olddiff>u) { |
,) |
,) |
|
|
acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_symmetric_plus_loop, |
acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_symmetric_plus_loop, |
Line 2577 if (n<0) {
|
Line 2626 if (n<0) {
|
newdiff = -newdiff; |
newdiff = -newdiff; |
} |
} |
n2=n1+n; |
n2=n1+n; |
if (diff>=0 || newdiff<0) { |
,if (diff>=0 || newdiff<0) { |
,) |
,) |
|
|
a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_question_do |
a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_question_do |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
#endif |
if (nstart == nlimit) { |
if (nstart == nlimit) { |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
INST_TAIL; |
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
: |
: |
Line 2597 SUPER_CONTINUE;
|
Line 2653 SUPER_CONTINUE;
|
\+xconds |
\+xconds |
|
|
a(+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do |
a(+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
#endif |
if (nstart >= nlimit) { |
if (nstart >= nlimit) { |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
INST_TAIL; |
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
: |
: |
Line 2613 SUPER_CONTINUE;
|
Line 2676 SUPER_CONTINUE;
|
THEN >r ; |
THEN >r ; |
|
|
a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do |
a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do |
if (ustart >= ulimit) { |
#ifdef NO_IP |
SET_IP((Xt *)a_target); |
|
INST_TAIL; |
INST_TAIL; |
|
#endif |
|
if (ustart >= ulimit) { |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
: |
: |
Line 2629 SUPER_CONTINUE;
|
Line 2699 SUPER_CONTINUE;
|
THEN >r ; |
THEN >r ; |
|
|
a(-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do |
a(-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do |
if (nstart <= nlimit) { |
#ifdef NO_IP |
SET_IP((Xt *)a_target); |
|
INST_TAIL; |
INST_TAIL; |
|
#endif |
|
if (nstart <= nlimit) { |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
: |
: |
Line 2645 SUPER_CONTINUE;
|
Line 2722 SUPER_CONTINUE;
|
THEN >r ; |
THEN >r ; |
|
|
a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do |
a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do |
if (ustart <= ulimit) { |
#ifdef NO_IP |
SET_IP((Xt *)a_target); |
|
INST_TAIL; |
INST_TAIL; |
|
#endif |
|
if (ustart <= ulimit) { |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
} |
} |
SUPER_CONTINUE; |
SUPER_CONTINUE; |
: |
: |
Line 2660 SUPER_CONTINUE;
|
Line 2744 SUPER_CONTINUE;
|
cell+ |
cell+ |
THEN >r ; |
THEN >r ; |
|
|
|
\ set-next-code and call2 do not appear in images and can be |
|
\ renumbered arbitrarily |
|
|
|
set-next-code ( #w -- ) gforth set_next_code |
|
#ifdef NO_IP |
|
next_code = (Label)w; |
|
#endif |
|
|
|
call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth |
|
/* call with explicit return address */ |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
JUMP(a_callee); |
|
#else |
|
assert(0); |
|
#endif |
|
|
|
compile-prim1 ( a_prim -- ) gforth compile_prim1 |
|
""compile prim (incl. immargs) at @var{a_prim}"" |
|
compile_prim1(a_prim); |
|
|
|
finish-code ( -- ) gforth finish_code |
|
""Perform delayed steps in code generation (branch resolution, I-cache |
|
flushing)."" |
|
finish_code(); |
|
|
|
forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode |
|
f = forget_dyncode(c_code); |
|
|
|
decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim |
|
""a_prim is the code address of the primitive that has been |
|
compile_prim1ed to a_code"" |
|
a_prim = decompile_code(a_code); |
|
|
\+ |
\+ |
|
|
include(peeprules.vmg) |
include(peeprules.vmg) |