| \ SEE.FS highend SEE for ANSforth 16may93jaw |
\ SEE.FS highend SEE for ANSforth 16may93jaw |
| |
|
| \ Copyright (C) 1995 Free Software Foundation, Inc. |
\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| \ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
| \ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
| \ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
| \ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
| |
|
| \ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
| \ GNU General Public License for more details. |
\ GNU General Public License for more details. |
| |
|
| \ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
| \ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
| \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
| |
|
| |
|
| \ May be cross-compiled |
\ May be cross-compiled |
| require look.fs |
require look.fs |
| require termsize.fs |
require termsize.fs |
| require wordinfo.fs |
require wordinfo.fs |
| [IFUNDEF] .name : .name name>string type space ; [THEN] |
|
| |
|
| decimal |
decimal |
| |
|
| 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 @ |
warp? dup XPos +! C-Output @ |
| IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP |
IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP |
| uppercase off ELSE type THEN |
uppercase off ELSE type THEN |
| ELSE 2drop THEN ; |
ELSE 2drop THEN ; |
| |
|
| 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 .string ( c-addr u n -- ) |
| |
|
| [IFDEF] Green |
[IFDEF] Green |
| VARIABLE Colors Colors on |
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 |
: .struc |
| uppercase on Str# .string ; |
uppercase on Str# .string ; |
| \ The branchtable consists of three entrys: |
\ The branchtable consists of three entrys: |
| \ address of branch , branch destination , branch type |
\ address of branch , branch destination , branch type |
| |
|
| CREATE BranchTable 500 allot |
CREATE BranchTable 128 cells allot |
| here 3 cells - |
here 3 cells - |
| ACONSTANT MaxTable |
ACONSTANT MaxTable |
| |
|
| |
|
| : MyBranch ( a-addr -- a-addr a-addr2 ) |
: MyBranch ( a-addr -- a-addr a-addr2 ) |
| \ finds branch table entry for branch at a-addr |
\ finds branch table entry for branch at a-addr |
| dup @ over + |
dup @ |
| BranchAddr? |
BranchAddr? |
| BEGIN |
BEGIN |
| WHILE 1 cells - @ |
WHILE 1 cells - @ |
| over <> |
over <> |
| WHILE dup @ over + |
WHILE dup @ |
| MoreBranchAddr? |
MoreBranchAddr? |
| REPEAT |
REPEAT |
| SearchPointer @ 3 cells - |
SearchPointer @ 3 cells - |
| 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 |
| : Display? ( -- flag ) C-Pass @ 1 = ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
| : Debug? ( -- flag ) C-Pass @ 2 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
| |
|
| : back? ( n -- flag ) 0< ; |
: back? ( addr target -- addr flag ) |
| : ahead? ( n -- flag ) 0> ; |
over u< ; |
| |
|
| : c-(compile) |
: .word ( addr x -- addr ) |
| Display? |
\ print x as a word if possible |
| |
dup look 0= IF |
| |
drop dup threaded>name dup 0= if |
| |
drop over 1 cells - @ dup body> look |
| IF |
IF |
| s" POSTPONE " Com# .string |
nip nip dup ." <" name>string rot wordinfo .string ." > " |
| dup @ look 0= ABORT" SEE: No valid XT" |
ELSE |
| name>string 0 .string bl cemit |
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 |
THEN |
| cell+ ; |
cell+ ; |
| |
|
| : c-lit |
: c-callxt ( addr1 -- addr2 ) |
| Display? IF |
Display? IF |
| dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit |
dup @ .word bl cemit |
| THEN |
THEN |
| cell+ ; |
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") |
\ !! the stack effect cannot be correct |
| dup 1 cells - @ look |
\ prints a name without a() e.g. a(+LOOP) or (s") |
| IF name>string over c@ '( = IF 1 /string THEN |
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 |
2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop |
| THEN ; |
THEN ; |
| |
|
| |
[ifdef] (s") |
| : c-c" |
: c-c" |
| Display? IF nl .name-without THEN |
Display? IF nl .name-without THEN |
| count 2dup + aligned -rot |
count 2dup + aligned -rot |
| [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 ) |
: Forward? ( a-addr true | false -- a-addr true | false ) |
| \ a-addr1 is pointer into branch table |
\ a-addr is pointer into branch table |
| \ returns true when jump is a forward jump |
\ returns true when jump is a forward jump |
| IF dup dup @ swap 1 cells - @ - |
IF |
| Ahead? IF true ELSE drop false THEN |
dup dup @ swap 1 cells - @ u> IF |
| |
true |
| |
ELSE |
| |
drop false |
| |
THEN |
| \ only if forward jump |
\ only if forward jump |
| ELSE false THEN ; |
ELSE |
| |
false |
| |
THEN ; |
| |
|
| : RepeatCheck ( a-addr1 a-addr2 true | false -- false ) |
: RepeatCheck ( a-addr1 a-addr2 true | false -- false ) |
| 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= |
| 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? |
| THEN |
THEN |
| THEN |
THEN |
| Debug? |
Debug? |
| IF dup @ + |
IF @ \ !!! cross-interacts with debugger !!! |
| ELSE cell+ |
ELSE cell+ |
| THEN ; |
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? |
| Display? IF nl S" FOR" .struc level+ THEN ; |
Display? IF nl S" FOR" .struc level+ THEN ; |
| |
|
| : c-loop |
: c-loop |
| Display? IF level- nl .name-without bl cemit nl THEN |
Display? IF level- nl .name-without nl bl cemit THEN |
| DebugBranch cell+ |
DebugBranch cell+ |
| Scan? |
Scan? |
| IF dup BranchAddr? |
IF dup BranchAddr? |
| : c-do |
: c-do |
| Display? IF nl .name-without level+ THEN ; |
Display? IF nl .name-without level+ THEN ; |
| |
|
| : c-?do |
: c-?do ( addr1 -- addr2 ) |
| Display? IF nl S" ?DO" .struc level+ THEN |
Display? IF |
| |
nl .name-without level+ |
| |
THEN |
| DebugBranch cell+ ; |
DebugBranch cell+ ; |
| |
|
| : c-exit dup 1 cells - |
: c-exit ( addr1 -- addr2 ) |
| |
dup 1 cells - |
| CheckEnd |
CheckEnd |
| IF Display? IF nlflag off S" ;" Com# .string THEN |
IF |
| |
Display? IF nlflag off S" ;" Com# .string THEN |
| C-Stop on |
C-Stop on |
| ELSE Display? IF S" EXIT " .struc THEN |
ELSE |
| |
Display? IF S" EXIT " .struc THEN |
| THEN |
THEN |
| Debug? IF drop THEN ; |
Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!! |
| |
|
| : c-does> \ end of create part |
|
| Display? IF S" DOES> " Com# .string THEN |
|
| maxaligned /does-handler + ; |
|
| |
|
| : c-abort" |
: c-abort" |
| count 2dup + aligned -rot |
count 2dup + aligned -rot |
| 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) |
| |
: 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-c" A, |
' does-exec A, ' c-callxt A, |
| ' (.") A, ' c-c" A, |
' lit@ A, ' c-call A, |
| ' "lit A, ' c-c" A, |
[IFDEF] call ' call A, ' c-call A, [THEN] |
| |
\ ' useraddr A, .... |
| |
' lit-perform A, ' c-call 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] |
| [IFDEF] (u+do) ' (u+do) A, ' c-do A, [THEN] |
[IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN] |
| [IFDEF] (-do) ' (-do) A, ' c-do A, [THEN] |
[IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN] |
| [IFDEF] (u-do) ' (u-do) A, ' c-do A, [THEN] |
[IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN] |
| ' (?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, |
| [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, |
| ' (does>) A, ' c-does> A, |
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
| ' (abort") A, ' c-abort" A, |
\ only defined if compiler is loaded |
| ' (compile) A, ' c-(compile) A, |
[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 |
| |
|
| \ 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!) |
| |
2drop false EXIT |
| |
THEN |
| THEN |
THEN |
| \ jump over to extender, if any 26jan97jaw |
\ jump over to extender, if any 26jan97jaw |
| 2 pick <> |
xt>threaded 2 pick <> |
| WHILE 2 cells + |
WHILE |
| |
2 cells + |
| REPEAT |
REPEAT |
| nip cell+ perform |
nip cell+ perform |
| true |
true |
| 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 |
| |
.word bl cemit |
| ELSE |
ELSE |
| dup cell+ count dup immediate-mask and |
drop |
| IF bl cemit ." POSTPONE " THEN |
|
| 31 and rot wordinfo .string THEN bl cemit |
|
| ELSE drop |
|
| THEN ; |
THEN ; |
| |
|
| : c-init |
: c-init |
| then |
then |
| space ; |
space ; |
| |
|
| Defer discode ( addr -- ) |
Defer discode ( addr u -- ) \ gforth |
| \ hook for the disassembler: disassemble code at addr (as far as the |
\G hook for the disassembler: disassemble code at addr of length u |
| \ disassembler thinks is sensible) |
' dump IS discode |
| :noname ( addr -- ) |
|
| drop ." ..." ; |
: next-head ( addr1 -- addr2 ) \ gforth |
| IS discode |
\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 |
| threading-method |
|
| if |
|
| >code-address |
>code-address |
| |
dup in-dictionary? \ user-defined code word? |
| |
if |
| |
dup next-head |
| |
else |
| |
dup next-prim |
| then |
then |
| discode |
over - discode |
| ." end-code" cr ; |
." end-code" cr ; |
| : seevar ( xt -- ) |
: seevar ( xt -- ) |
| s" Variable" .defname cr ; |
s" Variable" .defname cr ; |
| : seedefer ( xt -- ) |
: seedefer ( xt -- ) |
| dup >body @ xt-see-xt cr |
dup >body @ xt-see-xt cr |
| dup s" Defer" .defname cr |
dup s" Defer" .defname cr |
| >name dup ??? = if |
>name ?dup-if |
| drop ." lastxt >body !" |
|
| else |
|
| ." IS " .name cr |
." IS " .name cr |
| |
else |
| |
." latestxt >body !" |
| then ; |
then ; |
| : see-threaded ( addr -- ) |
: see-threaded ( addr -- ) |
| C-Pass @ DebugMode = IF |
C-Pass @ DebugMode = IF |
| dup >body ." 0 " ? ." 0 0 " |
dup >body ." 0 " ? ." 0 0 " |
| s" Field" .defname cr ; |
s" Field" .defname cr ; |
| |
|
| : xt-see ( xt -- ) |
: xt-see ( xt -- ) \ gforth |
| |
\G Decompile the definition represented by @i{xt}. |
| cr c-init |
cr c-init |
| dup >does-code |
dup >does-code |
| if |
if |
| dup >code-address |
dup >code-address |
| CASE |
CASE |
| docon: of seecon endof |
docon: of seecon endof |
| |
[IFDEF] dovalue: |
| |
dovalue: of seevalue endof |
| |
[THEN] |
| docol: of seecol endof |
docol: of seecol endof |
| dovar: of seevar endof |
dovar: of seevar endof |
| [ [IFDEF] douser: ] |
[IFDEF] douser: |
| douser: of seeuser endof |
douser: of seeuser endof |
| [ [THEN] ] |
[THEN] |
| [ [IFDEF] dodefer: ] |
[IFDEF] dodefer: |
| dodefer: of seedefer endof |
dodefer: of seedefer endof |
| [ [THEN] ] |
[THEN] |
| [ [IFDEF] dofield: ] |
[IFDEF] dofield: |
| dofield: of seefield endof |
dofield: of seefield endof |
| [ [THEN] ] |
[THEN] |
| over >body of seecode endof |
over of seecode endof \ direct threaded code words |
| |
over >body of seecode endof \ indirect threaded code words |
| 2drop abort" unknown word type" |
2drop abort" unknown word type" |
| ENDCASE ; |
ENDCASE ; |
| |
|
| : (xt-see-xt) ( xt -- ) |
: (xt-see-xt) ( xt -- ) |
| xt-see cr ." lastxt" ; |
xt-see cr ." latestxt" ; |
| ' (xt-see-xt) is xt-see-xt |
' (xt-see-xt) is xt-see-xt |
| |
|
| : (.immediate) ( xt -- ) |
: (.immediate) ( xt -- ) |
| if \ normal or immediate word |
if \ normal or immediate word |
| swap xt-see (.immediate) |
swap xt-see (.immediate) |
| else |
else |
| r@ ['] compile-only-error = |
r@ ['] ticking-compile-only-error = |
| if \ compile-only word |
if \ compile-only word |
| swap xt-see (.immediate) ." compile-only" |
swap xt-see (.immediate) ." compile-only" |
| else \ interpret/compile word |
else \ interpret/compile word |
| r@ xt-see-xt cr |
r@ xt-see-xt cr |
| swap xt-see-xt cr |
swap xt-see-xt cr |
| ." interpret/compile " over .name (.immediate) |
." interpret/compile: " over .name drop |
| then |
then |
| then |
then |
| rdrop drop ; |
rdrop drop ; |
| |
|
| : see ( "name" -- ) \ tools |
: 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= |
name find-name dup 0= |
| IF |
IF |
| drop -&13 bounce |
drop -&13 throw |
| THEN |
THEN |
| name-see ; |
name-see ; |
| |
|