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