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