File: see.fs

package info (click to toggle)
gforth 0.7.3+dfsg-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 5,992 kB
  • sloc: ansic: 8,535; sh: 3,666; lisp: 1,778; makefile: 1,019; yacc: 186; sed: 141; lex: 102; awk: 21
file content (818 lines) | stat: -rw-r--r-- 20,992 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
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
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
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
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
\ SEE.FS       highend SEE for ANSforth                16may93jaw

\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc.

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.


\ May be cross-compiled

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

\ Ideas:        Level should be a stack

require look.fs
require termsize.fs
require wordinfo.fs

decimal

\ 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
VARIABLE uppercase	\ structure words are in uppercase

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 ;

: warp?         ( len -- len )
                nlflag @ IF (nl) nlflag off THEN
                XPos @ over + cols u>= IF (nl) THEN ;

: ctype         ( adr len -- )
                warp? dup XPos +! C-Output @ 
		IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP
				  uppercase off ELSE type THEN
		ELSE 2drop THEN ;

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

DEFER .string ( c-addr u n -- )

[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

: 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        
	uppercase on Str# .string ;

\ CODES (Branchtypes)                                    15may93jaw

21 CONSTANT RepeatCode
22 CONSTANT AgainCode
23 CONSTANT UntilCode
\ 09 CONSTANT WhileCode
10 CONSTANT ElseCode
11 CONSTANT AheadCode
13 CONSTANT WhileCode2
14 CONSTANT Disable
15 CONSTANT LeaveCode


\ FORMAT WORDS                                          13jun93jaw

VARIABLE C-Stop
VARIABLE Branches

VARIABLE BranchPointer	\ point to the end of branch table
VARIABLE SearchPointer

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

CREATE BranchTable 128 cells allot
here 3 cells -
ACONSTANT MaxTable

: FirstBranch BranchTable cell+ SearchPointer ! ;

: (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
\ searches a branch with destination a-addr1
\ a-addr1: branch destination
\ a-addr2: pointer in branch table
        SearchPointer @
        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 ;

: MyBranch      ( a-addr -- a-addr a-addr2 )
\ finds branch table entry for branch at a-addr
                dup @
                BranchAddr?
                BEGIN
                WHILE 1 cells - @
                      over <>
                WHILE dup @
                      MoreBranchAddr?
                REPEAT
                SearchPointer @ 3 cells -
                ELSE    true ABORT" SEE: Table failure"
                THEN ;

\
\                 addrw               addrt
\       BEGIN ... WHILE ... AGAIN ... THEN
\         ^         !        !          ^
\         ----------+--------+          !
\                   !                   !
\                   +-------------------+
\
\

: CheckWhile ( a-addrw a-addrt -- true | false )
        BranchTable
        BEGIN   dup BranchPointer @ u<
        WHILE   dup @ 3 pick u>
                over @ 3 pick u< and
                IF dup cell+ @ 3 pick u<
                        IF 2drop drop true EXIT THEN
                THEN
                3 cells +
        REPEAT
        2drop drop false ;

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

: Type!   ( u -- )
        BranchPointer @ 1 cells - ! ;

: Branch! ( a-addr rel -- a-addr )
    over ,Branch ,Branch 0 ,Branch ;
\        over + over ,Branch ,Branch 0 ,Branch ;

\ 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 = ;

: back? ( addr target -- addr flag )
    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-callxt ( addr1 -- addr2 )
    Display? IF
	dup @ .word bl cemit
    THEN
    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 )
    \ !! the stack effect cannot be correct
    \ prints a name without a() e.g. a(+LOOP) or (s")
    dup 1 cells - @ threaded>name dup IF
	name>string over c@ 'a = IF
	    1 /string
	THEN
	 over c@ '( = IF
	    1 /string
	THEN
	2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop 
    THEN ;

[ifdef] (s")
: c-c"
	Display? IF nl .name-without THEN
        count 2dup + aligned -rot
        Display?
        IF      bl cemit 0 .string
                [char] " cemit bl cemit
        ELSE    2drop
        THEN ;
[endif]

: c-string? ( addr1 -- addr2 f )
    \ f is true if a string was found and decompiled.
    \ if f is false, addr2=addr1
    \ recognizes the following patterns:
    \ c":     ahead X: len string then lit X
    \ flit:   ahead X: float      then lit X f@
    \ s\":    ahead X: string     then lit X lit len
    \ .\":    ahead X: string     then lit X lit len type
    \ !! not recognized anywhere:
    \ abort": if ahead X: len string then lit X c(abort") then
    dup @ back? if false exit endif
    dup @ >r
    r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif
    r@ cell+ @ over cell+ <> if rdrop false exit endif
    \ we have at least C"
    r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if
	drop r@ 3 cells + @ over cell+ + aligned r@ = if
	    \ we have at least s"
	    r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded =
	    r@ 5 cells + @ ['] type >body = and if
		6 s\" .\\\" "
	    else
		4 s\" s\\\" "
	    endif
	    \ !! make newline if string too long?
	    display? if
		0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit
	    else
		2drop
	    endif
	    nip cells r> + true exit
	endif
    endif
    ['] f@ xt>threaded = if
	display? if
	    r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit
	endif
	drop r> 3 cells + true exit
    endif
    \ !! check if count matches space?
    display? if
	s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit
    endif
    drop r> 2 cells + true ;

: Forward? ( a-addr true | false -- a-addr true | false )
    \ a-addr is pointer into branch table
    \ returns true when jump is a forward jump
    IF
	dup dup @ swap 1 cells - @ u> IF
	    true
	ELSE
	    drop false
	THEN
	\ only if forward jump
    ELSE
	false
    THEN ;

: RepeatCheck ( a-addr1 a-addr2 true | false -- false )
        IF  BEGIN  2dup
                   1 cells - @ swap @
                   u<=
            WHILE  drop dup cell+
                   MoreBranchAddr? 0=
            UNTIL  false
            ELSE   true
            THEN
        ELSE false
        THEN ;

: c-branch ( addr1 -- addr2 )
    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
        Debug?
        IF      dup @ swap THEN ; \ return 2 different addresses

: c-?branch
        Scan?
        IF      dup @ Branch!
                dup @ Back?
                IF      UntilCode Type! THEN
        THEN
        Display?
        IF      dup @ Back?
                IF      level- nl S" UNTIL " .struc nl
                ELSE    dup    dup @ over +
                        CheckWhile
                        IF      MyBranch
                                cell+ dup @ 0=
                                         IF WhileCode2 swap !
                                         ELSE drop THEN
                                level- nl
                                S" WHILE " .struc
                                level+
                        ELSE    MyBranch cell+ @ LeaveCode =
				IF   s" 0= ?LEAVE " .struc
				ELSE nl S" IF " .struc level+
				THEN
                        THEN
                THEN
        THEN
        DebugBranch
        cell+ ;

: c-for
        Display? IF nl S" FOR" .struc level+ THEN ;

: c-loop
        Display? IF level- nl .name-without nl bl cemit THEN
        DebugBranch cell+ 
	Scan? 
	IF 	dup BranchAddr? 
		BEGIN   WHILE cell+ LeaveCode swap !
			dup MoreBranchAddr?
		REPEAT
	THEN
	cell+ ;

: c-do
        Display? IF nl .name-without level+ THEN ;

: c-?do ( addr1 -- addr2 )
    Display? IF
	nl .name-without level+
    THEN
    DebugBranch cell+ ;

: c-exit ( addr1 -- addr2 )
    dup 1 cells -
    CheckEnd
    IF
	Display? IF nlflag off S" ;" Com# .string THEN
	C-Stop on
    ELSE
	Display? IF S" EXIT " .struc THEN
    THEN
    Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!!

: c-abort"
        count 2dup + aligned -rot
        Display?
        IF      S" ABORT" .struc
                [char] " cemit bl cemit 0 .string
                [char] " cemit bl cemit
        ELSE    2drop
        THEN ;

[IFDEF] (does>)
: c-does>               \ end of create part
        Display? IF S" DOES> " Com# .string THEN
	maxaligned /does-handler + ;
[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
	        ' lit A,            ' c-lit A,
		' does-exec A,	    ' c-callxt A,
		' lit@ A,	    ' c-call 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]
        	' (do) A,           ' c-do A,
[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,
        	' (for) A,          ' c-for A,
        	' ?branch A,        ' c-?branch A,
        	' branch A,         ' c-branch A,
        	' (loop) A,         ' c-loop A,
        	' (+loop) A,        ' c-loop A,
[IFDEF] (s+loop) ' (s+loop) A,      ' c-loop A, [THEN]
[IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
        	' (next) A,         ' c-loop A,
        	' ;s A,             ' c-exit A,
[IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]
\ only defined if compiler is loaded
[IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
[IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
        	0 ,		here 0 ,

avariable c-extender
c-extender !

\ DOTABLE                                               15may93jaw

: 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
	xt>threaded 2 pick <>
    WHILE
	    2 cells +
    REPEAT
    nip cell+ perform
    true
;

: BranchTo? ( a-addr -- a-addr )
        Display?  IF    dup BranchAddr?
                        IF
				BEGIN cell+ @ dup 20 u>
                                IF drop nl S" BEGIN " .struc level+
                                ELSE
                                  dup Disable <> over LeaveCode <> 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 ;

: analyse ( a-addr1 -- a-addr2 )
    Branches @ IF BranchTo? THEN
    dup cell+ swap @
    dup >r DoTable r> swap IF drop EXIT THEN
    Display?
    IF
	.word bl cemit
    ELSE
	drop
    THEN ;

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

: makepass ( a-addr -- )
    c-stop off
    BEGIN
	analyse
	c-stop @
    UNTIL drop ;

Defer xt-see-xt ( xt -- )
\ this one is just a forward declaration for indirect recursion

: .defname ( xt c-addr u -- )
    rot look
    if ( c-addr u nfa )
	-rot type space .name
    else
	drop ." noname " type
    then
    space ;

Defer discode ( addr u -- ) \ gforth
\G hook for the disassembler: disassemble code at addr of length u
' dump IS discode

: next-head ( addr1 -- addr2 ) \ gforth
    \G find the next header starting after addr1, up to here (unreliable).
    here swap u+do
	i head? -2 and if
	    i unloop exit
	then
    cell +loop
    here ;

[ifundef] umin \ !! bootstrapping help
: umin ( u1 u2 -- u )
    2dup u>
    if
	swap
    then
    drop ;
[then]

: next-prim ( addr1 -- addr2 ) \ gforth
    \G find the next primitive after addr1 (unreliable)
    1+ >r -1 primstart
    begin ( umin head R: boundary )
	@ dup
    while
	tuck name>int >code-address ( head1 umin ca R: boundary )
	r@ - umin
	swap
    repeat
    drop dup r@ negate u>=
    \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
    if ( umin R: boundary ) \ no primitive found behind -> use a default length
	drop 31
    then
    r> + ;

: seecode ( xt -- )
    dup s" Code" .defname
    >code-address
    dup in-dictionary? \ user-defined code word?
    if
	dup next-head
    else
	dup next-prim
    then
    over - discode
    ." end-code" cr ;
: 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
    >name ?dup-if
	." IS " .name cr
    else
	." latestxt >body !"
    then ;
: see-threaded ( addr -- )
    C-Pass @ DebugMode = IF
	ScanMode c-pass !
	EXIT
    THEN
    ScanMode c-pass ! dup makepass
    DisplayMode c-pass ! makepass ;
: seedoes ( xt -- )
    dup s" create" .defname cr
    S" DOES> " Com# .string XPos @ Level !
    >does-code see-threaded ;
: seecol ( xt -- )
    dup s" :" .defname nl
    2 Level !
    >body see-threaded ;
: seefield ( xt -- )
    dup >body ." 0 " ? ." 0 0 "
    s" Field" .defname cr ;

: xt-see ( xt -- ) \ gforth
    \G Decompile the definition represented by @i{xt}.
    cr c-init
    dup >does-code
    if
	seedoes EXIT
    then
    dup xtprim?
    if
	seecode EXIT
    then
    dup >code-address
    CASE
	docon: of seecon endof
[IFDEF] dovalue:
        dovalue: of seevalue endof
[THEN]
	docol: of seecol endof
	dovar: of seevar endof
[IFDEF] douser:
	douser: of seeuser endof
[THEN]
[IFDEF] dodefer:
	dodefer: of seedefer endof
[THEN]
[IFDEF] dofield:
	dofield: of seefield endof
[THEN]
	over       of seecode endof \ direct threaded code words
	over >body of seecode endof \ indirect threaded code words
	2drop abort" unknown word type"
    ENDCASE ;

: (xt-see-xt) ( xt -- )
    xt-see cr ." latestxt" ;
' (xt-see-xt) is xt-see-xt

: (.immediate) ( xt -- )
    ['] execute = if
	."  immediate"
    then ;

: name-see ( nfa -- )
    dup name>int >r
    dup name>comp 
    over r@ =
    if \ normal or immediate word
	swap xt-see (.immediate)
    else
	r@ ['] ticking-compile-only-error =
	if \ compile-only word
	    swap xt-see (.immediate) ."  compile-only"
	else \ interpret/compile word
	    r@ xt-see-xt cr
	    swap xt-see-xt cr
	    ." interpret/compile: " over .name drop
	then
    then
    rdrop drop ;

: see ( "<spaces>name" -- ) \ tools
    \G Locate @var{name} using the current search order. Display the
    \G definition of @var{name}. Since this is achieved by decompiling
    \G the definition, the formatting is mechanised and some source
    \G information (comments, interpreted sequences within definitions
    \G etc.) is lost.
    name find-name dup 0=
    IF
	drop -&13 throw
    THEN
    name-see ;