see.fs 24.9 KB
Newer Older
anton's avatar
anton committed
1 2
\ SEE.FS       highend SEE for ANSforth                16may93jaw

Anton Ertl's avatar
Anton Ertl committed
3
\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008,2010,2013,2014,2015,2016,2017,2018 Free Software Foundation, Inc.
anton's avatar
anton committed
4 5 6 7 8

\ 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
9
\ as published by the Free Software Foundation, either version 3
anton's avatar
anton committed
10 11 12 13 14 15 16 17
\ 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
18
\ along with this program. If not, see http://www.gnu.org/licenses/.
anton's avatar
anton committed
19 20


anton's avatar
anton committed
21 22 23 24 25 26
\ May be cross-compiled

\ I'm sorry. This is really not "forthy" enough.

\ Ideas:        Level should be a stack

jwilke's avatar
jwilke committed
27
require look.fs
28
require termsize.fs
jwilke's avatar
jwilke committed
29
require wordinfo.fs
30

anton's avatar
anton committed
31 32
decimal

33 34 35 36
Vocabulary see-voc

get-current also see-voc definitions

anton's avatar
anton committed
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
\ Screen format words                                   16may93jaw

VARIABLE C-Output   1 C-Output  !
VARIABLE C-Formated 1 C-Formated !
VARIABLE C-Highlight 0 C-Highlight !
VARIABLE C-Clearline 0 C-Clearline !

VARIABLE XPos
VARIABLE YPos
VARIABLE Level

: Format        C-Formated @ C-Output @ and
                IF dup spaces XPos +! ELSE drop THEN ;

: level+        7 Level +!
                Level @ XPos @ -
                dup 0> IF Format ELSE drop THEN ;

: level-        -7 Level +! ;

VARIABLE nlflag
pazsan's avatar
pazsan committed
58
VARIABLE uppercase	\ structure words are in uppercase
anton's avatar
anton committed
59 60 61 62 63

DEFER nlcount ' noop IS nlcount

: nl            nlflag on ;
: (nl)          nlcount
jwilke's avatar
jwilke committed
64
                XPos @ Level @ = IF EXIT THEN \ ?Exit
anton's avatar
anton committed
65 66
                C-Formated @ IF
                C-Output @
67
                IF C-Clearline @ IF cols XPos @ - spaces
anton's avatar
anton committed
68 69 70 71 72 73 74
                                 ELSE cr THEN
                1 YPos +! 0 XPos !
                Level @ spaces
                THEN Level @ XPos ! THEN ;

: warp?         ( len -- len )
                nlflag @ IF (nl) nlflag off THEN
75
                XPos @ over + cols u>= IF (nl) THEN ;
anton's avatar
anton committed
76 77

: ctype         ( adr len -- )
pazsan's avatar
pazsan committed
78
                warp? dup XPos +! C-Output @ 
anton's avatar
anton committed
79
		IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP
pazsan's avatar
pazsan committed
80 81
				  uppercase off ELSE type THEN
		ELSE 2drop THEN ;
anton's avatar
anton committed
82 83 84 85 86 87

: cemit         1 warp?
                over bl = Level @ XPos @ = and
                IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
                THEN ;

88 89 90 91 92 93 94 95 96 97 98 99 100
	    
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 ;

101 102
dup set-current

103 104 105 106
Defer discode ( addr u -- ) \ gforth
\G hook for the disassembler: disassemble u bytes of code at addr
' dump IS discode

107 108
definitions

109 110 111
: next-head ( addr1 -- addr2 ) \ gforth
    \G find the next header starting after addr1, up to here (unreliable).
    here swap u+do
112
	i xt? -2 and if
113
	    i name>string drop cell negate and unloop exit
114 115 116 117 118 119 120 121
	then
    cell +loop
    here ;

: next-prim ( addr1 -- addr2 ) \ gforth
    \G find the next primitive after addr1 (unreliable)
    1+ >r -1 primstart
    begin ( umin head R: boundary )
122
	>link @ dup
123 124 125 126 127 128 129 130 131 132 133 134
    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> + ;

135
DEFER .string ( c-addr u n -- )
anton's avatar
anton committed
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155

[IFDEF] Green
VARIABLE Colors Colors on

: (.string)     ( c-addr u n -- )
                over warp? drop
                Colors @
                IF C-Highlight @ ?dup
                   IF   CT@ swap CT@ or
                   ELSE CT@
                   THEN
                attr! ELSE drop THEN
                ctype  ct @ attr! ;
