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