version 1.13, 1996/08/21 14:58:44
|
version 1.14, 1996/08/26 10:07:21
|
Line 459 CREATE C-Table
|
Line 459 CREATE C-Table
|
' f@local# A, ' c-f@local# A, |
' f@local# A, ' c-f@local# A, |
' laddr# A, ' c-laddr# A, |
' laddr# A, ' c-laddr# A, |
' lp+!# A, ' c-lp+!# A, |
' lp+!# A, ' c-lp+!# A, |
' (s") A, ' c-s" A, |
' (s") A, ' c-s" A, |
' (.") A, ' c-." A, |
' (.") A, ' c-." A, |
' "lit A, ' c-c" A, |
' "lit A, ' c-c" A, |
' leave A, ' c-leave A, |
comp' leave drop A, ' c-leave A, |
' ?leave A, ' c-?leave A, |
comp' ?leave drop A, ' c-?leave A, |
' (do) A, ' c-do A, |
' (do) A, ' c-do A, |
' (?do) A, ' c-?do A, |
' (?do) A, ' c-?do A, |
' (for) A, ' c-for A, |
' (for) A, ' c-for A, |
Line 535 CREATE C-Table
|
Line 535 CREATE C-Table
|
Branches on ; |
Branches on ; |
|
|
: makepass ( a-addr -- ) |
: makepass ( a-addr -- ) |
c-stop off |
c-stop off |
BEGIN |
BEGIN |
analyse |
analyse |
c-stop @ |
c-stop @ |
UNTIL drop ; |
UNTIL drop ; |
|
|
DEFER dosee |
Defer xt-see-xt ( xt -- ) |
|
\ this one is just a forward declaration for indirect recursion |
: dopri .name ." is primitive" cr ; |
|
: dovar ." Variable " .name cr ; |
: .defname ( xt c-addr u -- ) |
: douse ." User " .name cr ; |
rot look |
: docon dup ((name>)) >body @ . ." Constant " .name cr ; |
if ( c-addr u nfa ) |
: doval dup ((name>)) >body @ . ." Value " .name cr ; |
-rot type space .name |
: dodef ." Defer " dup >r .name cr |
else |
r@ ((name>)) >body @ look |
drop ." noname " type |
0= ABORT" SEE: No valid xt in deferred word" |
then |
dup dosee cr |
space ; |
." ' " .name r> ." IS " .name cr ; |
|
: dodoe ." Create " dup .name cr |
Defer discode ( addr -- ) |
S" DOES> " Com# .string XPos @ Level ! name>int |
\ hook for the disassembler: disassemble code at addr (as far as the |
>does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN |
\ disassembler thinks is sensible) |
ScanMode c-pass ! dup makepass |
:noname ( addr -- ) |
DisplayMode c-pass ! makepass ; |
drop ." ..." ; |
: doali here @ .name ." Alias " .name cr |
IS discode |
here @ dosee ; |
|
: docol |
: seecode ( xt -- ) |
S" : " Com# .string |
dup s" Code" .defname |
dup name>string 2 pick wordinfo .string bl cemit bl cemit |
>body discode |
( XPos @ ) 2 Level ! |
." end-code" cr ; |
name>int >body |
: seevar ( xt -- ) |
C-Pass @ DebugMode = |
s" Variable" .defname cr ; |
IF |
: seeuser ( xt -- ) |
ScanMode c-pass ! EXIT |
s" User" .defname cr ; |
|
: seecon ( xt -- ) |
|
dup >body ? |
|
s" Constant" .defname cr ; |
|
: seevalue ( xt -- ) |
|
dup >body ? |
|
s" Value" .defname cr ; |
|
: seedefer ( xt -- ) |
|
dup >body @ xt-see-xt cr |
|
dup s" Defer" .defname cr |
|
>name dup ??? = if |
|
drop ." lastxt >body !" |
|
else |
|
." IS " .name cr |
|
then ; |
|
: see-threaded ( addr -- ) |
|
C-Pass @ DebugMode = IF |
|
ScanMode c-pass ! |
|
EXIT |
THEN |
THEN |
ScanMode c-pass ! dup makepass |
ScanMode c-pass ! dup makepass |
DisplayMode c-pass ! makepass ; |
DisplayMode c-pass ! makepass ; |
|
: seedoes ( xt -- ) |
create wordtypes |
dup s" create" .defname cr |
Pri# , ' dopri A, |
S" DOES> " Com# .string XPos @ Level ! |
Var# , ' dovar A, |
>does-code see-threaded ; |
Con# , ' docon A, |
: seecol ( xt -- ) |
Val# , ' doval A, |
dup s" :" .defname cr |
Def# , ' dodef A, |
2 Level ! |
Doe# , ' dodoe A, |
>body see-threaded ; |
Ali# , ' doali A, |
: seefield ( xt -- ) |
Col# , ' docol A, |
dup >body ." 0 " ? ." 0 0 " |
Use# , ' douse A, |
s" Field" .defname cr ; |
0 , |
|
|
: xt-see ( xt -- ) |
: (dosee) ( lfa -- ) |
cr c-init |
dup dup cell+ c@ >r |
dup >does-code |
wordinfo |
if |
wordtypes |
seedoes EXIT |
BEGIN dup @ dup |
then |
WHILE 2 pick = IF cell+ @ nip EXECUTE |
dup forthstart u< |
r> dup immediate-mask and IF ." immediate" THEN |
if |
restrict-mask and IF ." restrict" THEN |
seecode EXIT |
EXIT THEN |
then |
2 cells + |
dup >code-address |
REPEAT |
CASE |
2drop rdrop |
docon: of seecon endof |
.name ." Don't know how to handle" cr ; |
docol: of seecol endof |
|
dovar: of seevar endof |
' (dosee) IS dosee |
douser: of seeuser endof |
|
dodefer: of seedefer endof |
: xtc ( xt -- ) \ do see at xt |
dofield: of seefield endof |
Look 0= ABORT" SEE: No valid XT" |
over >body of seecode endof |
cr c-init |
2drop abort" unknown word type" |
dosee ; |
ENDCASE ; |
|
|
|
: (xt-see-xt) ( xt -- ) |
|
xt-see cr ." lastxt" ; |
|
' (xt-see-xt) is xt-see-xt |
|
|
|
: (.immediate) ( xt -- ) |
|
['] execute = if |
|
." immediate" |
|
then ; |
|
|
|
: name-see ( nfa -- ) |
|
dup name>int >r |
|
dup name>comp |
|
over r@ = |
|
if \ normal or immediate word |
|
swap xt-see (.immediate) |
|
else |
|
r@ ['] compile-only-error = |
|
if \ compile-only word |
|
swap xt-see (.immediate) ." compile-only" |
|
else \ interpret/compile word |
|
r@ xt-see-xt cr |
|
swap xt-see-xt cr |
|
." interpret/compile " over .name (.immediate) |
|
then |
|
then |
|
rdrop drop ; |
|
|
: see ( "name" -- ) \ tools |
: see ( "name" -- ) \ tools |
name find-name dup 0= |
name find-name dup 0= |
IF |
IF |
drop -&13 bounce |
drop -&13 bounce |
THEN |
THEN |
name>int xtc ; |
name-see ; |
|
|
: lfc cr c-init cell+ dosee ; |
|
: nfc cr c-init dosee ; |
|
|
|
|
|