[ELSE]
: (.string)     ( c-addr u n -- )
                drop ctype ;
[THEN]

' (.string) IS .string

Anton Ertl's avatar
Anton Ertl committed
156
: c-\emit ( c -- )
Anton Ertl's avatar
Anton Ertl committed
157
    \ show char in \-escaped form; note that newlines can have
Anton Ertl's avatar
Anton Ertl committed
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
    \ two chars, so they need to be handled at the string level.
    dup '" = over '\ = or if
	'\ cemit cemit
    else
	dup bl 127 within if
	    cemit
	else
	    base @ { oldbase } try
		$10 base ! 0 <<# # # 'x' hold '\' hold #> ctype #>> 0
	    restore
		oldbase base !
	    endtry
	    throw
	endif
    endif ;

174 175 176 177 178 179 180 181
: 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
Anton Ertl's avatar
Anton Ertl committed
182
		over c@ c-\emit 1 /string
183 184 185
	    endif
    repeat
    2drop ;
anton's avatar
anton committed
186

187
Variable struct-pre
pazsan's avatar
pazsan committed
188
: .struc        
189
	uppercase on Str# struct-pre $@ Str# .string .string struct-pre $off ;
anton's avatar
anton committed
190

jwilke's avatar
jwilke committed
191
\ CODES (Branchtypes)                                    15may93jaw
anton's avatar
anton committed
192

193 194 195 196
21 Constant RepeatCode
22 Constant AgainCode
23 Constant UntilCode
24 Constant LoopCode
anton's avatar
anton committed
197
\ 09 CONSTANT WhileCode
198 199 200 201 202
10 Constant ElseCode
11 Constant AheadCode
13 Constant WhileCode2
14 Constant Disable
15 Constant LeaveCode
jwilke's avatar
jwilke committed
203

anton's avatar
anton committed
204 205 206 207 208 209

\ FORMAT WORDS                                          13jun93jaw

VARIABLE C-Stop
VARIABLE Branches

jwilke's avatar
jwilke committed
210
VARIABLE BranchPointer	\ point to the end of branch table
anton's avatar
anton committed
211
VARIABLE SearchPointer
jwilke's avatar
jwilke committed
212 213 214 215

\ The branchtable consists of three entrys:
\ address of branch , branch destination , branch type

pazsan's avatar
pazsan committed
216
CREATE BranchTable 128 cells allot
anton's avatar
anton committed
217 218 219 220 221
here 3 cells -
ACONSTANT MaxTable

: FirstBranch BranchTable cell+ SearchPointer ! ;

