version 1.41, 2002/09/14 11:18:57
|
version 1.44, 2002/12/25 21:16:54
|
Line 248 VARIABLE C-Pass
|
Line 248 VARIABLE C-Pass
|
: back? ( n -- flag ) 0< ; |
: back? ( n -- flag ) 0< ; |
: ahead? ( n -- flag ) 0> ; |
: ahead? ( n -- flag ) 0> ; |
|
|
: c-lit |
|
Display? IF |
|
dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
THEN |
|
cell+ ; |
|
|
|
: .word ( addr xt -- addr ) |
: .word ( addr xt -- addr ) |
look 0= IF |
look 0= IF |
drop dup 1 cells - @ dup body> look |
drop dup 1 cells - @ dup body> look |
Line 270 VARIABLE C-Pass
|
Line 264 VARIABLE C-Pass
|
dup name>string rot wordinfo .string |
dup name>string rot wordinfo .string |
THEN ; |
THEN ; |
|
|
: c-call |
: c-call ( addr1 -- addr2 ) |
Display? IF ." call " dup @ body> .word bl cemit THEN cell+ ; |
Display? IF |
|
dup @ body> .word bl cemit |
|
THEN |
|
cell+ ; |
|
|
|
: c-callxt ( addr1 -- addr2 ) |
|
Display? IF |
|
dup @ .word bl cemit |
|
THEN |
|
cell+ ; |
|
|
|
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
|
\ here over - 2constant doers |
|
|
|
: c-lit ( addr1 -- addr2 ) |
|
Display? IF |
|
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
|
( addr1 addr1@ ) |
|
dup body> @ dovar: = if |
|
drop c-call EXIT |
|
endif |
|
endif |
|
\ !! test for cfa here, and print "['] ..." |
|
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
endif |
|
cell+ ; |
|
|
|
: c-lit+ ( addr1 -- addr2 ) |
|
Display? if |
|
dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
s" + " 0 .string |
|
endif |
|
cell+ ; |
|
|
: .name-without ( addr -- addr ) |
: .name-without ( addr -- addr ) |
\ prints a name without () e.g. (+LOOP) or (s") |
\ prints a name without () e.g. (+LOOP) or (s") |
Line 444 VARIABLE C-Pass
|
Line 470 VARIABLE C-Pass
|
|
|
CREATE C-Table |
CREATE C-Table |
' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
|
' does-exec A, ' c-callxt A, |
|
' lit@ A, ' c-call A, |
[IFDEF] call ' call A, ' c-call A, [THEN] |
[IFDEF] call ' call A, ' c-call A, [THEN] |
' (s") A, ' c-c" A, |
\ ' useraddr A, .... |
' (.") A, ' c-c" A, |
' lit-perform A, ' c-call A, |
' "lit A, ' c-c" A, |
' lit+ A, ' c-lit+ A, |
|
[IFDEF] (s") ' (s") A, ' c-c" A, [THEN] |
|
[IFDEF] (.") ' (.") A, ' c-c" A, [THEN] |
|
[IFDEF] "lit ' "lit A, ' c-c" A, [THEN] |
[IFDEF] (c") ' (c") A, ' c-c" A, [THEN] |
[IFDEF] (c") ' (c") A, ' c-c" A, [THEN] |
' (do) A, ' c-do A, |
' (do) A, ' c-do A, |
[IFDEF] (+do) ' (+do) A, ' c-do A, [THEN] |
[IFDEF] (+do) ' (+do) A, ' c-do A, [THEN] |
Line 464 CREATE C-Table
|
Line 495 CREATE C-Table
|
[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN] |
[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN] |
' (next) A, ' c-loop A, |
' (next) A, ' c-loop A, |
' ;s A, ' c-exit A, |
' ;s A, ' c-exit A, |
' (abort") A, ' c-abort" A, |
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
\ only defined if compiler is loaded |
\ only defined if compiler is loaded |
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN] |
[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN] |
Line 475 c-extender !
|
Line 506 c-extender !
|
|
|
\ DOTABLE 15may93jaw |
\ DOTABLE 15may93jaw |
|
|
: DoTable ( cfa -- flag ) |
: DoTable ( ca/cfa -- flag ) |
C-Table |
decompile-prim C-Table BEGIN ( cfa table-entry ) |
BEGIN dup @ dup 0= |
dup @ dup 0= IF |
IF drop cell+ @ dup |
drop cell+ @ dup IF ( next table!) |
IF ( next table!) dup @ ELSE |
dup @ |
( end!) 2drop false EXIT THEN |
ELSE ( end!) |
THEN |
2drop false EXIT |
\ jump over to extender, if any 26jan97jaw |
THEN |
xt>threaded 2 pick <> |
THEN |
WHILE 2 cells + |
\ jump over to extender, if any 26jan97jaw |
REPEAT |
xt>threaded 2 pick <> |
nip cell+ perform |
WHILE |
true |
2 cells + |
; |
REPEAT |
|
nip cell+ perform |
|
true |
|
; |
|
|
: BranchTo? ( a-addr -- a-addr ) |
: BranchTo? ( a-addr -- a-addr ) |
Display? IF dup BranchAddr? |
Display? IF dup BranchAddr? |
Line 551 Defer discode ( addr u -- ) \ gforth
|
Line 585 Defer discode ( addr u -- ) \ gforth
|
: next-head ( addr1 -- addr2 ) \ gforth |
: next-head ( addr1 -- addr2 ) \ gforth |
\G find the next header starting after addr1, up to here (unreliable). |
\G find the next header starting after addr1, up to here (unreliable). |
here swap u+do |
here swap u+do |
i head? |
i head? -2 and if |
if |
|
i unloop exit |
i unloop exit |
then |
then |
cell +loop |
cell +loop |