version 1.99, 2002/09/24 16:50:28
|
version 1.106, 2002/12/16 20:40:10
|
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 1708 r = d;
|
Line 1718 r = d;
|
#endif |
#endif |
|
|
f>d ( r -- d ) float f_to_d |
f>d ( r -- d ) float f_to_d |
#ifdef BUGGY_LONG_LONG |
extern DCell double2ll(Float r); |
d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0); |
d = double2ll(r); |
d.lo = r-ldexp((Float)d.hi,CELL_BITS); |
|
#else |
|
d = r; |
|
#endif |
|
|
|
f! ( r f_addr -- ) float f_store |
f! ( r f_addr -- ) float f_store |
""Store @i{r} into the float at address @i{f-addr}."" |
""Store @i{r} into the float at address @i{f-addr}."" |
Line 1803 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 2411 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 2420 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); |
Line 2433 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 2443 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 2454 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 2490 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 2508 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 2521 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 2532 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 2551 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 2566 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 2581 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 2601 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 2617 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 2633 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 2649 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 2664 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) |