jwilke's avatar
jwilke committed
222 223 224 225
: (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
\ searches a branch with destination a-addr1
\ a-addr1: branch destination
\ a-addr2: pointer in branch table
anton's avatar
anton committed
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
        SearchPointer @
        BEGIN   dup BranchPointer @ u<
        WHILE
                dup @ 2 pick <>
        WHILE   3 cells +
        REPEAT
        nip dup  3 cells + SearchPointer ! true
        ELSE
        2drop false
        THEN ;

: BranchAddr?
        FirstBranch (BranchAddr?) ;

' (BranchAddr?) ALIAS MoreBranchAddr?

: CheckEnd ( a-addr -- true | false )
        BranchTable cell+
        BEGIN   dup BranchPointer @ u<
        WHILE
                dup @ 2 pick u<=
        WHILE   3 cells +
        REPEAT
        2drop false
        ELSE
        2drop true
        THEN ;

Bernd Paysan's avatar
Bernd Paysan committed
254 255
[IFUNDEF] cell- : cell- cell - ; [THEN]
    
jwilke's avatar
jwilke committed
256 257
: MyBranch      ( a-addr -- a-addr a-addr2 )
\ finds branch table entry for branch at a-addr
258
                dup @
jwilke's avatar
jwilke committed
259 260
                BranchAddr?
                BEGIN
261
                WHILE cell- @
jwilke's avatar
jwilke committed
262
                      over <>
263
                WHILE dup @
jwilke's avatar
jwilke committed
264 265 266 267 268 269
                      MoreBranchAddr?
                REPEAT
                SearchPointer @ 3 cells -
                ELSE    true ABORT" SEE: Table failure"
                THEN ;

anton's avatar
anton committed
270 271 272 273 274 275 276 277 278 279 280
\
\                 addrw               addrt
\       BEGIN ... WHILE ... AGAIN ... THEN
\         ^         !        !          ^
\         ----------+--------+          !
\                   !                   !
\                   +-------------------+
\
\

: CheckWhile ( a-addrw a-addrt -- true | false )
Bernd Paysan's avatar
Bernd Paysan committed
281 282
        BranchTable >r
        BEGIN   r@ BranchPointer @ u<
Bernd Paysan's avatar
Bernd Paysan committed
283
        WHILE   2dup r@ @ within
Bernd Paysan's avatar
Bernd Paysan committed
284 285
                IF  over r@ cell+ @ u>
                        IF 2drop rdrop true EXIT THEN
anton's avatar
anton committed
286
                THEN
Bernd Paysan's avatar
Bernd Paysan committed
287
                r> 3 cells + >r
anton's avatar
anton committed
288
        REPEAT
Bernd Paysan's avatar
Bernd Paysan committed
289
        2drop rdrop false ;
anton's avatar
anton committed
290 291 292 293 294 295 296

: ,Branch ( a-addr -- )
        BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
        !
        1 cells BranchPointer +! ;

: Type!   ( u -- )
297
        BranchPointer @ cell- ! ;
anton's avatar
anton committed
298 299

: Branch! ( a-addr rel -- a-addr )
300 301
    over ,Branch ,Branch 0 ,Branch ;
\        over + over ,Branch ,Branch 0 ,Branch ;
anton's avatar
anton committed
302 303 304 305 306 307 308 309 310 311 312 313

\ DEFER CheckUntil
VARIABLE NoOutput
VARIABLE C-Pass

0 CONSTANT ScanMode
1 CONSTANT DisplayMode
2 CONSTANT DebugMode

: Scan? ( -- flag ) C-Pass @ 0= ;
: Display? ( -- flag ) C-Pass @ 1 = ;
: Debug? ( -- flag ) C-Pass @ 2 = ;
dvdkhlng's avatar
dvdkhlng committed
314
: ?.string  ( c-addr u n -- )   Display? if .string else 2drop drop then ;
anton's avatar
anton committed
315

316 317
: back? ( addr target -- addr flag )
    over u< ;
anton's avatar
anton committed
318

319 320 321
: .word ( addr x -- addr )
    \ print x as a word if possible
    dup look 0= IF
322
	drop dup threaded>name dup 0= if
323
	    drop over cell- @ dup body> look
324
	    IF
325
		nip nip dup ." <" name>string rot wordinfo .string ." > "
326
	    ELSE
327
		2drop ." <$" 0 ['] .r $10 base-execute ." > "
328 329 330 331
	    THEN
	    EXIT
	then
    THEN
332
    nip dup immediate?
333
    IF
334
	bl cemit  ." [COMPILE] "
335 336 337
    THEN
    dup name>string rot wordinfo .string
    ;
338

anton's avatar
anton committed
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
: 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

pazsan's avatar
pazsan committed
354 355 356 357 358 359
[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]

360 361 362
: c># ( n -- addr u ) dup abs 0 <# #S rot sign #> ;
: c-. ( n -- ) c># 0 .string bl cemit ;

anton's avatar
anton committed
363
: c-lit ( addr1 -- addr2 )
dvdkhlng's avatar
dvdkhlng committed
364 365 366 367
    dup @ dup body> dup cfaligned over = swap in-dictionary? and if
	( addr1 addr1@ )
	dup body> @ dovar: = if
	    drop c-call EXIT
anton's avatar
anton committed
368
	endif
dvdkhlng's avatar
dvdkhlng committed
369 370
    endif
    over 4 cells + over = if
371 372
	over 1 cells + @ decompile-prim ['] call xt= >r
	over 3 cells + @ decompile-prim ['] ;S xt=
dvdkhlng's avatar
dvdkhlng committed
373
	r> and if
374
	    over 2 cells + @ ['] set-does> >body = if  drop
dvdkhlng's avatar
dvdkhlng committed
375
		S" DOES> " Com# ?.string 4 cells + EXIT endif
pazsan's avatar
pazsan committed
376
	endif
dvdkhlng's avatar
dvdkhlng committed
377 378
	[IFDEF] !;abi-code
	    over 2 cells + @ ['] !;abi-code >body = if  drop
379
		S" ;abi-code " Com# ?.string   4 cells +
dvdkhlng's avatar
dvdkhlng committed
380
		c-stop on
381 382 383 384
		Display? if
		    dup   dup  next-head   over - discode 
		    S" end-code" Com# ?.string 
		then   EXIT
dvdkhlng's avatar
dvdkhlng committed
385 386 387 388
	    endif
	[THEN]
    endif
    Display? if
anton's avatar
anton committed
389
	\ !! test for cfa here, and print "['] ..."
390 391 392
	dup >name dup IF
	    nip ." ['] " name>string
	ELSE
393
	    drop c>#
394 395
	THEN
	0 .string bl cemit
dvdkhlng's avatar
dvdkhlng committed
396
    else  drop  then
anton's avatar
anton committed
397 398 399 400
    cell+ ;

: c-lit+ ( addr1 -- addr2 )
    Display? if
401
	dup @ c-.
anton's avatar
anton committed
402 403 404
	s" + " 0 .string
    endif
    cell+ ;
405

jwilke's avatar
jwilke committed
406
: .name-without ( addr -- addr )
407 408
    \ !! the stack effect cannot be correct
    \ prints a name without a() e.g. a(+LOOP) or (s")
409
    dup cell- @ threaded>name dup IF
410 411 412 413 414 415 416 417
	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 ;
anton's avatar
anton committed
418 419

: c-c"
jwilke's avatar
jwilke committed
420
	Display? IF nl .name-without THEN
anton's avatar
anton committed
421 422
        count 2dup + aligned -rot
        Display?
jwilke's avatar
jwilke committed
423
        IF      bl cemit 0 .string
424
                '"' cemit bl cemit
anton's avatar
anton committed
425 426
        ELSE    2drop
        THEN ;
427 428 429 430 431 432

: 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
433 434 435
    \ 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
436 437 438 439
    \ !! not recognized anywhere:
    \ abort": if ahead X: len string then lit X c(abort") then
    dup @ back? if false exit endif
    dup @ >r
440
    r@ @ decompile-prim ['] lit xt= 0= if rdrop false exit endif
441 442
    r@ cell+ @ over cell+ <> if rdrop false exit endif
    \ we have at least C"
443
    r@ 2 cells + @ decompile-prim dup ['] lit xt= if
444
	drop r@ 3 cells + @ over cell+ + aligned r@ = if
445
	    \ we have at least s"
446
	    r@ 4 cells + @ decompile-prim ['] lit-perform xt=
447 448 449 450 451 452 453 454 455 456 457 458 459 460
	    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
461
    ['] f@ xt= if
462 463 464 465 466
	display? if
	    r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit
	endif
	drop r> 3 cells + true exit
    endif
467 468 469 470 471
    \ !! 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 ;
anton's avatar
anton committed
472

jwilke's avatar
jwilke committed
473
: Forward? ( a-addr true | false -- a-addr true | false )
474 475 476
    \ a-addr is pointer into branch table
    \ returns true when jump is a forward jump
    IF
477
	dup dup @ swap cell- @ u> IF
478 479 480 481 482 483 484 485
	    true
	ELSE
	    drop false
	THEN
	\ only if forward jump
    ELSE
	false
    THEN ;
anton's avatar
anton committed
486

jwilke's avatar
jwilke committed
487
: RepeatCheck ( a-addr1 a-addr2 true | false -- false )
anton's avatar
anton committed
488
        IF  BEGIN  2dup
489
                   cell- @ swap @
anton's avatar
anton committed
490 491 492 493 494 495 496 497 498
                   u<=
            WHILE  drop dup cell+
                   MoreBranchAddr? 0=
            UNTIL  false
            ELSE   true
            THEN
        ELSE false
        THEN ;

499 500
: c-branch ( addr1 -- addr2 )
    c-string? ?exit
anton's avatar
anton committed
501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526
        Scan?
        IF      dup @ Branch!
                dup @ back?
                IF                      \ might be: AGAIN, REPEAT
                        dup cell+ BranchAddr? Forward?
                        RepeatCheck
                        IF      RepeatCode Type!
                                cell+ Disable swap !
                        ELSE    AgainCode Type!
                        THEN
                ELSE    dup cell+ BranchAddr? Forward?
                        IF      ElseCode Type! drop
                        ELSE    AheadCode Type!
                        THEN
                THEN
        THEN
        Display?
        IF
                dup @ back?
                IF                      \ might be: AGAIN, REPEAT
                        level- nl
                        dup cell+ BranchAddr? Forward?
                        RepeatCheck
                        IF      drop S" REPEAT " .struc nl
                        ELSE    S" AGAIN " .struc nl
                        THEN
jwilke's avatar
jwilke committed
527 528 529 530 531
                ELSE    MyBranch cell+ @ LeaveCode =
			IF 	S" LEAVE " .struc
			ELSE
				dup cell+ BranchAddr? Forward?
       	                 	IF      dup cell+ @ WhileCode2 =
pazsan's avatar
pazsan committed
532
       	                         	IF nl S" ELSE " .struc level+
jwilke's avatar
jwilke committed
533 534
                                	ELSE level- nl S" ELSE" .struc level+ THEN
                                	cell+ Disable swap !
pazsan's avatar
pazsan committed
535
                        	ELSE    S" AHEAD " .struc level+
jwilke's avatar
jwilke committed
536 537
                        	THEN
			THEN
anton's avatar
anton committed
538 539 540
                THEN
        THEN
        Debug?
541
        IF      @ \ !!! cross-interacts with debugger !!!
anton's avatar
anton committed
542 543 544 545 546
        ELSE    cell+
        THEN ;

: DebugBranch
        Debug?
547
        IF      dup @ swap THEN ; \ return 2 different addresses
anton's avatar
anton committed
548 549 550 551 552 553 554 555 556 557

: c-?branch
        Scan?
        IF      dup @ Branch!
                dup @ Back?
                IF      UntilCode Type! THEN
        THEN
        Display?
        IF      dup @ Back?
                IF      level- nl S" UNTIL " .struc nl
Bernd Paysan's avatar
Bernd Paysan committed
558
                ELSE    dup    dup @
anton's avatar
anton committed
559 560 561 562 563 564
                        CheckWhile
                        IF      MyBranch
                                cell+ dup @ 0=
                                         IF WhileCode2 swap !
                                         ELSE drop THEN
                                level- nl
565
                                S" WHILE " .struc
anton's avatar
anton committed
566
                                level+
jwilke's avatar
jwilke committed
567 568 569 570
                        ELSE    MyBranch cell+ @ LeaveCode =
				IF   s" 0= ?LEAVE " .struc
				ELSE nl S" IF " .struc level+
				THEN
anton's avatar
anton committed
571 572 573 574 575 576
                        THEN
                THEN
        THEN
        DebugBranch
        cell+ ;

577 578 579
: c-?dup-?branch Scan? 0= IF  s" ?dup-" struct-pre $!  THEN
	c-?branch ;
    
anton's avatar
anton committed
580
: c-for
581
    Display? IF nl S" FOR" .struc level+ THEN ;
anton's avatar
anton committed
582 583

: c-loop
584
        scan? IF  dup @ Branch!  LoopCode Type! THEN
585
        Display? IF level- nl .name-without nl bl cemit THEN
jwilke's avatar
jwilke committed
586 587 588 589 590 591 592 593
        DebugBranch cell+ 
	Scan? 
	IF 	dup BranchAddr? 
		BEGIN   WHILE cell+ LeaveCode swap !
			dup MoreBranchAddr?
		REPEAT
	THEN
	cell+ ;
anton's avatar
anton committed
594

pazsan's avatar
pazsan committed
595
: c-do
596 597 598 599 600 601 602 603 604
    Display? IF
	dup BranchAddr?
	IF  cell+ dup @ LoopCode =
	    IF
		Disable swap !
		nl .name-without level+
	    ELSE  drop ." 2>r "  THEN
	ELSE  ." 2>r "  THEN
    THEN ;
605

606 607 608
: c-?do ( addr1 -- addr2 )
    Display? IF
	nl .name-without level+
609
	dup cell+ BranchAddr?  IF  Disable swap !  THEN
610 611
    THEN
    DebugBranch cell+ ;
612

613
: c-exit ( addr1 -- addr2 )
614
    dup cell-
615 616 617 618 619 620 621 622
    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 !!!
anton's avatar
anton committed
623 624 625 626 627

: c-abort"
        count 2dup + aligned -rot
        Display?
        IF      S" ABORT" .struc
628 629
                '"' cemit bl cemit 0 .string
                '"' cemit bl cemit
anton's avatar
anton committed
630 631 632
        ELSE    2drop
        THEN ;

633 634 635 636 637 638 639 640 641 642
[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]
anton's avatar
anton committed
643

644
[IFDEF] u#exec
Bernd Paysan's avatar
Bernd Paysan committed
645 646
    Variable u#what \ global variable to specify what to search for
    : search-u#gen ( 0 offset1 offset2 nt -- xt/0 offset1 offset2 flag )
647
	name>int dup @ docol: = IF
Bernd Paysan's avatar
Bernd Paysan committed
648
	    dup >body @ decompile-prim u#what @ xt=
649 650 651 652 653 654
	    over >body 3 cells + @ decompile-prim ['] ;S xt= and
	    IF  >r 2dup r@ >body cell+ 2@ d=
		IF  r> -rot 2>r nip 2r> false  EXIT  THEN
		r>
	    THEN
	THEN  drop true ;
Bernd Paysan's avatar
Bernd Paysan committed
655
    : c-u#gen ( addr -- addr' )
656
	display? IF
657
	    0 over 2@
Bernd Paysan's avatar
Bernd Paysan committed
658
	    [: ['] search-u#gen swap traverse-wordlist ;] map-vocs
659 660 661 662
	    2drop
	    ?dup-IF
		>name name>string Com# .string bl cemit
		2 cells + EXIT  THEN
Bernd Paysan's avatar
Bernd Paysan committed
663 664
	    u#what @ name>string com# .string bl cemit
	    dup @ c-. cell+ dup @ c-. cell+
665
	ELSE  2 cells +  THEN ;
Bernd Paysan's avatar
Bernd Paysan committed
666 667 668

    : c-u#exec ( addr -- addr' )  ['] u#exec u#what ! c-u#gen ;
    : c-u#+    ( addr -- addr' )  ['] u#+    u#what ! c-u#gen ;
669 670
[THEN]

Bernd Paysan's avatar
Bernd Paysan committed
671 672 673
[IFDEF] call-c#
    : c-call-c# ( addr -- addr' )
	display? IF
674
	    dup @ body> name>string com# .string bl cemit
Bernd Paysan's avatar
Bernd Paysan committed
675
	THEN  cell+ ;
676 677 678
[THEN]

[IFDEF] useraddr
679 680
    : ?type-found ( offset nt flag -- offset flag' )
	IF  2dup >body @ = IF  -rot nip false  EXIT
681
	    THEN  THEN  drop true ;
682 683 684
    : search-uservar ( offset nt -- offset flag )
	name>int dup @ douser: = ?type-found ;
    : c-searcharg ( addr xt addr u -- addr' ) 2>r >r
685 686
	display? IF
	    0 over @
687
	    r@ map-vocs drop
688 689
	    display? IF
		?dup-IF  name>string com# .string bl cemit
690
		ELSE  r> 2r@ com# .string >r
691 692 693
		    dup @ c-. bl cemit
		THEN
	    THEN
694 695 696 697
	THEN  cell+ rdrop rdrop rdrop ;
    : c-useraddr ( addr -- addr' )
	[: ['] search-uservar swap traverse-wordlist ;]
	s" useraddr " c-searcharg ;
Bernd Paysan's avatar
Bernd Paysan committed
698
[THEN]
Bernd Paysan's avatar
Bernd Paysan committed
699 700
[IFDEF] user@
    : search-userval ( offset nt -- offset flag )
701
	name>int dup >does-code ['] infile-id >does-code = ?type-found ;
Bernd Paysan's avatar
Bernd Paysan committed
702
    : c-user@ ( addr -- addr' )
703 704
	[: ['] search-userval swap traverse-wordlist ;]
	s" user@ " c-searcharg ;
Bernd Paysan's avatar
Bernd Paysan committed
705
[THEN]
Bernd Paysan's avatar
Bernd Paysan committed
706

Bernd Paysan's avatar
Bernd Paysan committed
707
CREATE C-Table \ primitives map to code only
jwilke's avatar
jwilke committed
708
	        ' lit A,            ' c-lit A,
709
[IFDEF] does-exec ' does-exec A,	    ' c-callxt A, [THEN]
710 711 712
[IFDEF] does-xt ' does-xt A,        ' c-callxt A, [THEN]
[IFDEF] extra-exec ' extra-exec A,	    ' c-callxt A, [THEN]
[IFDEF] extra-xt ' extra-xt A,	    ' c-callxt A, [THEN]
anton's avatar
anton committed
713
		' lit@ A,	    ' c-call A,
714
[IFDEF] call	' call A,           ' c-call A, [THEN]
715
[IFDEF] call-loc ' call-loc A,      ' c-call A, [THEN]
anton's avatar
anton committed
716 717 718
\		' useraddr A,	    ....
		' lit-perform A,    ' c-call A,
		' lit+ A,	    ' c-lit+ A,
719 720 721 722
\ [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]
jwilke's avatar
jwilke committed
723
        	' (do) A,           ' c-do A,
724 725 726 727 728
[IFDEF] (+do)	' (+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] (u-do)	' (u-do) A,	    ' c-?do A, [THEN]
        	' (?do) A,          ' c-?do A,
jwilke's avatar
jwilke committed
729
        	' (for) A,          ' c-for A,
730
        	' ?branch A,        ' c-?branch A,
731
        	' ?dup-?branch A,   ' c-?dup-?branch A,
732 733 734 735 736 737
        	' 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,
jwilke's avatar
jwilke committed
738
        	' ;s A,             ' c-exit A,
739
\ [IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]
740
\ only defined if compiler is loaded
741
\ [IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
Bernd Paysan's avatar
Bernd Paysan committed
742
[IFDEF] u#exec  ' u#exec A,         ' c-u#exec A, [THEN]
Bernd Paysan's avatar
Bernd Paysan committed
743
[IFDEF] u#+     ' u#+ A,            ' c-u#+ A, [THEN]
Bernd Paysan's avatar
Bernd Paysan committed
744
[IFDEF] call-c# ' call-c# A,        ' c-call-c# A, [THEN]
745
[IFDEF] useraddr ' useraddr A,      ' c-useraddr A, [THEN]
Bernd Paysan's avatar
Bernd Paysan committed
746
[IFDEF] user@    ' user@ A,         ' c-user@ A, [THEN]
jwilke's avatar
jwilke committed
747
        	0 ,		here 0 ,
pazsan's avatar
pazsan committed
748 749 750

avariable c-extender
c-extender !
anton's avatar
anton committed
751 752 753

\ DOTABLE                                               15may93jaw

anton's avatar
anton committed
754 755 756 757 758 759 760 761 762 763
: DoTable ( ca/cfa -- flag )
    decompile-prim C-Table BEGIN ( cfa table-entry )
	dup @ dup 0=  IF
	    drop cell+ @ dup IF ( next table!)
		dup @
	    ELSE ( end!)
		2drop false EXIT
	    THEN 
	THEN
	\ jump over to extender, if any 26jan97jaw
764
	2 pick swap xt= 0=
anton's avatar
anton committed
765 766 767 768 769 770
    WHILE
	    2 cells +
    REPEAT
    nip cell+ perform
    true
;
anton's avatar
anton committed
771 772

: BranchTo? ( a-addr -- a-addr )
773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789
    Display?  IF    dup BranchAddr?
	IF
	    BEGIN cell+ @ dup 20 u>
		IF drop nl S" BEGIN " .struc level+
		ELSE
		    dup Disable <>
		    over LeaveCode <> and
		    over LoopCode <> and
		    IF   WhileCode2 =
			IF nl S" THEN " .struc nl ELSE
			    level- nl S" THEN " .struc nl THEN
		    ELSE drop THEN
		THEN
		dup MoreBranchAddr? 0=
	    UNTIL
	THEN
    THEN ;
anton's avatar
anton committed
790 791

: analyse ( a-addr1 -- a-addr2 )
792 793
    Branches @ IF BranchTo? THEN
    dup cell+ swap @
794 795
    dup >r DoTable IF rdrop EXIT THEN
    r> Display?
796
    IF
797
	.word bl cemit
798 799 800
    ELSE
	drop
    THEN ;
anton's avatar
anton committed
801 802 803 804 805 806 807 808 809

: c-init
        0 YPos ! 0 XPos !
        0 Level ! nlflag off
        BranchTable BranchPointer !
        c-stop off
        Branches on ;

: makepass ( a-addr -- )
810 811 812 813 814 815
    c-stop off
    BEGIN
	analyse
	c-stop @
    UNTIL drop ;

816 817
\ user words

818 819
: seecode ( xt -- )
    dup s" Code" .defname
820
    >code-address
821 822 823 824 825 826
    dup in-dictionary? \ user-defined code word?
    if
	dup next-head
    else
	dup next-prim
    then
Bernd Paysan's avatar
Bernd Paysan committed
827
    threading-method 2 = IF  @ >r @ r>  THEN
828 829
    over - discode
    ." end-code" cr ;
830 831 832 833 834
: seeabicode ( xt -- )
    dup s" ABI-Code" .defname
    >body dup dup next-head 
    swap - discode
    ." end-code" cr ;
835 836 837 838 839
: see;abicode ( xt -- )
    dup s" ;ABI-Code" .defname
    >body dup dup next-head 
    swap - discode
    ." end-code" cr ;
840 841 842 843 844 845 846 847 848 849 850 851 852
: seevar ( xt -- )
    s" Variable" .defname cr ;
: seeuser ( xt -- )
    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
853
    >name ?dup-if
854
	." IS " .name cr
855
    else
856
	." latestxt >body !"
857 858 859 860 861
    then ;
: see-threaded ( addr -- )
    C-Pass @ DebugMode = IF
	ScanMode c-pass !
	EXIT
862 863 864
    THEN
    ScanMode c-pass ! dup makepass
    DisplayMode c-pass ! makepass ;
865
: seedoes ( xt -- )
Anton Ertl's avatar
Anton Ertl committed
866
    \ !! make it work for general xt set-does> words
867 868 869 870
    dup s" create" .defname cr
    S" DOES> " Com# .string XPos @ Level !
    >does-code see-threaded ;
: seecol ( xt -- )
pazsan's avatar
pazsan committed
871
    dup s" :" .defname nl
872 873 874 875 876
    2 Level !
    >body see-threaded ;
: seefield ( xt -- )
    dup >body ." 0 " ? ." 0 0 "
    s" Field" .defname cr ;
877 878 879 880 881 882 883 884 885 886 887
: seeumethod ( xt -- )
    dup s" umethod" .defname cr
    dup defer@ xt-see-xt cr
    >name ?dup-if
	." IS " .name cr
    else
	." latestxt >body !"
    then ;
: umethod? ( xt -- flag )
    >body dup @ decompile-prim ['] u#exec xt= swap
    3 cells + @ decompile-prim ['] ;S xt= and ;
888

889 890 891 892
\ user visible words

set-current

anton's avatar
anton committed
893 894
: xt-see ( xt -- ) \ gforth
    \G Decompile the definition represented by @i{xt}.
895 896 897 898 899
    cr c-init
    dup >does-code
    if
	seedoes EXIT
    then
jwilke's avatar
jwilke committed
900
    dup xtprim?
901 902 903 904 905 906
    if
	seecode EXIT
    then
    dup >code-address
    CASE
	docon: of seecon endof
907 908 909
[IFDEF] dovalue:
        dovalue: of seevalue endof
[THEN]
910 911
        docol: of dup umethod? IF  seeumethod  ELSE  seecol  THEN  endof
[IFDEF] docolloc:
912
	docolloc: of  seecol  endof
913
[THEN]
914
	dovar: of seevar endof
915
[IFDEF] douser:
916
	douser: of seeuser endof
917 918
[THEN]
[IFDEF] dodefer:
919
	dodefer: of seedefer endof
920 921
[THEN]
[IFDEF] dofield:
922
	dofield: of seefield endof
923 924 925
[THEN]
[IFDEF] doabicode:
        doabicode: of seeabicode endof
926 927 928
[THEN]
[IFDEF] do;abicode:
        do;abicode: of see;abicode endof
929
[THEN]
930 931
	over       of seecode endof \ direct threaded code words
	over >body of seecode endof \ indirect threaded code words
932 933 934 935
	2drop abort" unknown word type"
    ENDCASE ;

: (xt-see-xt) ( xt -- )
936
    xt-see cr ." latestxt" ;
937 938 939 940 941 942
' (xt-see-xt) is xt-see-xt

: (.immediate) ( xt -- )
    ['] execute = if
	."  immediate"
    then ;
943 944
: (.compile-only) ( nt -- )
    compile-only? IF  ."  compile-only"  THEN ;
945 946

: name-see ( nfa -- )
Bernd Paysan's avatar
Bernd Paysan committed
947
    dup synonym? IF
948
	." Synonym " dup .name dup >body @ .name
949
    ELSE
Bernd Paysan's avatar
Bernd Paysan committed
950
	dup alias? IF
951 952
	    dup >body @ name>string nip 0= IF
		dup >body @ hex.
Bernd Paysan's avatar
Bernd Paysan committed
953
	    ELSE
954
		." ' " dup >body @ .name
Bernd Paysan's avatar
Bernd Paysan committed
955 956 957
	    THEN ." Alias " dup .name
	THEN
    THEN
958
    dup >r
959
    dup name>comp 
960
    over r@ name>int =
961 962
    if \ normal or immediate word
	swap xt-see (.immediate)
963
	r@ (.compile-only)
964
    else
965 966 967 968
	\ interpret/compile word
	r@ name>int xt-see-xt cr
	swap xt-see-xt cr
	." interpret/compile: " r@ .name drop
969 970
    then
    rdrop drop ;
anton's avatar
anton committed
971

972 973 974 975 976 977
: 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.
anton's avatar
anton committed
978 979
    name find-name dup 0=
    IF
980
	drop -&13 throw
anton's avatar
anton committed
981
    THEN
982
    name-see ;
anton's avatar
anton committed
983

Bernd Paysan's avatar
Bernd Paysan committed
984
previous