version 1.3, 1994/07/13 19:21:08
|
version 1.75, 2010/09/12 17:10:04
|
Line 1
|
Line 1
|
\ SEE.FS highend SEE for ANSforth 16may93jaw |
\ SEE.FS highend SEE for ANSforth 16may93jaw |
|
|
|
\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
|
|
|
\ This file is part of Gforth. |
|
|
|
\ Gforth is free software; you can redistribute it and/or |
|
\ modify it under the terms of the GNU General Public License |
|
\ as published by the Free Software Foundation, either version 3 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ GNU General Public License for more details. |
|
|
|
\ You should have received a copy of the GNU General Public License |
|
\ along with this program. If not, see http://www.gnu.org/licenses/. |
|
|
|
|
\ May be cross-compiled |
\ May be cross-compiled |
|
|
\ I'm sorry. This is really not "forthy" enough. |
\ I'm sorry. This is really not "forthy" enough. |
|
|
\ Ideas: Level should be a stack |
\ Ideas: Level should be a stack |
|
|
|
require look.fs |
|
require termsize.fs |
|
require wordinfo.fs |
|
|
decimal |
decimal |
|
|
\ Screen format words 16may93jaw |
\ Screen format words 16may93jaw |
Line 29 VARIABLE Level
|
Line 51 VARIABLE Level
|
: 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 |
|
|
: nl nlflag on ; |
: nl nlflag on ; |
: (nl) nlcount |
: (nl) nlcount |
XPos @ Level @ = ?Exit |
XPos @ Level @ = IF EXIT THEN \ ?Exit |
C-Formated @ IF |
C-Formated @ IF |
C-Output @ |
C-Output @ |
IF C-Clearline @ IF 80 XPos @ - spaces |
IF C-Clearline @ IF cols XPos @ - spaces |
ELSE cr THEN |
ELSE cr THEN |
1 YPos +! 0 XPos ! |
1 YPos +! 0 XPos ! |
Level @ spaces |
Level @ spaces |
Line 45 DEFER nlcount ' noop IS nlcount
|
Line 68 DEFER nlcount ' noop IS nlcount
|
|
|
: warp? ( len -- len ) |
: warp? ( len -- len ) |
nlflag @ IF (nl) nlflag off THEN |
nlflag @ IF (nl) nlflag off THEN |
XPos @ over + 79 u> IF (nl) THEN ; |
XPos @ over + cols u>= IF (nl) 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@ toupper 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 |
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 .string |
|
|
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 -- ) |
|
|
[IFDEF] Green |
[IFDEF] Green |
VARIABLE Colors Colors on |
VARIABLE Colors Colors on |
Line 76 VARIABLE Colors Colors on
|
Line 154 VARIABLE Colors Colors on
|
|
|
' (.string) IS .string |
' (.string) IS .string |
|
|
|
: c-\type ( c-addr u -- ) |
|
\ type string in \-escaped form |
|
begin |
|
dup while |
|
2dup newline string-prefix? if |
|
'\ cemit 'n cemit |
|
newline nip /string |
|
else |
|
over c@ |
|
dup '" = over '\ = or if |
|
'\ cemit cemit |
|
else |
|
dup bl 127 within if |
|
cemit |
|
else |
|
base @ >r try |
|
8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 |
|
restore |
|
r@ base ! |
|
endtry |
|
rdrop throw |
|
endif |
|
endif |
|
1 /string |
|
endif |
|
repeat |
|
2drop ; |
|
|
: .struc Str# .string ; |
: .struc |
|
uppercase on Str# .string ; |
|
|
\ CODES 15may93jaw |
\ CODES (Branchtypes) 15may93jaw |
|
|
21 CONSTANT RepeatCode |
21 CONSTANT RepeatCode |
22 CONSTANT AgainCode |
22 CONSTANT AgainCode |
Line 89 VARIABLE Colors Colors on
|
Line 195 VARIABLE Colors Colors on
|
11 CONSTANT AheadCode |
11 CONSTANT AheadCode |
13 CONSTANT WhileCode2 |
13 CONSTANT WhileCode2 |
14 CONSTANT Disable |
14 CONSTANT Disable |
|
15 CONSTANT LeaveCode |
|
|
|
|
\ FORMAT WORDS 13jun93jaw |
\ FORMAT WORDS 13jun93jaw |
|
|
VARIABLE C-Stop |
VARIABLE C-Stop |
VARIABLE Branches |
VARIABLE Branches |
|
|
VARIABLE BranchPointer |
VARIABLE BranchPointer \ point to the end of branch table |
VARIABLE SearchPointer |
VARIABLE SearchPointer |
CREATE BranchTable 500 allot |
|
|
\ The branchtable consists of three entrys: |
|
\ address of branch , branch destination , branch type |
|
|
|
CREATE BranchTable 128 cells allot |
here 3 cells - |
here 3 cells - |
ACONSTANT MaxTable |
ACONSTANT MaxTable |
|
|
: FirstBranch BranchTable cell+ SearchPointer ! ; |
: FirstBranch BranchTable cell+ SearchPointer ! ; |
|
|
: (BranchAddr?) ( a-addr -- a-addr true | false ) |
: (BranchAddr?) ( a-addr1 -- a-addr2 true | false ) |
|
\ searches a branch with destination a-addr1 |
|
\ a-addr1: branch destination |
|
\ a-addr2: pointer in branch table |
SearchPointer @ |
SearchPointer @ |
BEGIN dup BranchPointer @ u< |
BEGIN dup BranchPointer @ u< |
WHILE |
WHILE |
Line 132 ACONSTANT MaxTable
|
Line 247 ACONSTANT MaxTable
|
2drop true |
2drop true |
THEN ; |
THEN ; |
|
|
|
: MyBranch ( a-addr -- a-addr a-addr2 ) |
|
\ finds branch table entry for branch at a-addr |
|
dup @ |
|
BranchAddr? |
|
BEGIN |
|
WHILE 1 cells - @ |
|
over <> |
|
WHILE dup @ |
|
MoreBranchAddr? |
|
REPEAT |
|
SearchPointer @ 3 cells - |
|
ELSE true ABORT" SEE: Table failure" |
|
THEN ; |
|
|
\ |
\ |
\ addrw addrt |
\ addrw addrt |
\ BEGIN ... WHILE ... AGAIN ... THEN |
\ BEGIN ... WHILE ... AGAIN ... THEN |
Line 163 ACONSTANT MaxTable
|
Line 292 ACONSTANT MaxTable
|
BranchPointer @ 1 cells - ! ; |
BranchPointer @ 1 cells - ! ; |
|
|
: Branch! ( a-addr rel -- a-addr ) |
: Branch! ( a-addr rel -- a-addr ) |
over + over ,Branch ,Branch 0 ,Branch ; |
over ,Branch ,Branch 0 ,Branch ; |
|
\ over + over ,Branch ,Branch 0 ,Branch ; |
|
|
\ DEFER CheckUntil |
\ DEFER CheckUntil |
VARIABLE NoOutput |
VARIABLE NoOutput |
Line 176 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? ( n -- flag ) 0< ; |
: back? ( addr target -- addr flag ) |
: ahead? ( n -- flag ) 0> ; |
over u< ; |
|
|
: c-(compile) |
|
Display? IF s" POSTPONE " Com# .string |
|
dup @ look 0= ABORT" SEE: No valid XT" |
|
cell+ count $1F and 0 .string bl cemit |
|
THEN |
|
cell+ ; |
|
|
|
: c-lit |
|
Display? IF dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit THEN |
|
cell+ ; |
|
|
|
: c-s" |
: .word ( addr x -- addr ) |
count 2dup + aligned -rot |
\ print x as a word if possible |
Display? |
dup look 0= IF |
IF [char] S cemit [char] " cemit bl cemit 0 .string |
drop dup threaded>name dup 0= if |
[char] " cemit bl cemit |
drop over 1 cells - @ dup body> look |
ELSE 2drop |
IF |
THEN ; |
nip nip dup ." <" name>string rot wordinfo .string ." > " |
|
ELSE |
|
2drop ." <" 0 .r ." > " |
|
THEN |
|
EXIT |
|
then |
|
THEN |
|
nip dup cell+ @ immediate-mask and |
|
IF |
|
bl cemit ." POSTPONE " |
|
THEN |
|
dup name>string rot wordinfo .string |
|
; |
|
|
|
: c-call ( addr1 -- addr2 ) |
|
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 |
|
|
|
[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-." |
: c-lit ( addr1 -- addr2 ) |
count 2dup + aligned -rot |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
Display? |
( addr1 addr1@ ) |
IF [char] . cemit |
dup body> @ dovar: = if |
[char] " cemit bl cemit 0 .string |
drop c-call EXIT |
[char] " cemit bl cemit |
endif |
ELSE 2drop |
endif |
THEN ; |
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 "['] ..." |
|
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
|
else drop then |
|
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 ) |
|
\ !! the stack effect cannot be correct |
|
\ prints a name without a() e.g. a(+LOOP) or (s") |
|
dup 1 cells - @ threaded>name dup IF |
|
name>string over c@ 'a = IF |
|
1 /string |
|
THEN |
|
over c@ '( = IF |
|
1 /string |
|
THEN |
|
2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop |
|
THEN ; |
|
|
|
[ifdef] (s") |
: c-c" |
: c-c" |
|
Display? IF nl .name-without THEN |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Display? |
Display? |
IF [char] C cemit [char] " cemit bl cemit 0 .string |
IF bl cemit 0 .string |
[char] " cemit bl cemit |
[char] " cemit bl cemit |
ELSE 2drop |
ELSE 2drop |
THEN ; |
THEN ; |
|
[endif] |
|
|
|
: c-string? ( addr1 -- addr2 f ) |
|
\ f is true if a string was found and decompiled. |
|
\ if f is false, addr2=addr1 |
|
\ recognizes the following patterns: |
|
\ c": ahead X: len string then lit X |
|
\ flit: ahead X: float then lit X f@ |
|
\ s\": ahead X: string then lit X lit len |
|
\ .\": ahead X: string then lit X lit len type |
|
\ !! not recognized anywhere: |
|
\ abort": if ahead X: len string then lit X c(abort") then |
|
dup @ back? if false exit endif |
|
dup @ >r |
|
r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif |
|
r@ cell+ @ over cell+ <> if rdrop false exit endif |
|
\ we have at least C" |
|
r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if |
|
drop r@ 3 cells + @ over cell+ + aligned r@ = if |
|
\ we have at least s" |
|
r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded = |
|
r@ 5 cells + @ ['] type >body = and if |
|
6 s\" .\\\" " |
|
else |
|
4 s\" s\\\" " |
|
endif |
|
\ !! make newline if string too long? |
|
display? if |
|
0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit |
|
else |
|
2drop |
|
endif |
|
nip cells r> + true exit |
|
endif |
|
endif |
|
['] f@ xt>threaded = if |
|
display? if |
|
r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit |
|
endif |
|
drop r> 3 cells + true exit |
|
endif |
|
\ !! check if count matches space? |
|
display? if |
|
s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit |
|
endif |
|
drop r> 2 cells + true ; |
|
|
|
: Forward? ( a-addr true | false -- a-addr true | false ) |
|
\ a-addr is pointer into branch table |
|
\ returns true when jump is a forward jump |
|
IF |
|
dup dup @ swap 1 cells - @ u> IF |
|
true |
|
ELSE |
|
drop false |
|
THEN |
|
\ only if forward jump |
|
ELSE |
|
false |
|
THEN ; |
|
|
: Forward? ( a-addr true | false -- ) |
: RepeatCheck ( a-addr1 a-addr2 true | false -- false ) |
IF dup dup @ swap 1 cells - @ - |
|
Ahead? IF true ELSE drop false THEN |
|
\ only if forward jump |
|
ELSE false THEN ; |
|
|
|
: RepeatCheck |
|
IF BEGIN 2dup |
IF BEGIN 2dup |
1 cells - @ swap dup @ + |
1 cells - @ swap @ |
u<= |
u<= |
WHILE drop dup cell+ |
WHILE drop dup cell+ |
MoreBranchAddr? 0= |
MoreBranchAddr? 0= |
Line 235 VARIABLE C-Pass
|
Line 485 VARIABLE C-Pass
|
ELSE false |
ELSE false |
THEN ; |
THEN ; |
|
|
: c-branch |
: c-branch ( addr1 -- addr2 ) |
|
c-string? ?exit |
Scan? |
Scan? |
IF dup @ Branch! |
IF dup @ Branch! |
dup @ back? |
dup @ back? |
Line 262 VARIABLE C-Pass
|
Line 513 VARIABLE C-Pass
|
IF drop S" REPEAT " .struc nl |
IF drop S" REPEAT " .struc nl |
ELSE S" AGAIN " .struc nl |
ELSE S" AGAIN " .struc nl |
THEN |
THEN |
ELSE dup cell+ BranchAddr? Forward? |
ELSE MyBranch cell+ @ LeaveCode = |
IF dup cell+ @ WhileCode2 = |
IF S" LEAVE " .struc |
IF nl S" ELSE" .struc level+ |
ELSE |
ELSE level- nl S" ELSE" .struc level+ THEN |
dup cell+ BranchAddr? Forward? |
cell+ Disable swap ! |
IF dup cell+ @ WhileCode2 = |
ELSE S" AHEAD" .struc level+ |
IF nl S" ELSE " .struc level+ |
THEN |
ELSE level- nl S" ELSE" .struc level+ THEN |
|
cell+ Disable swap ! |
|
ELSE S" AHEAD " .struc level+ |
|
THEN |
|
THEN |
THEN |
THEN |
THEN |
THEN |
Debug? |
Debug? |
IF dup @ + |
IF @ \ !!! cross-interacts with debugger !!! |
ELSE cell+ |
ELSE cell+ |
THEN ; |
THEN ; |
|
|
: MyBranch ( a-addr -- a-addr a-addr2 ) |
|
dup @ over + |
|
BranchAddr? |
|
BEGIN |
|
WHILE 1 cells - @ |
|
over <> |
|
WHILE dup @ over + |
|
MoreBranchAddr? |
|
REPEAT |
|
SearchPointer @ 3 cells - |
|
ELSE true ABORT" SEE: Table failure" |
|
THEN ; |
|
|
|
: DebugBranch |
: DebugBranch |
Debug? |
Debug? |
IF dup @ over + swap THEN ; \ return 2 different addresses |
IF dup @ swap THEN ; \ return 2 different addresses |
|
|
: c-?branch |
: c-?branch |
Scan? |
Scan? |
Line 309 VARIABLE C-Pass
|
Line 551 VARIABLE C-Pass
|
IF WhileCode2 swap ! |
IF WhileCode2 swap ! |
ELSE drop THEN |
ELSE drop THEN |
level- nl |
level- nl |
S" WHILE" .struc |
S" WHILE " .struc |
level+ |
level+ |
ELSE nl S" IF" .struc level+ |
ELSE MyBranch cell+ @ LeaveCode = |
|
IF s" 0= ?LEAVE " .struc |
|
ELSE nl S" IF " .struc level+ |
|
THEN |
THEN |
THEN |
THEN |
THEN |
THEN |
THEN |
DebugBranch |
DebugBranch |
cell+ ; |
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 |
|
Display? IF level- nl S" NEXT " .struc nl THEN |
|
DebugBranch cell+ cell+ ; |
|
|
|
: c-loop |
: c-loop |
Display? IF level- nl S" LOOP " .struc nl THEN |
Display? IF level- nl .name-without nl bl cemit THEN |
DebugBranch cell+ cell+ ; |
DebugBranch cell+ |
|
Scan? |
|
IF dup BranchAddr? |
|
BEGIN WHILE cell+ LeaveCode swap ! |
|
dup MoreBranchAddr? |
|
REPEAT |
|
THEN |
|
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-leave |
|
Display? IF S" LEAVE " .struc THEN |
|
Debug? IF dup @ + THEN cell+ ; |
|
|
|
: c-?leave |
|
Display? IF S" ?LEAVE " .struc THEN |
|
cell+ DebugBranch swap cell+ swap cell+ ; |
|
|
|
: c-exit dup 1 cells - |
|
CheckEnd |
|
IF Display? IF nlflag off S" ;" Com# .string THEN |
|
C-Stop on |
|
ELSE Display? IF S" EXIT " .struc THEN |
|
THEN |
|
Debug? IF drop THEN ; |
|
|
|
: c-;code \ end of create part |
: c-?do ( addr1 -- addr2 ) |
Display? IF S" DOES> " Com# .string THEN |
Display? IF |
Cell+ cell+ ; |
nl .name-without level+ |
|
THEN |
|
DebugBranch cell+ ; |
|
|
|
: c-exit ( addr1 -- addr2 ) |
|
dup 1 cells - |
|
CheckEnd |
|
IF |
|
Display? IF nlflag off S" ;" Com# .string THEN |
|
C-Stop on |
|
ELSE |
|
Display? IF S" EXIT " .struc THEN |
|
THEN |
|
Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!! |
|
|
: c-abort" |
: c-abort" |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Line 370 VARIABLE C-Pass
|
Line 606 VARIABLE C-Pass
|
ELSE 2drop |
ELSE 2drop |
THEN ; |
THEN ; |
|
|
|
[IFDEF] (compile) |
|
: c-(compile) |
|
Display? |
|
IF |
|
s" POSTPONE " Com# .string |
|
dup @ look 0= ABORT" SEE: No valid XT" |
|
name>string 0 .string bl cemit |
|
THEN |
|
cell+ ; |
|
[THEN] |
|
|
CREATE C-Table |
CREATE C-Table |
' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
' (s") A, ' c-s" A, |
' does-exec A, ' c-callxt A, |
' (.") A, ' c-." A, |
' lit@ A, ' c-call A, |
' "lit A, ' c-c" A, |
[IFDEF] call ' call A, ' c-call A, [THEN] |
' ?branch A, ' c-?branch A, |
\ ' useraddr A, .... |
' branch A, ' c-branch A, |
' lit-perform A, ' c-call A, |
' leave A, ' c-leave A, |
' lit+ A, ' c-lit+ A, |
' ?leave A, ' c-?leave A, |
[IFDEF] (s") ' (s") A, ' c-c" A, [THEN] |
' (do) A, ' c-do A, |
[IFDEF] (.") ' (.") A, ' c-c" A, [THEN] |
' (?do) A, ' c-?do A, |
[IFDEF] "lit ' "lit A, ' c-c" A, [THEN] |
' (for) A, ' c-for A, |
[IFDEF] (c") ' (c") A, ' c-c" A, [THEN] |
' (loop) A, ' c-loop A, |
' (do) A, ' c-do A, |
' (+loop) A, ' c-+loop A, |
[IFDEF] (+do) ' (+do) A, ' c-?do A, [THEN] |
' (next) A, ' c-next A, |
[IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN] |
' ;s A, ' c-exit A, |
[IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN] |
' (;code) A, ' c-;code A, |
[IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN] |
' (abort") A, ' c-abort" A, |
' (?do) A, ' c-?do A, |
' (compile) A, ' c-(compile) A, |
' (for) A, ' c-for A, |
0 , |
' ?branch A, ' c-?branch A, |
|
' branch A, ' c-branch A, |
|
' (loop) A, ' c-loop A, |
|
' (+loop) A, ' c-loop A, |
|
[IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN] |
|
[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN] |
|
' (next) A, ' c-loop A, |
|
' ;s A, ' c-exit A, |
|
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
|
\ only defined if compiler is loaded |
|
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
|
0 , here 0 , |
|
|
|
avariable c-extender |
|
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 |
dup @ dup 0= IF |
WHILE 2 pick <> |
drop cell+ @ dup IF ( next table!) |
WHILE 2 cells + |
dup @ |
REPEAT |
ELSE ( end!) |
nip cell+ @ EXECUTE |
2drop false EXIT |
true |
THEN |
ELSE |
THEN |
2drop drop false |
\ jump over to extender, if any 26jan97jaw |
THEN ; |
xt>threaded 2 pick <> |
|
WHILE |
|
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? |
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 <> over LeaveCode <> and |
IF WhileCode2 = |
IF WhileCode2 = |
IF nl S" THEN " .struc nl ELSE |
IF nl S" THEN " .struc nl ELSE |
level- nl S" THEN " .struc nl THEN |
level- nl S" THEN " .struc nl THEN |
Line 423 CREATE C-Table
|
Line 690 CREATE C-Table
|
THEN ; |
THEN ; |
|
|
: analyse ( a-addr1 -- a-addr2 ) |
: analyse ( a-addr1 -- a-addr2 ) |
Branches @ IF BranchTo? THEN |
Branches @ IF BranchTo? THEN |
dup cell+ swap @ |
dup cell+ swap @ |
dup >r DoTable r> swap IF drop EXIT THEN |
dup >r DoTable r> swap IF drop EXIT THEN |
Display? |
Display? |
IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!" |
IF |
ELSE dup cell+ count 31 and rot wordinfo .string THEN bl cemit |
.word bl cemit |
ELSE drop |
ELSE |
THEN ; |
drop |
|
THEN ; |
|
|
: c-init |
: c-init |
0 YPos ! 0 XPos ! |
0 YPos ! 0 XPos ! |
Line 440 CREATE C-Table
|
Line 708 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 |
: seecode ( xt -- ) |
|
dup s" Code" .defname |
: dopri .name ." is primitive" cr ; |
>code-address |
: dovar .name ." is variable" cr ; |
dup in-dictionary? \ user-defined code word? |
: docon dup .name ." is constant, value: " |
if |
cell+ (name>) >body @ . cr ; |
dup next-head |
: doval .name ." is value" cr ; |
else |
: dodef .name ." is defered word, is: " |
dup next-prim |
here @ look 0= ABORT" SEE: No valid xt in defered word" |
then |
.name cr here @ look drop dosee ; |
over - discode |
: dodoe .name ." is created word" cr |
." end-code" cr ; |
S" DOES> " Com# .string XPos @ Level ! |
: seeabicode ( xt -- ) |
here @ dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN |
dup s" ABI-Code" .defname |
ScanMode c-pass ! dup makepass |
>body dup dup next-head |
DisplayMode c-pass ! makepass ; |
swap - discode |
: doali .name ." is alias of " |
." end-code" cr ; |
here @ .name cr |
: seevar ( xt -- ) |
here @ dosee ; |
s" Variable" .defname cr ; |
: docol S" : " Com# .string |
: seeuser ( xt -- ) |
dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit |
s" User" .defname cr ; |
( XPos @ ) 2 Level ! |
: seecon ( xt -- ) |
name> >body |
dup >body ? |
C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN |
s" Constant" .defname cr ; |
ScanMode c-pass ! dup makepass |
: seevalue ( xt -- ) |
DisplayMode c-pass ! makepass ; |
dup >body ? |
|
s" Value" .defname cr ; |
create wordtypes |
: seedefer ( xt -- ) |
Pri# , ' dopri A, |
dup >body @ xt-see-xt cr |
Var# , ' dovar A, |
dup s" Defer" .defname cr |
Con# , ' docon A, |
>name ?dup-if |
Val# , ' doval A, |
." IS " .name cr |
Def# , ' dodef A, |
else |
Doe# , ' dodoe A, |
." latestxt >body !" |
Ali# , ' doali A, |
then ; |
Col# , ' docol A, |
: see-threaded ( addr -- ) |
0 , |
C-Pass @ DebugMode = IF |
|
ScanMode c-pass ! |
: (dosee) ( lfa -- ) |
EXIT |
dup dup cell+ c@ 32 and IF over .name ." is an immediate word" cr THEN |
THEN |
wordinfo |
ScanMode c-pass ! dup makepass |
wordtypes |
DisplayMode c-pass ! makepass ; |
BEGIN dup @ dup |
: seedoes ( xt -- ) |
WHILE 2 pick = IF cell+ @ nip EXECUTE EXIT THEN |
dup s" create" .defname cr |
2 cells + |
S" DOES> " Com# .string XPos @ Level ! |
REPEAT |
>does-code see-threaded ; |
2drop |
: seecol ( xt -- ) |
.name ." Don't know how to handle" cr ; |
dup s" :" .defname nl |
|
2 Level ! |
' (dosee) IS dosee |
>body see-threaded ; |
|
: seefield ( xt -- ) |
: xtc ( xt -- ) \ do see at xt |
dup >body ." 0 " ? ." 0 0 " |
Look 0= ABORT" SEE: No valid XT" |
s" Field" .defname cr ; |
cr c-init |
|
dosee ; |
: xt-see ( xt -- ) \ gforth |
|
\G Decompile the definition represented by @i{xt}. |
: see name find 0= IF ." Word unknown" cr drop exit THEN |
cr c-init |
xtc ; |
dup >does-code |
|
if |
: lfc cr c-init cell+ dosee ; |
seedoes EXIT |
: nfc cr c-init dosee ; |
then |
|
dup xtprim? |
|
if |
|
seecode EXIT |
|
then |
|
dup >code-address |
|
CASE |
|
docon: of seecon endof |
|
[IFDEF] dovalue: |
|
dovalue: of seevalue endof |
|
[THEN] |
|
docol: of seecol endof |
|
dovar: of seevar endof |
|
[IFDEF] douser: |
|
douser: of seeuser endof |
|
[THEN] |
|
[IFDEF] dodefer: |
|
dodefer: of seedefer endof |
|
[THEN] |
|
[IFDEF] dofield: |
|
dofield: of seefield endof |
|
[THEN] |
|
[IFDEF] doabicode: |
|
doabicode: of seeabicode endof |
|
[THEN] |
|
over of seecode endof \ direct threaded code words |
|
over >body of seecode endof \ indirect threaded code words |
|
2drop abort" unknown word type" |
|
ENDCASE ; |
|
|
|
: (xt-see-xt) ( xt -- ) |
|
xt-see cr ." latestxt" ; |
|
' (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@ ['] ticking-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 drop |
|
then |
|
then |
|
rdrop drop ; |
|
|
|
: see ( "<spaces>name" -- ) \ tools |
|
\G Locate @var{name} using the current search order. Display the |
|
\G definition of @var{name}. Since this is achieved by decompiling |
|
\G the definition, the formatting is mechanised and some source |
|
\G information (comments, interpreted sequences within definitions |
|
\G etc.) is lost. |
|
name find-name dup 0= |
|
IF |
|
drop -&13 throw |
|
THEN |
|
name-see ; |
|
|
|
|