version 1.66, 2010/04/11 15:37:22
|
version 1.75, 2010/09/12 17:10:04
|
Line 81 DEFER nlcount ' noop IS nlcount
|
Line 81 DEFER nlcount ' noop IS nlcount
|
IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN |
IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN |
THEN ; |
THEN ; |
|
|
|
|
|
Defer xt-see-xt ( xt -- ) |
|
\ this one is just a forward declaration for indirect recursion |
|
|
|
: .defname ( xt c-addr u -- ) |
|
rot look |
|
if ( c-addr u nfa ) |
|
-rot type space .name |
|
else |
|
drop ." noname " type |
|
then |
|
space ; |
|
|
|
Defer discode ( addr u -- ) \ gforth |
|
\G hook for the disassembler: disassemble u bytes of code at addr |
|
' dump IS discode |
|
|
|
: next-head ( addr1 -- addr2 ) \ gforth |
|
\G find the next header starting after addr1, up to here (unreliable). |
|
here swap u+do |
|
i head? -2 and if |
|
i unloop exit |
|
then |
|
cell +loop |
|
here ; |
|
|
|
[ifundef] umin \ !! bootstrapping help |
|
: umin ( u1 u2 -- u ) |
|
2dup u> |
|
if |
|
swap |
|
then |
|
drop ; |
|
[then] |
|
|
|
: next-prim ( addr1 -- addr2 ) \ gforth |
|
\G find the next primitive after addr1 (unreliable) |
|
1+ >r -1 primstart |
|
begin ( umin head R: boundary ) |
|
@ dup |
|
while |
|
tuck name>int >code-address ( head1 umin ca R: boundary ) |
|
r@ - umin |
|
swap |
|
repeat |
|
drop dup r@ negate u>= |
|
\ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)" |
|
if ( umin R: boundary ) \ no primitive found behind -> use a default length |
|
drop 31 |
|
then |
|
r> + ; |
|
|
DEFER .string ( c-addr u n -- ) |
DEFER .string ( c-addr u n -- ) |
|
|
[IFDEF] Green |
[IFDEF] Green |
Line 254 VARIABLE C-Pass
|
Line 306 VARIABLE C-Pass
|
: Scan? ( -- flag ) C-Pass @ 0= ; |
: Scan? ( -- flag ) C-Pass @ 0= ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
|
: ?.string ( c-addr u n -- ) Display? if .string else 2drop drop then ; |
|
|
: back? ( addr target -- addr flag ) |
: back? ( addr target -- addr flag ) |
over u< ; |
over u< ; |
Line 293 VARIABLE C-Pass
|
Line 346 VARIABLE C-Pass
|
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
\ here over - 2constant doers |
\ here over - 2constant doers |
|
|
|
[IFDEF] !does |
|
: c-does> \ end of create part |
|
Display? IF S" DOES> " Com# .string THEN ; |
|
\ maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff |
|
[THEN] |
|
|
: c-lit ( addr1 -- addr2 ) |
: c-lit ( addr1 -- addr2 ) |
Display? IF |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
( addr1 addr1@ ) |
( addr1 addr1@ ) |
dup body> @ dovar: = if |
dup body> @ dovar: = if |
drop c-call EXIT |
drop c-call EXIT |
|
endif |
|
endif |
endif |
|
endif |
|
over 4 cells + over = if |
|
over 1 cells + @ decompile-prim ['] call xt>threaded = >r |
|
over 3 cells + @ decompile-prim ['] ;S xt>threaded = |
|
r> and if |
|
over 2 cells + @ ['] !does >body = if drop |
|
S" DOES> " Com# ?.string 4 cells + EXIT endif |
|
endif |
|
[IFDEF] !;abi-code |
|
over 2 cells + @ ['] !;abi-code >body = if drop |
|
S" ;abi-code " Com# ?.string 4 cells + |
|
c-stop on |
|
Display? if |
|
dup dup next-head over - discode |
|
S" end-code" Com# ?.string |
|
then EXIT |
|
endif |
|
[THEN] |
|
endif |
|
Display? if |
\ !! test for cfa here, and print "['] ..." |
\ !! test for cfa here, and print "['] ..." |
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
endif |
else drop then |
cell+ ; |
cell+ ; |
|
|
: c-lit+ ( addr1 -- addr2 ) |
: c-lit+ ( addr1 -- addr2 ) |
Line 441 VARIABLE C-Pass
|
Line 518 VARIABLE C-Pass
|
ELSE |
ELSE |
dup cell+ BranchAddr? Forward? |
dup cell+ BranchAddr? Forward? |
IF dup cell+ @ WhileCode2 = |
IF dup cell+ @ WhileCode2 = |
IF nl S" ELSE" .struc level+ |
IF nl S" ELSE " .struc level+ |
ELSE level- nl S" ELSE" .struc level+ THEN |
ELSE level- nl S" ELSE" .struc level+ THEN |
cell+ Disable swap ! |
cell+ Disable swap ! |
ELSE S" AHEAD" .struc level+ |
ELSE S" AHEAD " .struc level+ |
THEN |
THEN |
THEN |
THEN |
THEN |
THEN |
Line 529 VARIABLE C-Pass
|
Line 606 VARIABLE C-Pass
|
ELSE 2drop |
ELSE 2drop |
THEN ; |
THEN ; |
|
|
[IFDEF] (does>) |
|
: c-does> \ end of create part |
|
Display? IF S" DOES> " Com# .string THEN ; |
|
\ maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff |
|
[THEN] |
|
|
|
[IFDEF] (compile) |
[IFDEF] (compile) |
: c-(compile) |
: c-(compile) |
Display? |
Display? |
Line 576 CREATE C-Table
|
Line 647 CREATE C-Table
|
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
[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] |
|
0 , here 0 , |
0 , here 0 , |
|
|
avariable c-extender |
avariable c-extender |
Line 644 c-extender !
|
Line 714 c-extender !
|
c-stop @ |
c-stop @ |
UNTIL drop ; |
UNTIL drop ; |
|
|
Defer xt-see-xt ( xt -- ) |
|
\ this one is just a forward declaration for indirect recursion |
|
|
|
: .defname ( xt c-addr u -- ) |
|
rot look |
|
if ( c-addr u nfa ) |
|
-rot type space .name |
|
else |
|
drop ." noname " type |
|
then |
|
space ; |
|
|
|
Defer discode ( addr u -- ) \ gforth |
|
\G hook for the disassembler: disassemble code at addr of length u |
|
' dump IS discode |
|
|
|
: next-head ( addr1 -- addr2 ) \ gforth |
|
\G find the next header starting after addr1, up to here (unreliable). |
|
here swap u+do |
|
i head? -2 and if |
|
i unloop exit |
|
then |
|
cell +loop |
|
here ; |
|
|
|
[ifundef] umin \ !! bootstrapping help |
|
: umin ( u1 u2 -- u ) |
|
2dup u> |
|
if |
|
swap |
|
then |
|
drop ; |
|
[then] |
|
|
|
: next-prim ( addr1 -- addr2 ) \ gforth |
|
\G find the next primitive after addr1 (unreliable) |
|
1+ >r -1 primstart |
|
begin ( umin head R: boundary ) |
|
@ dup |
|
while |
|
tuck name>int >code-address ( head1 umin ca R: boundary ) |
|
r@ - umin |
|
swap |
|
repeat |
|
drop dup r@ negate u>= |
|
\ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)" |
|
if ( umin R: boundary ) \ no primitive found behind -> use a default length |
|
drop 31 |
|
then |
|
r> + ; |
|
|
|
: seecode ( xt -- ) |
: seecode ( xt -- ) |
dup s" Code" .defname |
dup s" Code" .defname |
>code-address |
>code-address |
Line 706 Defer discode ( addr u -- ) \ gforth
|
Line 725 Defer discode ( addr u -- ) \ gforth
|
then |
then |
over - discode |
over - discode |
." end-code" cr ; |
." end-code" cr ; |
|
: seeabicode ( xt -- ) |
|
dup s" ABI-Code" .defname |
|
>body dup dup next-head |
|
swap - discode |
|
." end-code" cr ; |
: seevar ( xt -- ) |
: seevar ( xt -- ) |
s" Variable" .defname cr ; |
s" Variable" .defname cr ; |
: seeuser ( xt -- ) |
: seeuser ( xt -- ) |
Line 771 Defer discode ( addr u -- ) \ gforth
|
Line 795 Defer discode ( addr u -- ) \ gforth
|
[IFDEF] dofield: |
[IFDEF] dofield: |
dofield: of seefield endof |
dofield: of seefield endof |
[THEN] |
[THEN] |
|
[IFDEF] doabicode: |
|
doabicode: of seeabicode endof |
|
[THEN] |
over of seecode endof \ direct threaded code words |
over of seecode endof \ direct threaded code words |
over >body of seecode endof \ indirect threaded code words |
over >body of seecode endof \ indirect threaded code words |
2drop abort" unknown word type" |
2drop abort" unknown word type" |