File:
[gforth] /
gforth /
see.fs
Revision
1.52:
download - view:
text,
annotated -
select for diffs
Sat Mar 22 10:04:07 2003 UTC (21 years, 1 month ago) by
anton
Branches:
MAIN
CVS tags:
v0-6-2,
HEAD
added LATEST, replaced uses of LAST @ with uses of LATEST
renamed LASTXT to LATESTXT, and changed the uses
made >NAME the primary name for >HEAD
documentation changes
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 dup @ +
458: ELSE cell+
459: THEN ;
460:
461: : DebugBranch
462: Debug?
463: IF dup @ over + 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 bl cemit nl 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 dup 1 cells -
517: CheckEnd
518: IF Display? IF nlflag off S" ;" Com# .string THEN
519: C-Stop on
520: ELSE Display? IF S" EXIT " .struc THEN
521: THEN
522: Debug? IF drop THEN ;
523:
524: : c-abort"
525: count 2dup + aligned -rot
526: Display?
527: IF S" ABORT" .struc
528: [char] " cemit bl cemit 0 .string
529: [char] " cemit bl cemit
530: ELSE 2drop
531: THEN ;
532:
533: [IFDEF] (does>)
534: : c-does> \ end of create part
535: Display? IF S" DOES> " Com# .string THEN
536: maxaligned /does-handler + ;
537: [THEN]
538:
539: [IFDEF] (compile)
540: : c-(compile)
541: Display?
542: IF
543: s" POSTPONE " Com# .string
544: dup @ look 0= ABORT" SEE: No valid XT"
545: name>string 0 .string bl cemit
546: THEN
547: cell+ ;
548: [THEN]
549:
550: CREATE C-Table
551: ' lit A, ' c-lit A,
552: ' does-exec A, ' c-callxt A,
553: ' lit@ A, ' c-call A,
554: [IFDEF] call ' call A, ' c-call A, [THEN]
555: \ ' useraddr A, ....
556: ' lit-perform A, ' c-call A,
557: ' lit+ A, ' c-lit+ A,
558: [IFDEF] (s") ' (s") A, ' c-c" A, [THEN]
559: [IFDEF] (.") ' (.") A, ' c-c" A, [THEN]
560: [IFDEF] "lit ' "lit A, ' c-c" A, [THEN]
561: [IFDEF] (c") ' (c") A, ' c-c" A, [THEN]
562: ' (do) A, ' c-do A,
563: [IFDEF] (+do) ' (+do) A, ' c-?do A, [THEN]
564: [IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN]
565: [IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN]
566: [IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN]
567: ' (?do) A, ' c-?do A,
568: ' (for) A, ' c-for A,
569: ' ?branch A, ' c-?branch A,
570: ' branch A, ' c-branch A,
571: ' (loop) A, ' c-loop A,
572: ' (+loop) A, ' c-loop A,
573: [IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN]
574: [IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]
575: ' (next) A, ' c-loop A,
576: ' ;s A, ' c-exit A,
577: [IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN]
578: \ only defined if compiler is loaded
579: [IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN]
580: [IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN]
581: 0 , here 0 ,
582:
583: avariable c-extender
584: c-extender !
585:
586: \ DOTABLE 15may93jaw
587:
588: : DoTable ( ca/cfa -- flag )
589: decompile-prim C-Table BEGIN ( cfa table-entry )
590: dup @ dup 0= IF
591: drop cell+ @ dup IF ( next table!)
592: dup @
593: ELSE ( end!)
594: 2drop false EXIT
595: THEN
596: THEN
597: \ jump over to extender, if any 26jan97jaw
598: xt>threaded 2 pick <>
599: WHILE
600: 2 cells +
601: REPEAT
602: nip cell+ perform
603: true
604: ;
605:
606: : BranchTo? ( a-addr -- a-addr )
607: Display? IF dup BranchAddr?
608: IF
609: BEGIN cell+ @ dup 20 u>
610: IF drop nl S" BEGIN " .struc level+
611: ELSE
612: dup Disable <> over LeaveCode <> and
613: IF WhileCode2 =
614: IF nl S" THEN " .struc nl ELSE
615: level- nl S" THEN " .struc nl THEN
616: ELSE drop THEN
617: THEN
618: dup MoreBranchAddr? 0=
619: UNTIL
620: THEN
621: THEN ;
622:
623: : analyse ( a-addr1 -- a-addr2 )
624: Branches @ IF BranchTo? THEN
625: dup cell+ swap @
626: dup >r DoTable r> swap IF drop EXIT THEN
627: Display?
628: IF
629: .word bl cemit
630: ELSE
631: drop
632: THEN ;
633:
634: : c-init
635: 0 YPos ! 0 XPos !
636: 0 Level ! nlflag off
637: BranchTable BranchPointer !
638: c-stop off
639: Branches on ;
640:
641: : makepass ( a-addr -- )
642: c-stop off
643: BEGIN
644: analyse
645: c-stop @
646: UNTIL drop ;
647:
648: Defer xt-see-xt ( xt -- )
649: \ this one is just a forward declaration for indirect recursion
650:
651: : .defname ( xt c-addr u -- )
652: rot look
653: if ( c-addr u nfa )
654: -rot type space .name
655: else
656: drop ." noname " type
657: then
658: space ;
659:
660: Defer discode ( addr u -- ) \ gforth
661: \G hook for the disassembler: disassemble code at addr of length u
662: ' dump IS discode
663:
664: : next-head ( addr1 -- addr2 ) \ gforth
665: \G find the next header starting after addr1, up to here (unreliable).
666: here swap u+do
667: i head? -2 and if
668: i unloop exit
669: then
670: cell +loop
671: here ;
672:
673: : umin ( u1 u2 -- u )
674: 2dup u>
675: if
676: swap
677: then
678: drop ;
679:
680: : next-prim ( addr1 -- addr2 ) \ gforth
681: \G find the next primitive after addr1 (unreliable)
682: 1+ >r -1 primstart
683: begin ( umin head R: boundary )
684: @ dup
685: while
686: tuck name>int >code-address ( head1 umin ca R: boundary )
687: r@ - umin
688: swap
689: repeat
690: drop dup r@ negate u>=
691: \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
692: if ( umin R: boundary ) \ no primitive found behind -> use a default length
693: drop 31
694: then
695: r> + ;
696:
697: : seecode ( xt -- )
698: dup s" Code" .defname
699: >code-address
700: dup in-dictionary? \ user-defined code word?
701: if
702: dup next-head
703: else
704: dup next-prim
705: then
706: over - discode
707: ." end-code" cr ;
708: : seevar ( xt -- )
709: s" Variable" .defname cr ;
710: : seeuser ( xt -- )
711: s" User" .defname cr ;
712: : seecon ( xt -- )
713: dup >body ?
714: s" Constant" .defname cr ;
715: : seevalue ( xt -- )
716: dup >body ?
717: s" Value" .defname cr ;
718: : seedefer ( xt -- )
719: dup >body @ xt-see-xt cr
720: dup s" Defer" .defname cr
721: >name ?dup-if
722: ." IS " .name cr
723: else
724: ." latestxt >body !"
725: then ;
726: : see-threaded ( addr -- )
727: C-Pass @ DebugMode = IF
728: ScanMode c-pass !
729: EXIT
730: THEN
731: ScanMode c-pass ! dup makepass
732: DisplayMode c-pass ! makepass ;
733: : seedoes ( xt -- )
734: dup s" create" .defname cr
735: S" DOES> " Com# .string XPos @ Level !
736: >does-code see-threaded ;
737: : seecol ( xt -- )
738: dup s" :" .defname nl
739: 2 Level !
740: >body see-threaded ;
741: : seefield ( xt -- )
742: dup >body ." 0 " ? ." 0 0 "
743: s" Field" .defname cr ;
744:
745: : xt-see ( xt -- ) \ gforth
746: \G Decompile the definition represented by @i{xt}.
747: cr c-init
748: dup >does-code
749: if
750: seedoes EXIT
751: then
752: dup xtprim?
753: if
754: seecode EXIT
755: then
756: dup >code-address
757: CASE
758: docon: of seecon endof
759: docol: of seecol endof
760: dovar: of seevar endof
761: [ [IFDEF] douser: ]
762: douser: of seeuser endof
763: [ [THEN] ]
764: [ [IFDEF] dodefer: ]
765: dodefer: of seedefer endof
766: [ [THEN] ]
767: [ [IFDEF] dofield: ]
768: dofield: of seefield endof
769: [ [THEN] ]
770: over of seecode endof \ direct threaded code words
771: over >body of seecode endof \ indirect threaded code words
772: 2drop abort" unknown word type"
773: ENDCASE ;
774:
775: : (xt-see-xt) ( xt -- )
776: xt-see cr ." latestxt" ;
777: ' (xt-see-xt) is xt-see-xt
778:
779: : (.immediate) ( xt -- )
780: ['] execute = if
781: ." immediate"
782: then ;
783:
784: : name-see ( nfa -- )
785: dup name>int >r
786: dup name>comp
787: over r@ =
788: if \ normal or immediate word
789: swap xt-see (.immediate)
790: else
791: r@ ['] ticking-compile-only-error =
792: if \ compile-only word
793: swap xt-see (.immediate) ." compile-only"
794: else \ interpret/compile word
795: r@ xt-see-xt cr
796: swap xt-see-xt cr
797: ." interpret/compile " over .name (.immediate)
798: then
799: then
800: rdrop drop ;
801:
802: : see ( "<spaces>name" -- ) \ tools
803: \G Locate @var{name} using the current search order. Display the
804: \G definition of @var{name}. Since this is achieved by decompiling
805: \G the definition, the formatting is mechanised and some source
806: \G information (comments, interpreted sequences within definitions
807: \G etc.) is lost.
808: name find-name dup 0=
809: IF
810: drop -&13 throw
811: THEN
812: name-see ;
813:
814:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>