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