1: \ SEE.FS highend SEE for ANSforth 16may93jaw
2:
3: \ Copyright (C) 1995,2000,2003,2004,2006,2007 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation, either version 3
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ 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/.
19:
20:
21: \ May be cross-compiled
22:
23: \ I'm sorry. This is really not "forthy" enough.
24:
25: \ Ideas: Level should be a stack
26:
27: require look.fs
28: require termsize.fs
29: require wordinfo.fs
30:
31: decimal
32:
33: \ Screen format words 16may93jaw
34:
35: VARIABLE C-Output 1 C-Output !
36: VARIABLE C-Formated 1 C-Formated !
37: VARIABLE C-Highlight 0 C-Highlight !
38: VARIABLE C-Clearline 0 C-Clearline !
39:
40: VARIABLE XPos
41: VARIABLE YPos
42: VARIABLE Level
43:
44: : Format C-Formated @ C-Output @ and
45: IF dup spaces XPos +! ELSE drop THEN ;
46:
47: : level+ 7 Level +!
48: Level @ XPos @ -
49: dup 0> IF Format ELSE drop THEN ;
50:
51: : level- -7 Level +! ;
52:
53: VARIABLE nlflag
54: VARIABLE uppercase \ structure words are in uppercase
55:
56: DEFER nlcount ' noop IS nlcount
57:
58: : nl nlflag on ;
59: : (nl) nlcount
60: XPos @ Level @ = IF EXIT THEN \ ?Exit
61: C-Formated @ IF
62: C-Output @
63: IF C-Clearline @ IF cols XPos @ - spaces
64: ELSE cr THEN
65: 1 YPos +! 0 XPos !
66: Level @ spaces
67: THEN Level @ XPos ! THEN ;
68:
69: : warp? ( len -- len )
70: nlflag @ IF (nl) nlflag off THEN
71: XPos @ over + cols u>= IF (nl) THEN ;
72:
73: : ctype ( adr len -- )
74: warp? dup XPos +! C-Output @
75: IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP
76: uppercase off ELSE type THEN
77: ELSE 2drop THEN ;
78:
79: : cemit 1 warp?
80: over bl = Level @ XPos @ = and
81: IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
82: THEN ;
83:
84: DEFER .string ( c-addr u n -- )
85:
86: [IFDEF] Green
87: VARIABLE Colors Colors on
88:
89: : (.string) ( c-addr u n -- )
90: over warp? drop
91: Colors @
92: IF C-Highlight @ ?dup
93: IF CT@ swap CT@ or
94: ELSE CT@
95: THEN
96: attr! ELSE drop THEN
97: ctype ct @ attr! ;
98: [ELSE]
99: : (.string) ( c-addr u n -- )
100: drop ctype ;
101: [THEN]
102:
103: ' (.string) IS .string
104:
105: : c-\type ( c-addr u -- )
106: \ type string in \-escaped form
107: begin
108: dup while
109: 2dup newline string-prefix? if
110: '\ cemit 'n cemit
111: newline nip /string
112: else
113: over c@
114: dup '" = over '\ = or if
115: '\ cemit cemit
116: else
117: dup bl 127 within if
118: cemit
119: else
120: base @ >r try
121: 8 base ! 0 <<# # # # '\ hold #> ctype #>> 0
122: restore
123: r@ base !
124: endtry
125: rdrop throw
126: endif
127: endif
128: 1 /string
129: endif
130: repeat
131: 2drop ;
132:
133: : .struc
134: uppercase on Str# .string ;
135:
136: \ CODES (Branchtypes) 15may93jaw
137:
138: 21 CONSTANT RepeatCode
139: 22 CONSTANT AgainCode
140: 23 CONSTANT UntilCode
141: \ 09 CONSTANT WhileCode
142: 10 CONSTANT ElseCode
143: 11 CONSTANT AheadCode
144: 13 CONSTANT WhileCode2
145: 14 CONSTANT Disable
146: 15 CONSTANT LeaveCode
147:
148:
149: \ FORMAT WORDS 13jun93jaw
150:
151: VARIABLE C-Stop
152: VARIABLE Branches
153:
154: VARIABLE BranchPointer \ point to the end of branch table
155: VARIABLE SearchPointer
156:
157: \ The branchtable consists of three entrys:
158: \ address of branch , branch destination , branch type
159:
160: CREATE BranchTable 128 cells allot
161: here 3 cells -
162: ACONSTANT MaxTable
163:
164: : FirstBranch BranchTable cell+ SearchPointer ! ;
165:
166: : (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
167: \ searches a branch with destination a-addr1
168: \ a-addr1: branch destination
169: \ a-addr2: pointer in branch table
170: SearchPointer @
171: BEGIN dup BranchPointer @ u<
172: WHILE
173: dup @ 2 pick <>
174: WHILE 3 cells +
175: REPEAT
176: nip dup 3 cells + SearchPointer ! true
177: ELSE
178: 2drop false
179: THEN ;
180:
181: : BranchAddr?
182: FirstBranch (BranchAddr?) ;
183:
184: ' (BranchAddr?) ALIAS MoreBranchAddr?
185:
186: : CheckEnd ( a-addr -- true | false )
187: BranchTable cell+
188: BEGIN dup BranchPointer @ u<
189: WHILE
190: dup @ 2 pick u<=
191: WHILE 3 cells +
192: REPEAT
193: 2drop false
194: ELSE
195: 2drop true
196: THEN ;
197:
198: : MyBranch ( a-addr -- a-addr a-addr2 )
199: \ finds branch table entry for branch at a-addr
200: dup @
201: BranchAddr?
202: BEGIN
203: WHILE 1 cells - @
204: over <>
205: WHILE dup @
206: MoreBranchAddr?
207: REPEAT
208: SearchPointer @ 3 cells -
209: ELSE true ABORT" SEE: Table failure"
210: THEN ;
211:
212: \
213: \ addrw addrt
214: \ BEGIN ... WHILE ... AGAIN ... THEN
215: \ ^ ! ! ^
216: \ ----------+--------+ !
217: \ ! !
218: \ +-------------------+
219: \
220: \
221:
222: : CheckWhile ( a-addrw a-addrt -- true | false )
223: BranchTable
224: BEGIN dup BranchPointer @ u<
225: WHILE dup @ 3 pick u>
226: over @ 3 pick u< and
227: IF dup cell+ @ 3 pick u<
228: IF 2drop drop true EXIT THEN
229: THEN
230: 3 cells +
231: REPEAT
232: 2drop drop false ;
233:
234: : ,Branch ( a-addr -- )
235: BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
236: !
237: 1 cells BranchPointer +! ;
238:
239: : Type! ( u -- )
240: BranchPointer @ 1 cells - ! ;
241:
242: : Branch! ( a-addr rel -- a-addr )
243: over ,Branch ,Branch 0 ,Branch ;
244: \ over + over ,Branch ,Branch 0 ,Branch ;
245:
246: \ DEFER CheckUntil
247: VARIABLE NoOutput
248: VARIABLE C-Pass
249:
250: 0 CONSTANT ScanMode
251: 1 CONSTANT DisplayMode
252: 2 CONSTANT DebugMode
253:
254: : Scan? ( -- flag ) C-Pass @ 0= ;
255: : Display? ( -- flag ) C-Pass @ 1 = ;
256: : Debug? ( -- flag ) C-Pass @ 2 = ;
257:
258: : back? ( addr target -- addr flag )
259: over u< ;
260:
261: : .word ( addr x -- addr )
262: \ print x as a word if possible
263: dup look 0= IF
264: drop dup threaded>name dup 0= if
265: drop over 1 cells - @ dup body> look
266: IF
267: nip nip dup ." <" name>string rot wordinfo .string ." > "
268: ELSE
269: 2drop ." <" 0 .r ." > "
270: THEN
271: EXIT
272: then
273: THEN
274: nip dup cell+ @ immediate-mask and
275: IF
276: bl cemit ." POSTPONE "
277: THEN
278: dup name>string rot wordinfo .string
279: ;
280:
281: : c-call ( addr1 -- addr2 )
282: Display? IF
283: dup @ body> .word bl cemit
284: THEN
285: cell+ ;
286:
287: : c-callxt ( addr1 -- addr2 )
288: Display? IF
289: dup @ .word bl cemit
290: THEN
291: cell+ ;
292:
293: \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
294: \ here over - 2constant doers
295:
296: : c-lit ( addr1 -- addr2 )
297: Display? IF
298: dup @ dup body> dup cfaligned over = swap in-dictionary? and if
299: ( addr1 addr1@ )
300: dup body> @ dovar: = if
301: drop c-call EXIT
302: endif
303: endif
304: \ !! test for cfa here, and print "['] ..."
305: dup abs 0 <# #S rot sign #> 0 .string bl cemit
306: endif
307: cell+ ;
308:
309: : c-lit+ ( addr1 -- addr2 )
310: Display? if
311: dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
312: s" + " 0 .string
313: endif
314: cell+ ;
315:
316: : .name-without ( addr -- addr )
317: \ !! the stack effect cannot be correct
318: \ prints a name without a() e.g. a(+LOOP) or (s")
319: dup 1 cells - @ threaded>name dup IF
320: name>string over c@ 'a = IF
321: 1 /string
322: THEN
323: over c@ '( = IF
324: 1 /string
325: THEN
326: 2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
327: THEN ;
328:
329: [ifdef] (s")
330: : c-c"
331: Display? IF nl .name-without THEN
332: count 2dup + aligned -rot
333: Display?
334: IF bl cemit 0 .string
335: [char] " cemit bl cemit
336: ELSE 2drop
337: THEN ;
338: [endif]
339:
340: : c-string? ( addr1 -- addr2 f )
341: \ f is true if a string was found and decompiled.
342: \ if f is false, addr2=addr1
343: \ recognizes the following patterns:
344: \ c": ahead X: len string then lit X
345: \ flit: ahead X: float then lit X f@
346: \ s\": ahead X: string then lit X lit len
347: \ .\": ahead X: string then lit X lit len type
348: \ !! not recognized anywhere:
349: \ abort": if ahead X: len string then lit X c(abort") then
350: dup @ back? if false exit endif
351: dup @ >r
352: r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif
353: r@ cell+ @ over cell+ <> if rdrop false exit endif
354: \ we have at least C"
355: r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if
356: drop r@ 3 cells + @ over cell+ + aligned r@ = if
357: \ we have at least s"
358: r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded =
359: r@ 5 cells + @ ['] type >body = and if
360: 6 s\" .\\\" "
361: else
362: 4 s\" s\\\" "
363: endif
364: \ !! make newline if string too long?
365: display? if
366: 0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit
367: else
368: 2drop
369: endif
370: nip cells r> + true exit
371: endif
372: endif
373: ['] f@ xt>threaded = if
374: display? if
375: r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit
376: endif
377: drop r> 3 cells + true exit
378: endif
379: \ !! check if count matches space?
380: display? if
381: s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit
382: endif
383: drop r> 2 cells + true ;
384:
385: : Forward? ( a-addr true | false -- a-addr true | false )
386: \ a-addr is pointer into branch table
387: \ returns true when jump is a forward jump
388: IF
389: dup dup @ swap 1 cells - @ u> IF
390: true
391: ELSE
392: drop false
393: THEN
394: \ only if forward jump
395: ELSE
396: false
397: THEN ;
398:
399: : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
400: IF BEGIN 2dup
401: 1 cells - @ swap @
402: u<=
403: WHILE drop dup cell+
404: MoreBranchAddr? 0=
405: UNTIL false
406: ELSE true
407: THEN
408: ELSE false
409: THEN ;
410:
411: : c-branch ( addr1 -- addr2 )
412: c-string? ?exit
413: Scan?
414: IF dup @ Branch!
415: dup @ back?
416: IF \ might be: AGAIN, REPEAT
417: dup cell+ BranchAddr? Forward?
418: RepeatCheck
419: IF RepeatCode Type!
420: cell+ Disable swap !
421: ELSE AgainCode Type!
422: THEN
423: ELSE dup cell+ BranchAddr? Forward?
424: IF ElseCode Type! drop
425: ELSE AheadCode Type!
426: THEN
427: THEN
428: THEN
429: Display?
430: IF
431: dup @ back?
432: IF \ might be: AGAIN, REPEAT
433: level- nl
434: dup cell+ BranchAddr? Forward?
435: RepeatCheck
436: IF drop S" REPEAT " .struc nl
437: ELSE S" AGAIN " .struc nl
438: THEN
439: ELSE MyBranch cell+ @ LeaveCode =
440: IF S" LEAVE " .struc
441: ELSE
442: dup cell+ BranchAddr? Forward?
443: IF dup cell+ @ WhileCode2 =
444: IF nl S" ELSE" .struc level+
445: ELSE level- nl S" ELSE" .struc level+ THEN
446: cell+ Disable swap !
447: ELSE S" AHEAD" .struc level+
448: THEN
449: THEN
450: THEN
451: THEN
452: Debug?
453: IF @ \ !!! cross-interacts with debugger !!!
454: ELSE cell+
455: THEN ;
456:
457: : DebugBranch
458: Debug?
459: IF dup @ swap THEN ; \ return 2 different addresses
460:
461: : c-?branch
462: Scan?
463: IF dup @ Branch!
464: dup @ Back?
465: IF UntilCode Type! THEN
466: THEN
467: Display?
468: IF dup @ Back?
469: IF level- nl S" UNTIL " .struc nl
470: ELSE dup dup @ over +
471: CheckWhile
472: IF MyBranch
473: cell+ dup @ 0=
474: IF WhileCode2 swap !
475: ELSE drop THEN
476: level- nl
477: S" WHILE " .struc
478: level+
479: ELSE MyBranch cell+ @ LeaveCode =
480: IF s" 0= ?LEAVE " .struc
481: ELSE nl S" IF " .struc level+
482: THEN
483: THEN
484: THEN
485: THEN
486: DebugBranch
487: cell+ ;
488:
489: : c-for
490: Display? IF nl S" FOR" .struc level+ THEN ;
491:
492: : c-loop
493: Display? IF level- nl .name-without nl bl cemit THEN
494: DebugBranch cell+
495: Scan?
496: IF dup BranchAddr?
497: BEGIN WHILE cell+ LeaveCode swap !
498: dup MoreBranchAddr?
499: REPEAT
500: THEN
501: cell+ ;
502:
503: : c-do
504: Display? IF nl .name-without level+ THEN ;
505:
506: : c-?do ( addr1 -- addr2 )
507: Display? IF
508: nl .name-without level+
509: THEN
510: DebugBranch cell+ ;
511:
512: : c-exit ( addr1 -- addr2 )
513: dup 1 cells -
514: CheckEnd
515: IF
516: Display? IF nlflag off S" ;" Com# .string THEN
517: C-Stop on
518: ELSE
519: Display? IF S" EXIT " .struc THEN
520: THEN
521: Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!!
522:
523: : c-abort"
524: count 2dup + aligned -rot
525: Display?
526: IF S" ABORT" .struc
527: [char] " cemit bl cemit 0 .string
528: [char] " cemit bl cemit
529: ELSE 2drop
530: THEN ;
531:
532: [IFDEF] (does>)
533: : c-does> \ end of create part
534: Display? IF S" DOES> " Com# .string THEN
535: maxaligned /does-handler + ;
536: [THEN]
537:
538: [IFDEF] (compile)
539: : c-(compile)
540: Display?
541: IF
542: s" POSTPONE " Com# .string
543: dup @ look 0= ABORT" SEE: No valid XT"
544: name>string 0 .string bl cemit
545: THEN
546: cell+ ;
547: [THEN]
548:
549: CREATE C-Table
550: ' lit A, ' c-lit A,
551: ' does-exec A, ' c-callxt A,
552: ' lit@ A, ' c-call A,
553: [IFDEF] call ' call A, ' c-call A, [THEN]
554: \ ' useraddr A, ....
555: ' lit-perform A, ' c-call A,
556: ' lit+ A, ' c-lit+ A,
557: [IFDEF] (s") ' (s") A, ' c-c" A, [THEN]
558: [IFDEF] (.") ' (.") A, ' c-c" A, [THEN]
559: [IFDEF] "lit ' "lit A, ' c-c" A, [THEN]
560: [IFDEF] (c") ' (c") A, ' c-c" A, [THEN]
561: ' (do) A, ' c-do A,
562: [IFDEF] (+do) ' (+do) A, ' c-?do A, [THEN]
563: [IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN]
564: [IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN]
565: [IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN]
566: ' (?do) A, ' c-?do A,
567: ' (for) A, ' c-for A,
568: ' ?branch A, ' c-?branch A,
569: ' branch A, ' c-branch A,
570: ' (loop) A, ' c-loop A,
571: ' (+loop) A, ' c-loop A,
572: [IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN]
573: [IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]
574: ' (next) A, ' c-loop A,
575: ' ;s A, ' c-exit A,
576: [IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN]
577: \ only defined if compiler is loaded
578: [IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN]
579: [IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN]
580: 0 , here 0 ,
581:
582: avariable c-extender
583: c-extender !
584:
585: \ DOTABLE 15may93jaw
586:
587: : DoTable ( ca/cfa -- flag )
588: decompile-prim C-Table BEGIN ( cfa table-entry )
589: dup @ dup 0= IF
590: drop cell+ @ dup IF ( next table!)
591: dup @
592: ELSE ( end!)
593: 2drop false EXIT
594: THEN
595: THEN
596: \ jump over to extender, if any 26jan97jaw
597: xt>threaded 2 pick <>
598: WHILE
599: 2 cells +
600: REPEAT
601: nip cell+ perform
602: true
603: ;
604:
605: : BranchTo? ( a-addr -- a-addr )
606: Display? IF dup BranchAddr?
607: IF
608: BEGIN cell+ @ dup 20 u>
609: IF drop nl S" BEGIN " .struc level+
610: ELSE
611: dup Disable <> over LeaveCode <> and
612: IF WhileCode2 =
613: IF nl S" THEN " .struc nl ELSE
614: level- nl S" THEN " .struc nl THEN
615: ELSE drop THEN
616: THEN
617: dup MoreBranchAddr? 0=
618: UNTIL
619: THEN
620: THEN ;
621:
622: : analyse ( a-addr1 -- a-addr2 )
623: Branches @ IF BranchTo? THEN
624: dup cell+ swap @
625: dup >r DoTable r> swap IF drop EXIT THEN
626: Display?
627: IF
628: .word bl cemit
629: ELSE
630: drop
631: THEN ;
632:
633: : c-init
634: 0 YPos ! 0 XPos !
635: 0 Level ! nlflag off
636: BranchTable BranchPointer !
637: c-stop off
638: Branches on ;
639:
640: : makepass ( a-addr -- )
641: c-stop off
642: BEGIN
643: analyse
644: c-stop @
645: UNTIL drop ;
646:
647: Defer xt-see-xt ( xt -- )
648: \ this one is just a forward declaration for indirect recursion
649:
650: : .defname ( xt c-addr u -- )
651: rot look
652: if ( c-addr u nfa )
653: -rot type space .name
654: else
655: drop ." noname " type
656: then
657: space ;
658:
659: Defer discode ( addr u -- ) \ gforth
660: \G hook for the disassembler: disassemble code at addr of length u
661: ' dump IS discode
662:
663: : next-head ( addr1 -- addr2 ) \ gforth
664: \G find the next header starting after addr1, up to here (unreliable).
665: here swap u+do
666: i head? -2 and if
667: i unloop exit
668: then
669: cell +loop
670: here ;
671:
672: [ifundef] umin \ !! bootstrapping help
673: : umin ( u1 u2 -- u )
674: 2dup u>
675: if
676: swap
677: then
678: drop ;
679: [then]
680:
681: : next-prim ( addr1 -- addr2 ) \ gforth
682: \G find the next primitive after addr1 (unreliable)
683: 1+ >r -1 primstart
684: begin ( umin head R: boundary )
685: @ dup
686: while
687: tuck name>int >code-address ( head1 umin ca R: boundary )
688: r@ - umin
689: swap
690: repeat
691: drop dup r@ negate u>=
692: \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
693: if ( umin R: boundary ) \ no primitive found behind -> use a default length
694: drop 31
695: then
696: r> + ;
697:
698: : seecode ( xt -- )
699: dup s" Code" .defname
700: >code-address
701: dup in-dictionary? \ user-defined code word?
702: if
703: dup next-head
704: else
705: dup next-prim
706: then
707: over - discode
708: ." end-code" cr ;
709: : seevar ( xt -- )
710: s" Variable" .defname cr ;
711: : seeuser ( xt -- )
712: s" User" .defname cr ;
713: : seecon ( xt -- )
714: dup >body ?
715: s" Constant" .defname cr ;
716: : seevalue ( xt -- )
717: dup >body ?
718: s" Value" .defname cr ;
719: : seedefer ( xt -- )
720: dup >body @ xt-see-xt cr
721: dup s" Defer" .defname cr
722: >name ?dup-if
723: ." IS " .name cr
724: else
725: ." latestxt >body !"
726: then ;
727: : see-threaded ( addr -- )
728: C-Pass @ DebugMode = IF
729: ScanMode c-pass !
730: EXIT
731: THEN
732: ScanMode c-pass ! dup makepass
733: DisplayMode c-pass ! makepass ;
734: : seedoes ( xt -- )
735: dup s" create" .defname cr
736: S" DOES> " Com# .string XPos @ Level !
737: >does-code see-threaded ;
738: : seecol ( xt -- )
739: dup s" :" .defname nl
740: 2 Level !
741: >body see-threaded ;
742: : seefield ( xt -- )
743: dup >body ." 0 " ? ." 0 0 "
744: s" Field" .defname cr ;
745:
746: : xt-see ( xt -- ) \ gforth
747: \G Decompile the definition represented by @i{xt}.
748: cr c-init
749: dup >does-code
750: if
751: seedoes EXIT
752: then
753: dup xtprim?
754: if
755: seecode EXIT
756: then
757: dup >code-address
758: CASE
759: docon: of seecon endof
760: [IFDEF] dovalue:
761: dovalue: of seevalue endof
762: [THEN]
763: docol: of seecol endof
764: dovar: of seevar endof
765: [IFDEF] douser:
766: douser: of seeuser endof
767: [THEN]
768: [IFDEF] dodefer:
769: dodefer: of seedefer endof
770: [THEN]
771: [IFDEF] dofield:
772: dofield: of seefield endof
773: [THEN]
774: over of seecode endof \ direct threaded code words
775: over >body of seecode endof \ indirect threaded code words
776: 2drop abort" unknown word type"
777: ENDCASE ;
778:
779: : (xt-see-xt) ( xt -- )
780: xt-see cr ." latestxt" ;
781: ' (xt-see-xt) is xt-see-xt
782:
783: : (.immediate) ( xt -- )
784: ['] execute = if
785: ." immediate"
786: then ;
787:
788: : name-see ( nfa -- )
789: dup name>int >r
790: dup name>comp
791: over r@ =
792: if \ normal or immediate word
793: swap xt-see (.immediate)
794: else
795: r@ ['] ticking-compile-only-error =
796: if \ compile-only word
797: swap xt-see (.immediate) ." compile-only"
798: else \ interpret/compile word
799: r@ xt-see-xt cr
800: swap xt-see-xt cr
801: ." interpret/compile: " over .name drop
802: then
803: then
804: rdrop drop ;
805:
806: : see ( "<spaces>name" -- ) \ tools
807: \G Locate @var{name} using the current search order. Display the
808: \G definition of @var{name}. Since this is achieved by decompiling
809: \G the definition, the formatting is mechanised and some source
810: \G information (comments, interpreted sequences within definitions
811: \G etc.) is lost.
812: name find-name dup 0=
813: IF
814: drop -&13 throw
815: THEN
816: name-see ;
817:
818:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>