version 1.35, 2001/03/17 21:36:41
|
version 1.61, 2007/09/29 22:20:02
|
Line 1
|
Line 1
|
\ SEE.FS highend SEE for ANSforth 16may93jaw |
\ SEE.FS highend SEE for ANSforth 16may93jaw |
|
|
\ Copyright (C) 1995,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1995,2000,2003,2004,2006 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 28
|
Line 28
|
require look.fs |
require look.fs |
require termsize.fs |
require termsize.fs |
require wordinfo.fs |
require wordinfo.fs |
[IFUNDEF] .name |
|
: id. ( nt -- ) \ gforth |
|
\G Print the name of the word represented by @var{nt}. |
|
\ this name comes from fig-Forth |
|
name>string type space ; |
|
|
|
' id. alias .id ( nt -- ) |
|
\G F83 name for @code{id.}. |
|
|
|
' id. alias .name ( nt -- ) |
|
\G Gforth <=0.5.0 name for @code{id.}. |
|
|
|
[THEN] |
|
|
|
decimal |
decimal |
|
|
Line 84 DEFER nlcount ' noop IS nlcount
|
Line 71 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 ( c1 -- c2 ) \ gforth |
|
\ nac05feb1999 there is a primitive, toupper, with this function |
|
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 ; |
|
|
Line 120 VARIABLE Colors Colors on
|
Line 103 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 ; |
Line 188 ACONSTANT MaxTable
|
Line 198 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 - |
Line 231 ACONSTANT MaxTable
|
Line 241 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 245 VARIABLE C-Pass
|
Line 256 VARIABLE C-Pass
|
: 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< ; |
|
|
|
: .word ( addr x -- addr ) |
|
\ 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 |
|
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-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+ ; |
|
|
: .word |
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
look 0= IF |
\ here over - 2constant doers |
drop dup 1 cells - @ ." <" 0 .r ." >" |
|
ELSE |
|
dup cell+ @ immediate-mask and |
|
IF |
|
bl cemit ." POSTPONE " |
|
THEN |
|
dup name>string rot wordinfo .string |
|
THEN ; |
|
|
|
: c-call |
: c-lit ( addr1 -- addr2 ) |
Display? IF dup @ body> .word bl cemit THEN cell+ ; |
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 |
2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop |
name>string over c@ 'a = IF |
THEN ; |
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 |
Display? IF nl .name-without THEN |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Line 283 VARIABLE C-Pass
|
Line 336 VARIABLE C-Pass
|
[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 |
\ only if forward jump |
true |
ELSE false THEN ; |
ELSE |
|
drop false |
|
THEN |
|
\ only if forward jump |
|
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= |
Line 305 VARIABLE C-Pass
|
Line 409 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 346 VARIABLE C-Pass
|
Line 451 VARIABLE C-Pass
|
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? |
Line 386 VARIABLE C-Pass
|
Line 491 VARIABLE C-Pass
|
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? |
Line 399 VARIABLE C-Pass
|
Line 504 VARIABLE C-Pass
|
: 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 |
DebugBranch cell+ ; |
nl .name-without level+ |
|
THEN |
: c-exit dup 1 cells - |
DebugBranch cell+ ; |
CheckEnd |
|
IF Display? IF nlflag off S" ;" Com# .string THEN |
: c-exit ( addr1 -- addr2 ) |
C-Stop on |
dup 1 cells - |
ELSE Display? IF S" EXIT " .struc THEN |
CheckEnd |
THEN |
IF |
Debug? IF drop THEN ; |
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 439 VARIABLE C-Pass
|
Line 549 VARIABLE C-Pass
|
|
|
CREATE C-Table |
CREATE C-Table |
' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
' call A, ' c-call A, |
' does-exec A, ' c-callxt A, |
' (s") A, ' c-c" A, |
' lit@ A, ' c-call A, |
' (.") A, ' c-c" A, |
[IFDEF] call ' call A, ' c-call A, [THEN] |
' "lit A, ' c-c" A, |
\ ' 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, |
' 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, |
[IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN] |
[IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN] |
[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, |
' (abort") A, ' c-abort" A, |
[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] |
[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN] |
Line 470 c-extender !
|
Line 585 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!) |
THEN |
2drop false EXIT |
\ jump over to extender, if any 26jan97jaw |
THEN |
2 pick <> |
THEN |
WHILE 2 cells + |
\ jump over to extender, if any 26jan97jaw |
REPEAT |
xt>threaded 2 pick <> |
nip cell+ perform |
WHILE |
true |
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? |
Line 546 Defer discode ( addr u -- ) \ gforth
|
Line 664 Defer discode ( addr u -- ) \ gforth
|
: next-head ( addr1 -- addr2 ) \ gforth |
: next-head ( addr1 -- addr2 ) \ gforth |
\G find the next header starting after addr1, up to here (unreliable). |
\G find the next header starting after addr1, up to here (unreliable). |
here swap u+do |
here swap u+do |
i head? |
i head? -2 and if |
if |
|
i unloop exit |
i unloop exit |
then |
then |
cell +loop |
cell +loop |
here ; |
here ; |
|
|
|
[ifundef] umin \ !! bootstrapping help |
: umin ( u1 u2 -- u ) |
: umin ( u1 u2 -- u ) |
2dup u> |
2dup u> |
if |
if |
swap |
swap |
then |
then |
drop ; |
drop ; |
|
[then] |
|
|
: next-prim ( addr1 -- addr2 ) \ gforth |
: next-prim ( addr1 -- addr2 ) \ gforth |
\G find the next primitive after addr1 (unreliable) |
\G find the next primitive after addr1 (unreliable) |
1+ >r -1 primstart |
1+ >r -1 primstart |
Line 579 Defer discode ( addr u -- ) \ gforth
|
Line 698 Defer discode ( addr u -- ) \ gforth
|
|
|
: seecode ( xt -- ) |
: seecode ( xt -- ) |
dup s" Code" .defname |
dup s" Code" .defname |
threading-method |
>code-address |
if |
|
>code-address |
|
then |
|
dup in-dictionary? \ user-defined code word? |
dup in-dictionary? \ user-defined code word? |
if |
if |
dup next-head |
dup next-head |
Line 607 Defer discode ( addr u -- ) \ gforth
|
Line 723 Defer discode ( addr u -- ) \ gforth
|
>name ?dup-if |
>name ?dup-if |
." IS " .name cr |
." IS " .name cr |
else |
else |
." lastxt >body !" |
." latestxt >body !" |
then ; |
then ; |
: see-threaded ( addr -- ) |
: see-threaded ( addr -- ) |
C-Pass @ DebugMode = IF |
C-Pass @ DebugMode = IF |
Line 642 Defer discode ( addr u -- ) \ gforth
|
Line 758 Defer discode ( addr u -- ) \ gforth
|
dup >code-address |
dup >code-address |
CASE |
CASE |
docon: of seecon endof |
docon: of seecon endof |
|
dovalue: of seevalue endof |
docol: of seecol endof |
docol: of seecol endof |
dovar: of seevar endof |
dovar: of seevar endof |
[ [IFDEF] douser: ] |
[ [IFDEF] douser: ] |
Line 659 Defer discode ( addr u -- ) \ gforth
|
Line 776 Defer discode ( addr u -- ) \ gforth
|
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 -- ) |
Line 674 Defer discode ( addr u -- ) \ gforth
|
Line 791 Defer discode ( addr u -- ) \ gforth
|
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 ; |