| : level- -7 Level +! ; |
: level- -7 Level +! ; |
| |
|
| VARIABLE nlflag |
VARIABLE nlflag |
| |
VARIABLE uppercase \ structure words are in uppercase |
| |
|
| DEFER nlcount ' noop IS nlcount |
DEFER nlcount ' noop IS nlcount |
| |
|
| nlflag @ IF (nl) nlflag off THEN |
nlflag @ IF (nl) nlflag off THEN |
| XPos @ over + cols u>= IF (nl) THEN ; |
XPos @ over + cols u>= IF (nl) THEN ; |
| |
|
| |
: c-to-upper |
| |
dup [char] a >= over [char] z <= and if bl - then ; |
| |
|
| : ctype ( adr len -- ) |
: ctype ( adr len -- ) |
| warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ; |
warp? dup XPos +! C-Output @ |
| |
IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP |
| |
uppercase off ELSE type THEN |
| |
ELSE 2drop THEN ; |
| |
|
| : cemit 1 warp? |
: cemit 1 warp? |
| over bl = Level @ XPos @ = and |
over bl = Level @ XPos @ = and |
| ' (.string) IS .string |
' (.string) IS .string |
| |
|
| |
|
| : .struc Str# .string ; |
: .struc |
| |
uppercase on Str# .string ; |
| |
|
| \ CODES 15may93jaw |
\ CODES 15may93jaw |
| |
|
| THEN |
THEN |
| cell+ ; |
cell+ ; |
| |
|
| : c-@local# |
|
| Display? IF |
|
| S" @local" 0 .string |
|
| dup @ dup 1 cells / abs 0 <# #S rot sign #> 0 .string bl cemit |
|
| THEN |
|
| cell+ ; |
|
| |
|
| : c-flit |
|
| Display? IF |
|
| dup f@ scratch represent 0= |
|
| IF 2drop scratch 3 min 0 .string |
|
| ELSE |
|
| IF '- cemit THEN 1- |
|
| scratch over c@ cemit '. cemit 1 /string 0 .string |
|
| 'E cemit |
|
| dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
| THEN THEN |
|
| float+ ; |
|
| |
|
| : c-f@local# |
|
| Display? IF |
|
| S" f@local" 0 .string |
|
| dup @ dup 1 floats / abs 0 <# #S rot sign #> 0 .string bl cemit |
|
| THEN |
|
| cell+ ; |
|
| |
|
| : c-laddr# |
|
| Display? IF |
|
| S" laddr# " 0 .string |
|
| dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
| THEN |
|
| cell+ ; |
|
| |
|
| : c-lp+!# |
|
| Display? IF |
|
| S" lp+!# " 0 .string |
|
| dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
| THEN |
|
| cell+ ; |
|
| |
|
| : c-s" |
: c-s" |
| count 2dup + aligned -rot |
count 2dup + aligned -rot |
| Display? |
Display? |
| DebugBranch |
DebugBranch |
| cell+ ; |
cell+ ; |
| |
|
| : c-?branch-lp+!# c-?branch cell+ ; |
|
| : c-branch-lp+!# c-branch cell+ ; |
|
| |
|
| : c-do |
|
| Display? IF nl S" DO" .struc level+ THEN ; |
|
| |
|
| : c-?do |
|
| Display? IF nl S" ?DO" .struc level+ THEN |
|
| DebugBranch cell+ ; |
|
| |
|
| : c-for |
: c-for |
| Display? IF nl S" FOR" .struc level+ THEN ; |
Display? IF nl S" FOR" .struc level+ THEN ; |
| |
|
| : c-next |
: .name-without |
| Display? IF level- nl S" NEXT " .struc nl THEN |
dup 1 cells - @ look IF name>string 1 /string 1- .struc ELSE drop THEN ; |
| DebugBranch cell+ cell+ ; |
|
| |
|
| : c-loop |
: c-loop |
| Display? IF level- nl S" LOOP " .struc nl THEN |
Display? IF level- nl .name-without bl cemit nl THEN |
| DebugBranch cell+ cell+ ; |
|
| |
|
| : c-+loop |
|
| Display? IF level- nl S" +LOOP " .struc nl THEN |
|
| DebugBranch cell+ cell+ ; |
|
| |
|
| : c-s+loop |
|
| Display? IF level- nl S" S+LOOP " .struc nl THEN |
|
| DebugBranch cell+ cell+ ; |
DebugBranch cell+ cell+ ; |
| |
|
| : c--loop |
: c-do |
| Display? IF level- nl S" -LOOP " .struc nl THEN |
Display? IF nl .name-without level+ THEN ; |
| DebugBranch cell+ cell+ ; |
|
| |
|
| : c-next-lp+!# c-next cell+ ; |
: c-?do |
| : c-loop-lp+!# c-loop cell+ ; |
Display? IF nl S" ?DO" .struc level+ THEN |
| : c-+loop-lp+!# c-+loop cell+ ; |
DebugBranch cell+ ; |
| : c-s+loop-lp+!# c-s+loop cell+ ; |
|
| : c--loop-lp+!# c--loop cell+ ; |
|
| |
|
| : c-leave |
: c-leave |
| Display? IF S" LEAVE " .struc THEN |
Display? IF S" LEAVE " .struc THEN |
| |
|
| CREATE C-Table |
CREATE C-Table |
| ' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
| ' @local# A, ' c-@local# A, |
|
| ' flit A, ' c-flit A, |
|
| ' f@local# A, ' c-f@local# A, |
|
| ' laddr# A, ' c-laddr# 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, |
| |
' (u+do) A, ' c-do A, |
| |
' (-do) A, ' c-do A, |
| |
' (u-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, |
| ' ?branch A, ' c-?branch A, |
' ?branch A, ' c-?branch A, |
| ' branch A, ' c-branch A, |
' branch A, ' c-branch A, |
| ' (loop) A, ' c-loop A, |
' (loop) A, ' c-loop A, |
| ' (+loop) A, ' c-+loop A, |
' (+loop) A, ' c-loop A, |
| ' (s+loop) A, ' c-s+loop A, |
' (s+loop) A, ' c-loop A, |
| ' (-loop) A, ' c--loop A, |
' (-loop) A, ' c-loop A, |
| ' (next) A, ' c-next A, |
' (next) A, ' c-loop A, |
| ' ?branch-lp+!# A, ' c-?branch-lp+!# A, |
|
| ' branch-lp+!# A, ' c-branch-lp+!# A, |
|
| ' (loop)-lp+!# A, ' c-loop-lp+!# A, |
|
| ' (+loop)-lp+!# A, ' c-+loop-lp+!# A, |
|
| ' (s+loop)-lp+!# A, ' c-s+loop-lp+!# A, |
|
| ' (-loop)-lp+!# A, ' c--loop-lp+!# A, |
|
| ' (next)-lp+!# A, ' c-next-lp+!# A, |
|
| ' ;s A, ' c-exit A, |
' ;s A, ' c-exit A, |
| ' (does>) A, ' c-does> A, |
' (does>) A, ' c-does> A, |
| ' (abort") A, ' c-abort" A, |
' (abort") A, ' c-abort" A, |
| ' (compile) A, ' c-(compile) A, |
' (compile) A, ' c-(compile) A, |
| 0 , |
0 , here 0 , |
| |
|
| |
avariable c-extender |
| |
c-extender ! |
| |
|
| \ DOTABLE 15may93jaw |
\ DOTABLE 15may93jaw |
| |
|
| : DoTable ( cfa -- flag ) |
: DoTable ( cfa -- flag ) |
| C-Table |
C-Table |
| BEGIN dup @ dup |
BEGIN dup @ dup 0= |
| WHILE 2 pick <> |
IF drop cell+ @ dup |
| |
IF ( next table!) dup @ ELSE |
| |
( end!) 2drop false EXIT THEN |
| |
THEN |
| |
\ jump over to extender, if any 26jan97jaw |
| |
2 pick <> |
| WHILE 2 cells + |
WHILE 2 cells + |
| REPEAT |
REPEAT |
| nip cell+ @ EXECUTE |
nip cell+ perform |
| true |
true |
| ELSE |
; |
| 2drop drop false |
|
| THEN ; |
|
| |
|
| : BranchTo? ( a-addr -- a-addr ) |
: BranchTo? ( a-addr -- a-addr ) |
| Display? IF dup BranchAddr? |
Display? IF dup BranchAddr? |
| IF BEGIN cell+ @ dup 20 u> |
IF |
| |
BEGIN cell+ @ dup 20 u> |
| IF drop nl S" BEGIN " .struc level+ |
IF drop nl S" BEGIN " .struc level+ |
| ELSE |
ELSE |
| dup Disable <> |
dup Disable <> |
| 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 ; |
: .defname ( xt c-addr u -- ) |
| : dovar ." Variable " .name cr ; |
rot look |
| : douse ." User " .name cr ; |
if ( c-addr u nfa ) |
| : docon dup cell+ (name>) >body @ . ." Constant " .name cr ; |
-rot type space .name |
| : doval dup cell+ (name>) >body @ . ." Value " .name cr ; |
else |
| : dodef ." Defer " dup >r .name cr |
drop ." noname " type |
| r@ cell+ (name>) >body @ look |
then |
| 0= ABORT" SEE: No valid xt in deferred word" |
space ; |
| dup dosee cr |
|
| ." ' " .name r> ." IS " .name cr ; |
Defer discode ( addr -- ) |
| : dodoe ." Create " dup .name cr |
\ hook for the disassembler: disassemble code at addr (as far as the |
| S" DOES> " Com# .string XPos @ Level ! name> |
\ disassembler thinks is sensible) |
| >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN |
:noname ( addr -- ) |
| ScanMode c-pass ! dup makepass |
drop ." ..." ; |
| DisplayMode c-pass ! makepass ; |
IS discode |
| : doali here @ .name ." Alias " .name cr |
|
| here @ dosee ; |
: seecode ( xt -- ) |
| : docol |
dup s" Code" .defname |
| S" : " Com# .string |
>body discode |
| dup name>string 2 pick wordinfo .string bl cemit bl cemit |
." end-code" cr ; |
| ( XPos @ ) 2 Level ! |
: seevar ( xt -- ) |
| name> >body |
s" Variable" .defname cr ; |
| C-Pass @ DebugMode = |
: seeuser ( xt -- ) |
| IF |
s" User" .defname cr ; |
| ScanMode c-pass ! EXIT |
: 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 -- ) |
| |
dup s" create" .defname cr |
| |
S" DOES> " Com# .string XPos @ Level ! |
| |
>does-code see-threaded ; |
| |
: seecol ( xt -- ) |
| |
dup s" :" .defname nl |
| |
2 Level ! |
| |
>body see-threaded ; |
| |
: seefield ( xt -- ) |
| |
dup >body ." 0 " ? ." 0 0 " |
| |
s" Field" .defname cr ; |
| |
|
| create wordtypes |
: xt-see ( xt -- ) |
| Pri# , ' dopri A, |
|
| Var# , ' dovar A, |
|
| Con# , ' docon A, |
|
| Val# , ' doval A, |
|
| Def# , ' dodef A, |
|
| Doe# , ' dodoe A, |
|
| Ali# , ' doali A, |
|
| Col# , ' docol A, |
|
| Use# , ' douse A, |
|
| 0 , |
|
| |
|
| : (dosee) ( lfa -- ) |
|
| dup dup cell+ c@ >r |
|
| wordinfo |
|
| wordtypes |
|
| BEGIN dup @ dup |
|
| WHILE 2 pick = IF cell+ @ nip EXECUTE |
|
| r> dup 32 and IF ." immediate" THEN |
|
| 64 and IF ." restrict" THEN EXIT THEN |
|
| 2 cells + |
|
| REPEAT |
|
| 2drop rdrop |
|
| .name ." Don't know how to handle" cr ; |
|
| |
|
| ' (dosee) IS dosee |
|
| |
|
| : xtc ( xt -- ) \ do see at xt |
|
| Look 0= ABORT" SEE: No valid XT" |
|
| cr c-init |
cr c-init |
| dosee ; |
dup >does-code |
| |
if |
| |
seedoes EXIT |
| |
then |
| |
dup forthstart u< |
| |
if |
| |
seecode EXIT |
| |
then |
| |
dup >code-address |
| |
CASE |
| |
docon: of seecon endof |
| |
docol: of seecol endof |
| |
dovar: of seevar endof |
| |
douser: of seeuser endof |
| |
dodefer: of seedefer endof |
| |
dofield: of seefield endof |
| |
over >body of seecode endof |
| |
2drop abort" unknown word type" |
| |
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 sfind 0= IF ." Word unknown" cr exit THEN |
: see ( "name" -- ) \ tools |
| xtc ; |
name find-name dup 0= |
| |
IF |
| : lfc cr c-init cell+ dosee ; |
drop -&13 bounce |
| : nfc cr c-init dosee ; |
THEN |
| |
name-see ; |
| |
|
| |
|
