1: \ SEE.FS highend SEE for ANSforth 16may93jaw
2:
3: \ Copyright (C) 1995,2000,2003,2004,2006 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: : ctype ( adr len -- )
75: warp? dup XPos +! C-Output @
76: IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP
77: uppercase off ELSE type THEN
78: ELSE 2drop THEN ;
79:
80: : cemit 1 warp?
81: over bl = Level @ XPos @ = and
82: IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
83: THEN ;
84:
85: DEFER .string ( c-addr u n -- )
86:
87: [IFDEF] Green
88: VARIABLE Colors Colors on
89:
90: : (.string) ( c-addr u n -- )
91: over warp? drop
92: Colors @
93: IF C-Highlight @ ?dup
94: IF CT@ swap CT@ or
95: ELSE CT@
96: THEN
97: attr! ELSE drop THEN
98: ctype ct @ attr! ;
99: [ELSE]
100: : (.string) ( c-addr u n -- )
101: drop ctype ;
102: [THEN]
103:
104: ' (.string) IS .string
105:
106: : c-\type ( c-addr u -- )
107: \ type string in \-escaped form
108: begin
109: dup while
110: 2dup newline string-prefix? if
111: '\ cemit 'n cemit
112: newline nip /string
113: else
114: over c@
115: dup '" = over '\ = or if
116: '\ cemit cemit
117: else
118: dup bl 127 within if
119: cemit
120: else
121: base @ >r try
122: 8 base ! 0 <<# # # # '\ hold #> ctype #>> 0
123: restore
124: r@ base !
125: endtry
126: rdrop throw
127: endif
128: endif
129: 1 /string
130: endif
131: repeat
132: 2drop ;
133:
134: : .struc
135: uppercase on Str# .string ;
136:
137: \ CODES (Branchtypes) 15may93jaw
138:
139: 21 CONSTANT RepeatCode
140: 22 CONSTANT AgainCode
141: 23 CONSTANT UntilCode
142: \ 09 CONSTANT WhileCode
143: 10 CONSTANT ElseCode
144: 11 CONSTANT AheadCode
145: 13 CONSTANT WhileCode2
146: 14 CONSTANT Disable
147: 15 CONSTANT LeaveCode
148:
149:
150: \ FORMAT WORDS 13jun93jaw
151:
152: VARIABLE C-Stop
153: VARIABLE Branches
154:
155: VARIABLE BranchPointer \ point to the end of branch table
156: VARIABLE SearchPointer
157:
158: \ The branchtable consists of three entrys:
159: \ address of branch , branch destination , branch type
160:
161: CREATE BranchTable 128 cells allot
162: here 3 cells -
163: ACONSTANT MaxTable
164:
165: : FirstBranch BranchTable cell+ SearchPointer ! ;
166:
167: : (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
168: \ searches a branch with destination a-addr1
169: \ a-addr1: branch destination
170: \ a-addr2: pointer in branch table
171: SearchPointer @
172: BEGIN dup BranchPointer @ u<
173: WHILE
174: dup @ 2 pick <>
175: WHILE 3 cells +
176: REPEAT
177: nip dup 3 cells + SearchPointer ! true
178: ELSE
179: 2drop false
180: THEN ;
181:
182: : BranchAddr?
183: FirstBranch (BranchAddr?) ;
184:
185: ' (BranchAddr?) ALIAS MoreBranchAddr?
186:
187: : CheckEnd ( a-addr -- true | false )
188: BranchTable cell+
189: BEGIN dup BranchPointer @ u<
190: WHILE
191: dup @ 2 pick u<=
192: WHILE 3 cells +
193: REPEAT
194: 2drop false
195: ELSE
196: 2drop true
197: THEN ;
198:
199: : MyBranch ( a-addr -- a-addr a-addr2 )
200: \ finds branch table entry for branch at a-addr
201: dup @
202: BranchAddr?
203: BEGIN
204: WHILE 1 cells - @
205: over <>
206: WHILE dup @
207: MoreBranchAddr?
208: REPEAT
209: SearchPointer @ 3 cells -
210: ELSE true ABORT" SEE: Table failure"
211: THEN ;
212:
213: \
214: \ addrw addrt
215: \ BEGIN ... WHILE ... AGAIN ... THEN
216: \ ^ ! ! ^
217: \ ----------+--------+ !
218: \ ! !
219: \ +-------------------+
220: \
221: \
222:
223: : CheckWhile ( a-addrw a-addrt -- true | false )
224: BranchTable
225: BEGIN dup BranchPointer @ u<
226: WHILE dup @ 3 pick u>
227: over @ 3 pick u< and
228: IF dup cell+ @ 3 pick u<
229: IF 2drop drop true EXIT THEN
230: THEN
231: 3 cells +
232: REPEAT
233: 2drop drop false ;
234:
235: : ,Branch ( a-addr -- )
236: BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
237: !
238: 1 cells BranchPointer +! ;
239:
240: : Type! ( u -- )
241: BranchPointer @ 1 cells - ! ;
242:
243: : Branch! ( a-addr rel -- a-addr )
244: over ,Branch ,Branch 0 ,Branch ;
245: \ over + over ,Branch ,Branch 0 ,Branch ;
246:
247: \ DEFER CheckUntil
248: VARIABLE NoOutput
249: VARIABLE C-Pass
250:
251: 0 CONSTANT ScanMode
252: 1 CONSTANT DisplayMode
253: 2 CONSTANT DebugMode
254:
255: : Scan? ( -- flag ) C-Pass @ 0= ;
256: : Display? ( -- flag ) C-Pass @ 1 = ;
257: : Debug? ( -- flag ) C-Pass @ 2 = ;
258:
259: : back? ( addr target -- addr flag )
260: over u< ;
261:
262: : .word ( addr x -- addr )
263: \ print x as a word if possible
264: dup look 0= IF
265: drop dup threaded>name dup 0= if
266: drop over 1 cells - @ dup body> look
267: IF
268: nip nip dup ." <" name>string rot wordinfo .string ." > "
269: ELSE
270: 2drop ." <" 0 .r ." > "
271: THEN
272: EXIT
273: then
274: THEN
275: nip dup cell+ @ immediate-mask and
276: IF
277: bl cemit ." POSTPONE "
278: THEN
279: dup name>string rot wordinfo .string
280: ;
281:
282: : c-call ( addr1 -- addr2 )
283: Display? IF
284: dup @ body> .word bl cemit
285: THEN
286: cell+ ;
287:
288: : c-callxt ( addr1 -- addr2 )
289: Display? IF
290: dup @ .word bl cemit
291: THEN
292: cell+ ;
293:
294: \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
295: \ here over - 2constant doers
296:
297: : c-lit ( addr1 -- addr2 )
298: Display? IF
299: dup @ dup body> dup cfaligned over = swap in-dictionary? and if
300: ( addr1 addr1@ )
301: dup body> @ dovar: = if
302: drop c-call EXIT
303: endif
304: endif
305: \ !! test for cfa here, and print "['] ..."
306: dup abs 0 <# #S rot sign #> 0 .string bl cemit
307: endif
308: cell+ ;
309:
310: : c-lit+ ( addr1 -- addr2 )
311: Display? if
312: dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
313: s" + " 0 .string
314: endif
315: cell+ ;
316:
317: : .name-without ( addr -- addr )
318: \ !! the stack effect cannot be correct
319: \ prints a name without a() e.g. a(+LOOP) or (s")
320: dup 1 cells - @ threaded>name dup IF
321: name>string over c@ 'a = IF
322: 1 /string
323: THEN
324: over c@ '( = IF
325: 1 /string
326: THEN
327: 2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
328: THEN ;
329:
330: [ifdef] (s")
331: : c-c"
332: Display? IF nl .name-without THEN
333: count 2dup + aligned -rot
334: Display?
335: IF bl cemit 0 .string
336: [char] " cemit bl cemit
337: ELSE 2drop
338: THEN ;
339: [endif]
340:
341: : c-string? ( addr1 -- addr2 f )
342: \ f is true if a string was found and decompiled.
343: \ if f is false, addr2=addr1
344: \ recognizes the following patterns:
345: \ c": ahead X: len string then lit X
346: \ flit: ahead X: float then lit X f@
347: \ s\": ahead X: string then lit X lit len
348: \ .\": ahead X: string then lit X lit len type
349: \ !! not recognized anywhere:
350: \ abort": if ahead X: len string then lit X c(abort") then
351: dup @ back? if false exit endif
352: dup @ >r
353: r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif
354: r@ cell+ @ over cell+ <> if rdrop false exit endif
355: \ we have at least C"
356: r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if
357: drop r@ 3 cells + @ over cell+ + aligned r@ = if
358: \ we have at least s"
359: r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded =
360: r@ 5 cells + @ ['] type >body = and if
361: 6 s\" .\\\" "
362: else
363: 4 s\" s\\\" "
364: endif
365: \ !! make newline if string too long?
366: display? if
367: 0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit
368: else
369: 2drop
370: endif
371: nip cells r> + true exit
372: endif
373: endif
374: ['] f@ xt>threaded = if
375: display? if
376: r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit
377: endif
378: drop r> 3 cells + true exit
379: endif
380: \ !! check if count matches space?
381: display? if
382: s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit
383: endif
384: drop r> 2 cells + true ;
385:
386: : Forward? ( a-addr true | false -- a-addr true | false )
387: \ a-addr is pointer into branch table
388: \ returns true when jump is a forward jump
389: IF
390: dup dup @ swap 1 cells - @ u> IF
391: true
392: ELSE
393: drop false
394: THEN
395: \ only if forward jump
396: ELSE
397: false
398: THEN ;
399:
400: : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
401: IF BEGIN 2dup
402: 1 cells - @ swap @
403: u<=
404: WHILE drop dup cell+
405: MoreBranchAddr? 0=
406: UNTIL false
407: ELSE true
408: THEN
409: ELSE false
410: THEN ;
411:
412: : c-branch ( addr1 -- addr2 )
413: c-string? ?exit
414: Scan?
415: IF dup @ Branch!
416: dup @ back?
417: IF \ might be: AGAIN, REPEAT
418: dup cell+ BranchAddr? Forward?
419: RepeatCheck
420: IF RepeatCode Type!
421: cell+ Disable swap !
422: ELSE AgainCode Type!
423: THEN
424: ELSE dup cell+ BranchAddr? Forward?
425: IF ElseCode Type! drop
426: ELSE AheadCode Type!
427: THEN
428: THEN
429: THEN
430: Display?
431: IF
432: dup @ back?
433: IF \ might be: AGAIN, REPEAT
434: level- nl
435: dup cell+ BranchAddr? Forward?
436: RepeatCheck
437: IF drop S" REPEAT " .struc nl
438: ELSE S" AGAIN " .struc nl
439: THEN
440: ELSE MyBranch cell+ @ LeaveCode =
441: IF S" LEAVE " .struc
442: ELSE
443: dup cell+ BranchAddr? Forward?
444: IF dup cell+ @ WhileCode2 =
445: IF nl S" ELSE" .struc level+
446: ELSE level- nl S" ELSE" .struc level+ THEN
447: cell+ Disable swap !
448: ELSE S" AHEAD" .struc level+
449: THEN
450: THEN
451: THEN
452: THEN
453: Debug?
454: IF @ \ !!! cross-interacts with debugger !!!
455: ELSE cell+
456: THEN ;
457:
458: : DebugBranch
459: Debug?
460: IF dup @ swap THEN ; \ return 2 different addresses
461:
462: : c-?branch
463: Scan?
464: IF dup @ Branch!
465: dup @ Back?
466: IF UntilCode Type! THEN
467: THEN
468: Display?
469: IF dup @ Back?
470: IF level- nl S" UNTIL " .struc nl
471: ELSE dup dup @ over +
472: CheckWhile
473: IF MyBranch
474: cell+ dup @ 0=
475: IF WhileCode2 swap !
476: ELSE drop THEN
477: level- nl
478: S" WHILE " .struc
479: level+
480: ELSE MyBranch cell+ @ LeaveCode =
481: IF s" 0= ?LEAVE " .struc
482: ELSE nl S" IF " .struc level+
483: THEN
484: THEN
485: THEN
486: THEN
487: DebugBranch
488: cell+ ;
489:
490: : c-for
491: Display? IF nl S" FOR" .struc level+ THEN ;
492:
493: : c-loop
494: Display? IF level- nl .name-without nl bl cemit THEN
495: DebugBranch cell+
496: Scan?
497: IF dup BranchAddr?
498: BEGIN WHILE cell+ LeaveCode swap !
499: dup MoreBranchAddr?
500: REPEAT
501: THEN
502: cell+ ;
503:
504: : c-do
505: Display? IF nl .name-without level+ THEN ;
506:
507: : c-?do ( addr1 -- addr2 )
508: Display? IF
509: nl .name-without level+
510: THEN
511: DebugBranch cell+ ;
512:
513: : c-exit ( addr1 -- addr2 )
514: dup 1 cells -
515: CheckEnd
516: IF
517: Display? IF nlflag off S" ;" Com# .string THEN
518: C-Stop on
519: ELSE
520: Display? IF S" EXIT " .struc THEN
521: THEN
522: Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!!
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: [ifundef] umin \ !! bootstrapping help
674: : umin ( u1 u2 -- u )
675: 2dup u>
676: if
677: swap
678: then
679: drop ;
680: [then]
681:
682: : next-prim ( addr1 -- addr2 ) \ gforth
683: \G find the next primitive after addr1 (unreliable)
684: 1+ >r -1 primstart
685: begin ( umin head R: boundary )
686: @ dup
687: while
688: tuck name>int >code-address ( head1 umin ca R: boundary )
689: r@ - umin
690: swap
691: repeat
692: drop dup r@ negate u>=
693: \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
694: if ( umin R: boundary ) \ no primitive found behind -> use a default length
695: drop 31
696: then
697: r> + ;
698:
699: : seecode ( xt -- )
700: dup s" Code" .defname
701: >code-address
702: dup in-dictionary? \ user-defined code word?
703: if
704: dup next-head
705: else
706: dup next-prim
707: then
708: over - discode
709: ." end-code" cr ;
710: : seevar ( xt -- )
711: s" Variable" .defname cr ;
712: : seeuser ( xt -- )
713: s" User" .defname cr ;
714: : seecon ( xt -- )
715: dup >body ?
716: s" Constant" .defname cr ;
717: : seevalue ( xt -- )
718: dup >body ?
719: s" Value" .defname cr ;
720: : seedefer ( xt -- )
721: dup >body @ xt-see-xt cr
722: dup s" Defer" .defname cr
723: >name ?dup-if
724: ." IS " .name cr
725: else
726: ." latestxt >body !"
727: then ;
728: : see-threaded ( addr -- )
729: C-Pass @ DebugMode = IF
730: ScanMode c-pass !
731: EXIT
732: THEN
733: ScanMode c-pass ! dup makepass
734: DisplayMode c-pass ! makepass ;
735: : seedoes ( xt -- )
736: dup s" create" .defname cr
737: S" DOES> " Com# .string XPos @ Level !
738: >does-code see-threaded ;
739: : seecol ( xt -- )
740: dup s" :" .defname nl
741: 2 Level !
742: >body see-threaded ;
743: : seefield ( xt -- )
744: dup >body ." 0 " ? ." 0 0 "
745: s" Field" .defname cr ;
746:
747: : xt-see ( xt -- ) \ gforth
748: \G Decompile the definition represented by @i{xt}.
749: cr c-init
750: dup >does-code
751: if
752: seedoes EXIT
753: then
754: dup xtprim?
755: if
756: seecode EXIT
757: then
758: dup >code-address
759: CASE
760: docon: of seecon endof
761: docol: of seecol endof
762: dovar: of seevar endof
763: [ [IFDEF] douser: ]
764: douser: of seeuser endof
765: [ [THEN] ]
766: [ [IFDEF] dodefer: ]
767: dodefer: of seedefer endof
768: [ [THEN] ]
769: [ [IFDEF] dofield: ]
770: dofield: of seefield endof
771: [ [THEN] ]
772: over of seecode endof \ direct threaded code words
773: over >body of seecode endof \ indirect threaded code words
774: 2drop abort" unknown word type"
775: ENDCASE ;
776:
777: : (xt-see-xt) ( xt -- )
778: xt-see cr ." latestxt" ;
779: ' (xt-see-xt) is xt-see-xt
780:
781: : (.immediate) ( xt -- )
782: ['] execute = if
783: ." immediate"
784: then ;
785:
786: : name-see ( nfa -- )
787: dup name>int >r
788: dup name>comp
789: over r@ =
790: if \ normal or immediate word
791: swap xt-see (.immediate)
792: else
793: r@ ['] ticking-compile-only-error =
794: if \ compile-only word
795: swap xt-see (.immediate) ." compile-only"
796: else \ interpret/compile word
797: r@ xt-see-xt cr
798: swap xt-see-xt cr
799: ." interpret/compile: " over .name drop
800: then
801: then
802: rdrop drop ;
803:
804: : see ( "<spaces>name" -- ) \ tools
805: \G Locate @var{name} using the current search order. Display the
806: \G definition of @var{name}. Since this is achieved by decompiling
807: \G the definition, the formatting is mechanised and some source
808: \G information (comments, interpreted sequences within definitions
809: \G etc.) is lost.
810: name find-name dup 0=
811: IF
812: drop -&13 throw
813: THEN
814: name-see ;
815:
816:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to see.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth