version 1.115, 2003/01/08 09:38:28
|
version 1.122, 2003/01/23 21:45:59
|
Line 1404 while(a_addr != NULL)
|
Line 1404 while(a_addr != NULL)
|
rdrop r> |
rdrop r> |
REPEAT nip nip ; |
REPEAT nip nip ; |
|
|
(hashkey) ( c_addr u1 -- u2 ) gforth paren_hashkey |
|
u2=0; |
|
while(u1--) |
|
u2+=(Cell)toupper(*c_addr++); |
|
: |
|
0 -rot bounds ?DO I c@ toupper + LOOP ; |
|
|
|
(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 |
(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 |
""ukey is the hash key for the string c_addr u fitting in ubits bits"" |
""ukey is the hash key for the string c_addr u fitting in ubits bits"" |
/* this hash function rotates the key at every step by rot bits within |
/* this hash function rotates the key at every step by rot bits within |
Line 1473 f_addr = (Float *)((((Cell)c_addr)+(size
|
Line 1466 f_addr = (Float *)((((Cell)c_addr)+(size
|
: |
: |
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
|
|
>body ( xt -- a_addr ) core to_body |
|
"" Get the address of the body of the word represented by @i{xt} (the address |
|
of the word's data field)."" |
|
a_addr = PFA(xt); |
|
: |
|
2 cells + ; |
|
|
|
\ threading stuff is currently only interesting if we have a compiler |
\ threading stuff is currently only interesting if we have a compiler |
\fhas? standardthreading has? compiler and [IF] |
\fhas? standardthreading has? compiler and [IF] |
|
|
>code-address ( xt -- c_addr ) gforth to_code_address |
|
""@i{c-addr} is the code address of the word @i{xt}."" |
|
/* !! This behaves installation-dependently for DOES-words */ |
|
c_addr = (Address)CODE_ADDRESS(xt); |
|
: |
|
@ ; |
|
|
|
>does-code ( xt -- a_addr ) gforth to_does_code |
|
""If @i{xt} is the execution token of a child of a @code{DOES>} word, |
|
@i{a-addr} is the start of the Forth code after the @code{DOES>}; |
|
Otherwise @i{a-addr} is 0."" |
|
a_addr = (Cell *)DOES_CODE(xt); |
|
: |
|
cell+ @ ; |
|
|
|
code-address! ( c_addr xt -- ) gforth code_address_store |
|
""Create a code field with code address @i{c-addr} at @i{xt}."" |
|
MAKE_CF(xt, c_addr); |
|
: |
|
! ; |
|
|
|
does-code! ( a_addr xt -- ) gforth does_code_store |
|
""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>}."" |
|
MAKE_DOES_CF(xt, a_addr); |
|
: |
|
dodoes: over ! cell+ ! ; |
|
|
|
does-handler! ( a_addr -- ) gforth does_handler_store |
|
""Create a @code{DOES>}-handler at address @i{a-addr}. Normally, |
|
@i{a-addr} points just behind a @code{DOES>}."" |
|
MAKE_DOES_HANDLER(a_addr); |
|
: |
|
drop ; |
|
|
|
/does-handler ( -- n ) gforth slash_does_handler |
|
""The size of a @code{DOES>}-handler (includes possible padding)."" |
|
/* !! a constant or environmental query might be better */ |
|
n = DOES_HANDLER_SIZE; |
|
: |
|
2 cells ; |
|
|
|
threading-method ( -- n ) gforth threading_method |
threading-method ( -- n ) gforth threading_method |
""0 if the engine is direct threaded. Note that this may change during |
""0 if the engine is direct threaded. Note that this may change during |
the lifetime of an image."" |
the lifetime of an image."" |
Line 2061 else
|
Line 2004 else
|
|
|
represent ( r c_addr u -- n f1 f2 ) float |
represent ( r c_addr u -- n f1 f2 ) float |
char *sig; |
char *sig; |
|
size_t siglen; |
int flag; |
int flag; |
int decpt; |
int decpt; |
sig=ecvt(r, u, &decpt, &flag); |
sig=ecvt(r, u, &decpt, &flag); |
n=(r==0 ? 1 : decpt); |
n=(r==0. ? 1 : decpt); |
f1=FLAG(flag!=0); |
f1=FLAG(flag!=0); |
f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
memmove(c_addr,sig,u); |
siglen=strlen(sig); |
|
memcpy(c_addr,sig,siglen); |
|
memset(c_addr+siglen,'0',u-siglen); |
|
|
>float ( c_addr u -- flag ) float to_float |
>float ( c_addr u -- flag ) float to_float |
""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the |
""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the |
Line 2436 IF_fpTOS(fpTOS=fp[0]);
|
Line 2382 IF_fpTOS(fpTOS=fp[0]);
|
|
|
\g peephole |
\g peephole |
|
|
primtable ( -- wprimtable ) new |
compile-prim1 ( a_prim -- ) gforth compile_prim1 |
""wprimtable is a table containing the xts of the primitives indexed |
""compile prim (incl. immargs) at @var{a_prim}"" |
by sequence-number in prim (for use in prepare-peephole-table)."" |
compile_prim1(a_prim); |
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); |
|
|
|
compile-prim ( xt1 -- xt2 ) obsolete compile_prim |
finish-code ( -- ) gforth finish_code |
xt2 = (Xt)compile_prim((Label)xt1); |
""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 = (Cell *)decompile_code((Label)a_code); |
|
|
\ set-next-code and call2 do not appear in images and can be |
\ set-next-code and call2 do not appear in images and can be |
\ renumbered arbitrarily |
\ renumbered arbitrarily |
Line 2472 JUMP(a_callee);
|
Line 2416 JUMP(a_callee);
|
assert(0); |
assert(0); |
#endif |
#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 = (Label)decompile_code((Label)a_code); |
|
|
|
\+ |
\+ |
|
|
include(peeprules.vmg) |
include(peeprules.vmg) |