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

3
\ Authors: Bernd Paysan, Anton Ertl, David Kühling, Jens Wilke, Neal Crook
Anton Ertl's avatar
Anton Ertl committed
4
\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008,2010,2013,2014,2015,2016,2017,2018,2019 Free Software Foundation, Inc.
anton's avatar
anton committed
5 6 7 8 9

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


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

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

\ Ideas:        Level should be a stack

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

anton's avatar
anton committed
32 33
decimal

34 35 36 37
Vocabulary see-voc

get-current also see-voc definitions

anton's avatar
anton committed
38 39 40 41 42 43 44 45 46 47 48
\ 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

49 50 51 52 53 54
    
: Format ( u -- )
    C-Formated @ C-Output @ and if ( u )
	dup spaces dup XPos +! then
    drop ;

anton's avatar
anton committed
55

56 57 58
: level+ ( -- )
    7 Level +!
    Level @ XPos @ - dup 0> IF Format ELSE drop THEN ;
anton's avatar
anton committed
59

60 61
: level- ( -- )
    -7 Level +! ;
anton's avatar
anton committed
62 63

VARIABLE nlflag
pazsan's avatar
pazsan committed
64
VARIABLE uppercase	\ structure words are in uppercase
anton's avatar
anton committed
65

66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
DEFER nlcount ( -- )
' noop IS nlcount

: nl ( -- )
    nlflag on ;
: (nl) ( -- )
    nlcount
    XPos @ Level @ = IF EXIT THEN \ ?Exit
    C-Formated @ IF
	C-Output @ IF
	    C-Clearline @ IF
		cols XPos @ - spaces
	    ELSE
		cr THEN
	    1 YPos +! 0 XPos !
	    Level @ spaces THEN
	Level @ XPos ! THEN ;
anton's avatar
anton committed
83 84 85

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

: ctype         ( adr len -- )
pazsan's avatar
pazsan committed
89
                warp? dup XPos +! C-Output @ 
anton's avatar
anton committed
90
		IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP
pazsan's avatar
pazsan committed
91 92
				  uppercase off ELSE type THEN
		ELSE 2drop THEN ;
anton's avatar
anton committed
93

94 95 96 97 98 99 100
: cemit ( c -- )
    1 warp?
    over bl = Level @ XPos @ = and IF
	2drop
    ELSE
	XPos +! C-Output @ IF emit ELSE drop THEN
    THEN ;
anton's avatar
anton committed
101

102 103 104 105 106 107 108 109 110 111 112 113 114
	    
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 ;

115 116
dup set-current

117 118 119 120
Defer discode ( addr u -- ) \ gforth
\G hook for the disassembler: disassemble u bytes of code at addr
' dump IS discode

121 122
definitions

123 124 125
: next-head ( addr1 -- addr2 ) \ gforth
    \G find the next header starting after addr1, up to here (unreliable).
    here swap u+do
126
	i xt? if
127
	    i name>string drop cell negate and unloop exit
128 129 130 131 132 133 134 135
	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 )
136
	>link @ dup
137 138 139 140 141 142 143 144 145 146 147 148
    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> + ;

anton's avatar
anton committed
149
DEFER .string ( c-addr u n -- )
anton's avatar
anton committed
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169

