version 1.101, 2002/10/27 09:57:11
|
version 1.104, 2002/12/13 15:49:53
|
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 2408 xt = peephole_opt(xt1, xt2, wpeeptable);
|
Line 2417 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 2417 call ( #a_callee -- R:a_retaddr ) new
|
Line 2430 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); |
Line 2430 lit@ ( #a_addr -- w ) new lit_fetch
|
Line 2444 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 2440 lit+ ( n1 #n2 -- n ) new lit_plus
|
Line 2456 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 2451 IF_spTOS(spTOS = sp[0]);
|
Line 2471 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 2487 SUPER_CONTINUE;
|
Line 2532 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 2505 a?dup-?branch ( #a_target f -- f ) new a
|
Line 2550 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 2518 few cycles in that case, but is easy to
|
Line 2568 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 2529 SUPER_CONTINUE;
|
Line 2583 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 2548 acondbranch(a(+loop),n R:nlimit R:n1 --
|
Line 2602 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 2563 if ((olddiff^(olddiff+n))>=0 /* the li
|
Line 2617 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 2578 if (n<0) {
|
Line 2632 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 2598 SUPER_CONTINUE;
|
Line 2659 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 2614 SUPER_CONTINUE;
|
Line 2682 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 2630 SUPER_CONTINUE;
|
Line 2705 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 2646 SUPER_CONTINUE;
|
Line 2728 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 2661 SUPER_CONTINUE;
|
Line 2750 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 ( a_code -- f ) gforth-internal forget_dyncode |
|
f = forget_dyncode(a_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) |