[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
170
: c-\emit ( c -- )
Anton Ertl's avatar
Anton Ertl committed
171
    \ show char in \-escaped form; note that newlines can have
Anton Ertl's avatar
Anton Ertl committed
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
    \ 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 ;

188 189 190 191 192 193 194 195
: 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
196
		over c@ c-\emit 1 /string
197 198 199
	    endif
    repeat
    2drop ;
anton's avatar
anton committed
200

201
Variable struct-pre
202
: .struc ( c-addr u -- )       
203
	uppercase on Str# struct-pre $@ Str# .string .string struct-pre $off ;
anton's avatar
anton committed
204

jwilke's avatar
jwilke committed
205
\ CODES (Branchtypes)                                    15may93jaw
anton's avatar
anton committed
206

207 208 209 210
21 Constant RepeatCode
22 Constant AgainCode
23 Constant UntilCode
24 Constant LoopCode
anton's avatar
anton committed
211
\ 09 CONSTANT WhileCode
212 213 214 215 216
10 Constant ElseCode
11 Constant AheadCode
13 Constant WhileCode2
14 Constant Disable
15 Constant LeaveCode
jwilke's avatar
jwilke committed
217

anton's avatar
anton committed
218 219 220 221 222 223

\ FORMAT WORDS                                          13jun93jaw

VARIABLE C-Stop
VARIABLE Branches

jwilke's avatar
jwilke committed
224
VARIABLE BranchPointer	\ point to the end of branch table
anton's avatar
anton committed
225
VARIABLE SearchPointer
jwilke's avatar
jwilke committed
226 227 228 229

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

pazsan's avatar
pazsan committed
230
CREATE BranchTable 128 cells allot
anton's avatar
anton committed
231 232 233
here 3 cells -
ACONSTANT MaxTable

234 235
: FirstBranch ( -- )
    BranchTable cell+ SearchPointer ! ;
anton's avatar
anton committed
236

jwilke's avatar
jwilke committed
237
: (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
238 239 240 241 242 243 244 245 246 247 248
    \ searches a branch with destination a-addr1
    \ a-addr1: branch destination
    \ a-addr2: pointer in branch table
    SearchPointer @ BEGIN
	dup BranchPointer @ u< WHILE
	    dup @ 2 pick <> WHILE
		3 cells +
	REPEAT
	nip dup  3 cells + SearchPointer ! true
    ELSE
	2drop false THEN ;
anton's avatar
anton committed
249

250
: BranchAddr? ( a-addr1 -- a-addr2 true | false )
anton's avatar
anton committed
251 252
        FirstBranch (BranchAddr?) ;

253
' (BranchAddr?) ALIAS MoreBranchAddr? ( a-addr1 -- a-addr2 true | false )
anton's avatar
anton committed
254 255

: CheckEnd ( a-addr -- true | false )
256 257 258 259 260 261 262
    BranchTable cell+ BEGIN
	dup BranchPointer @ u< WHILE
	    dup @ 2 pick u<= WHILE
		3 cells + REPEAT
	2drop false
    ELSE
	2drop true THEN ;
anton's avatar
anton committed
263

264
[IFUNDEF] cell- : cell- ( addr1 -- addr2 ) cell - ; [THEN]
Bernd Paysan's avatar
Bernd Paysan committed
265
    
jwilke's avatar
jwilke committed
266 267
: MyBranch      ( a-addr -- a-addr a-addr2 )
\ finds branch table entry for branch at a-addr
268 269 270 271 272 273 274
    dup @ BranchAddr? BEGIN
    WHILE
	    cell- @ over <> WHILE
		dup @ MoreBranchAddr? REPEAT
	SearchPointer @ 3 cells -
    ELSE
	true ABORT" SEE: Table failure" THEN ;
jwilke's avatar
jwilke committed
275

anton's avatar
anton committed
276 277 278 279 280 281 282 283 284 285 286
\
\                 addrw               addrt
\       BEGIN ... WHILE ... AGAIN ... THEN
\         ^         !        !          ^
\         ----------+--------+          !
\                   !                   !
\                   +-------------------+
\
\

: CheckWhile ( a-addrw a-addrt -- true | false )
287 288 289 290 291 292 293 294
    BranchTable >r BEGIN
	r@ BranchPointer @ u< WHILE
	    2dup r@ @ within IF
		over r@ cell+ @ u> IF
		    2drop rdrop true EXIT THEN
	    THEN
	    r> 3 cells + >r REPEAT
    2drop rdrop false ;
anton's avatar
anton committed
295 296 297 298 299 300 301

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

: Type!   ( u -- )
Bernd Paysan's avatar
Bernd Paysan committed
302
        BranchPointer @ cell- ! ;
anton's avatar
anton committed
303 304

: Branch! ( a-addr rel -- a-addr )
305 306
    over ,Branch ,Branch 0 ,Branch ;
\        over + over ,Branch ,Branch 0 ,Branch ;
anton's avatar
anton committed
307 308 309 310 311 312 313 314 315 316 317 318

\ 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
319
: ?.string  ( c-addr u n -- )   Display? if .string else 2drop drop then ;
anton's avatar
anton committed
320

321 322
: back? ( addr target -- addr flag )
    over u< ;
anton's avatar
anton committed
323

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

anton's avatar
anton committed
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
: 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
357
[IFDEF] !does
358 359 360
    : c-does> ( -- )
	\ end of create part
	Display? IF S" DOES> " Com# .string THEN ;
pazsan's avatar
pazsan committed
361 362 363
\	maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff
[THEN]

364
: c># ( n -- addr u ) `smart. $tmp ;
365
: c-. ( n -- ) c># 0 .string ;
366

anton's avatar
anton committed
367
: c-lit ( addr1 -- addr2 )
dvdkhlng's avatar
dvdkhlng committed
368 369 370 371
    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
372
	endif
dvdkhlng's avatar
dvdkhlng committed
373 374
    endif
    over 4 cells + over = if
375 376
	over 1 cells + @ decompile-prim ['] call xt= >r
	over 3 cells + @ decompile-prim ['] ;S xt=
dvdkhlng's avatar
dvdkhlng committed
377
	r> and if
378
	    over 2 cells + @ ['] set-does> >body = if  drop
dvdkhlng's avatar
dvdkhlng committed
379
		S" DOES> " Com# ?.string 4 cells + EXIT endif
pazsan's avatar
pazsan committed
380
	endif
dvdkhlng's avatar
dvdkhlng committed
381 382
	[IFDEF] !;abi-code
	    over 2 cells + @ ['] !;abi-code >body = if  drop
383
		S" ;abi-code " Com# ?.string   4 cells +
dvdkhlng's avatar
dvdkhlng committed
384
		c-stop on
385 386 387 388
		Display? if
		    dup   dup  next-head   over - discode 
		    S" end-code" Com# ?.string 
		then   EXIT
dvdkhlng's avatar
dvdkhlng committed
389 390 391
	    endif
	[THEN]
    endif
392 393 394
    Display? if ( addr1 addr1@ )
	dup c-. then
    drop cell+ ;
anton's avatar
anton committed
395 396 397

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

jwilke's avatar
jwilke committed
403
: .name-without ( addr -- addr )
404
    \ !! the stack effect cannot be correct
405
    \ prints a name without () and without -LP+!#, e.g. a (+LOOP) or (s")
Bernd Paysan's avatar
Bernd Paysan committed
406
    dup cell- @ threaded>name dup IF
407
	dup ``(/loop)# = over ``(/loop)#-lp+!# = or if drop ``+loop then
Anton Ertl's avatar
Anton Ertl committed
408
	name>string over c@ '( = IF
409 410
	    1 /string
	THEN
411 412 413 414 415
	2dup "-lp+!#" string-suffix? if 6 - then
	2dup + 1- c@ ') = IF 1- THEN
	.struc
    ELSE
	drop THEN ;
anton's avatar
anton committed
416 417

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

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

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

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

497
: c-branch ( addr1 -- addr2 )
498 499 500 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 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568
    c-string? ?exit 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
	ELSE
	    MyBranch cell+ @ LeaveCode = IF
		S" LEAVE " .struc
	    ELSE
		dup cell+ BranchAddr? Forward? IF
		    dup cell+ @ WhileCode2 = IF
			nl S" ELSE " .struc level+
		    ELSE
			level- nl S" ELSE" .struc level+ THEN
		    cell+ Disable swap !
		ELSE
		    S" AHEAD " .struc level+ THEN
	    THEN
	THEN
    THEN
    Debug? IF
	@ \ !!! cross-interacts with debugger !!!
    ELSE
	cell+ THEN ;

: DebugBranch ( addr -- x addr | addr )
    \ !! reconstructed stack effect, code looks broken
    \ should probably be ( addr -- addr )
    Debug? IF
	dup @ swap THEN ; \ return 2 different addresses

: c-?branch ( addr -- addr2 )
    Scan? IF
	dup @ Branch!  dup @ Back? IF ( addr )
	    UntilCode Type! THEN
    THEN ( addr )
    Display? IF
	dup @ Back? IF ( addr )
	    level- nl S" UNTIL " .struc nl
	ELSE
	    dup dup @ CheckWhile IF ( addr )
		MyBranch cell+ dup @ 0= IF ( addr addr2 )
		    WhileCode2 swap !
		ELSE
		    drop THEN ( addr )
		level- nl  S" WHILE " .struc  level+
	    ELSE ( addr )
		MyBranch cell+ @ LeaveCode = IF ( addr )
		    s" 0= ?LEAVE " .struc
		ELSE
		    nl S" IF " .struc level+ THEN
	    THEN
	THEN ( addr )
    THEN ( addr )
    DebugBranch cell+ ;
anton's avatar
anton committed
569

570 571 572 573
: c-?dup-?branch ( addr -- addr2 )
    Scan? 0= IF
	s" ?dup-" struct-pre $!  THEN
    c-?branch ;
574
    
575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
: c-for ( -- )
    Display? IF
	nl S" FOR" .struc level+ THEN ;

: c-loop ( addr -- addr1 )
    scan? IF
	dup @ Branch!  LoopCode Type! THEN
    Display? IF
	level- nl .name-without nl bl cemit THEN
    DebugBranch cell+  Scan? IF
	dup BranchAddr? BEGIN ( addr1 addr2 f )
	WHILE ( addr1 addr2 )
		cell+ LeaveCode swap ! dup MoreBranchAddr? REPEAT 
    THEN ( addr1 ) \ perverse stack effect of MoreBranchAddr?
    cell+ ;
anton's avatar
anton committed
590

591 592 593 594 595
: c-loop# ( addr -- addr1 )
    Display? if
	dup @ c-. then
    c-loop cell+ ;

596
: c-do ( addr -- addr )
597
    Display? IF
598 599 600 601 602 603 604
	dup BranchAddr? IF ( addr addr1 )
	    cell+ dup @ LoopCode = IF ( addr addr2 )
		Disable swap !	nl .name-without level+
	    ELSE
		drop ." 2>r "  THEN ( addr )
	ELSE ( addr ) \ perverse stack effect of ?BranchAddr
	    ." 2>r "  THEN
605
    THEN ;
606

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

pazsan's avatar
pazsan committed
614
: c-exit ( addr1 -- addr2 )
615 616 617
    dup cell- CheckEnd IF ( addr1 )
	Display? IF
	    nlflag off S" ;" Com# .string THEN
pazsan's avatar
pazsan committed
618 619 620 621
	C-Stop on
    ELSE
	Display? IF S" EXIT " .struc THEN
    THEN
622
    Debug? IF drop THEN ( !! unbalanced! ) ; \ !!! cross-interacts with debugger !!!
anton's avatar
anton committed
623

624 625 626 627 628 629 630
: c-abort" ( c-addr -- c-addr-end )
    count 2dup + aligned -rot Display? IF (  c-addr-end c-addr1 u )
	S" ABORT" .struc
	'"' cemit bl cemit 0 .string
	'"' cemit bl cemit
    ELSE
	2drop THEN ;
anton's avatar
anton committed
631

632
[IFDEF] (compile)
633 634
: c-(compile) ( addr -- )
    Display? IF
635 636 637 638 639 640
	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
641

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

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

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

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

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

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

\ DOTABLE                                               15may93jaw

anton's avatar
anton committed
753 754 755 756 757 758 759 760 761 762
: 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
763
	2 pick swap xt= 0=
anton's avatar
anton committed
764 765 766 767 768 769
    WHILE
	    2 cells +
    REPEAT
    nip cell+ perform
    true
;
anton's avatar
anton committed
770 771

: BranchTo? ( a-addr -- a-addr )
772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788
    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
789 790

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

801
: c-init ( -- )
anton's avatar
anton committed
802 803 804 805 806 807 808
        0 YPos ! 0 XPos !
        0 Level ! nlflag off
        BranchTable BranchPointer !
        c-stop off
        Branches on ;

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

815 816
\ user words

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

888 889 890 891
\ user visible words

set-current

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

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

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

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

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

Bernd Paysan's avatar
Bernd Paysan committed
983
previous