Annotation of gforth/see.fs, revision 1.49
1.1 anton 1: \ SEE.FS highend SEE for ANSforth 16may93jaw
2:
1.30 anton 3: \ Copyright (C) 1995,2000 Free Software Foundation, Inc.
1.9 anton 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
1.31 anton 19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.9 anton 20:
21:
1.1 anton 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:
1.18 jwilke 28: require look.fs
1.10 anton 29: require termsize.fs
1.18 jwilke 30: require wordinfo.fs
1.32 anton 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]
1.10 anton 44:
1.1 anton 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
1.15 pazsan 68: VARIABLE uppercase \ structure words are in uppercase
1.1 anton 69:
70: DEFER nlcount ' noop IS nlcount
71:
72: : nl nlflag on ;
73: : (nl) nlcount
1.18 jwilke 74: XPos @ Level @ = IF EXIT THEN \ ?Exit
1.1 anton 75: C-Formated @ IF
76: C-Output @
1.10 anton 77: IF C-Clearline @ IF cols XPos @ - spaces
1.1 anton 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
1.10 anton 85: XPos @ over + cols u>= IF (nl) THEN ;
1.1 anton 86:
1.22 crook 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 ;
1.15 pazsan 90:
1.1 anton 91: : ctype ( adr len -- )
1.15 pazsan 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 ;
1.1 anton 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:
1.34 anton 102: DEFER .string ( c-addr u n -- )
1.1 anton 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:
1.45 anton 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 ;
1.1 anton 149:
1.15 pazsan 150: : .struc
151: uppercase on Str# .string ;
1.1 anton 152:
1.17 jwilke 153: \ CODES (Branchtypes) 15may93jaw
1.1 anton 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
1.17 jwilke 163: 15 CONSTANT LeaveCode
164:
1.1 anton 165:
166: \ FORMAT WORDS 13jun93jaw
167:
168: VARIABLE C-Stop
169: VARIABLE Branches
170:
1.17 jwilke 171: VARIABLE BranchPointer \ point to the end of branch table
1.1 anton 172: VARIABLE SearchPointer
1.17 jwilke 173:
174: \ The branchtable consists of three entrys:
175: \ address of branch , branch destination , branch type
176:
1.25 pazsan 177: CREATE BranchTable 128 cells allot
1.1 anton 178: here 3 cells -
179: ACONSTANT MaxTable
180:
181: : FirstBranch BranchTable cell+ SearchPointer ! ;
182:
1.17 jwilke 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
1.1 anton 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:
1.17 jwilke 215: : MyBranch ( a-addr -- a-addr a-addr2 )
216: \ finds branch table entry for branch at a-addr
1.45 anton 217: dup @
1.17 jwilke 218: BranchAddr?
219: BEGIN
220: WHILE 1 cells - @
221: over <>
1.45 anton 222: WHILE dup @
1.17 jwilke 223: MoreBranchAddr?
224: REPEAT
225: SearchPointer @ 3 cells -
226: ELSE true ABORT" SEE: Table failure"
227: THEN ;
228:
1.1 anton 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 )
1.45 anton 260: over ,Branch ,Branch 0 ,Branch ;
261: \ over + over ,Branch ,Branch 0 ,Branch ;
1.1 anton 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:
1.45 anton 275: : back? ( addr target -- addr flag )
276: over u< ;
1.1 anton 277:
1.47 anton 278: : .word ( addr x -- addr )
279: \ print x as a word if possible
280: dup look 0= IF
1.48 anton 281: drop dup threaded>name dup 0= if
1.47 anton 282: 2drop dup 1 cells - @ dup body> look
283: IF
284: nip dup ." <" name>string rot wordinfo .string ." > "
285: ELSE
286: drop ." <" 0 .r ." > "
287: THEN
288: EXIT
289: then
290: THEN
291: nip dup cell+ @ immediate-mask and
292: IF
293: bl cemit ." POSTPONE "
294: THEN
295: dup name>string rot wordinfo .string
296: ;
1.35 pazsan 297:
1.44 anton 298: : c-call ( addr1 -- addr2 )
299: Display? IF
300: dup @ body> .word bl cemit
301: THEN
302: cell+ ;
303:
304: : c-callxt ( addr1 -- addr2 )
305: Display? IF
306: dup @ .word bl cemit
307: THEN
308: cell+ ;
309:
310: \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
311: \ here over - 2constant doers
312:
313: : c-lit ( addr1 -- addr2 )
314: Display? IF
315: dup @ dup body> dup cfaligned over = swap in-dictionary? and if
316: ( addr1 addr1@ )
317: dup body> @ dovar: = if
318: drop c-call EXIT
319: endif
320: endif
321: \ !! test for cfa here, and print "['] ..."
322: dup abs 0 <# #S rot sign #> 0 .string bl cemit
323: endif
324: cell+ ;
325:
326: : c-lit+ ( addr1 -- addr2 )
327: Display? if
328: dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
329: s" + " 0 .string
330: endif
331: cell+ ;
1.35 pazsan 332:
1.18 jwilke 333: : .name-without ( addr -- addr )
1.48 anton 334: \ !! the stack effect cannot be correct
335: \ prints a name without a() e.g. a(+LOOP) or (s")
336: dup 1 cells - @ threaded>name dup IF
1.45 anton 337: name>string over c@ 'a = IF
338: 1 /string
339: THEN
340: over c@ '( = IF
341: 1 /string
342: THEN
343: 2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
344: THEN ;
1.1 anton 345:
1.45 anton 346: [ifdef] (s")
1.1 anton 347: : c-c"
1.18 jwilke 348: Display? IF nl .name-without THEN
1.1 anton 349: count 2dup + aligned -rot
350: Display?
1.18 jwilke 351: IF bl cemit 0 .string
1.1 anton 352: [char] " cemit bl cemit
353: ELSE 2drop
354: THEN ;
1.45 anton 355: [endif]
1.1 anton 356:
1.45 anton 357: : c-string? ( addr1 -- addr2 f )
358: \ f is true if a string was found and decompiled.
359: \ if f is false, addr2=addr1
360: \ recognizes the following patterns:
361: \ c": ahead X: len string then lit X
1.49 ! anton 362: \ flit: ahead X: float then lit X f@
! 363: \ s\": ahead X: string then lit X lit len
! 364: \ .\": ahead X: string then lit X lit len type
1.45 anton 365: \ !! not recognized anywhere:
366: \ abort": if ahead X: len string then lit X c(abort") then
367: dup @ back? if false exit endif
368: dup @ >r
369: r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif
370: r@ cell+ @ over cell+ <> if rdrop false exit endif
371: \ we have at least C"
1.49 ! anton 372: r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if
! 373: drop r@ 3 cells + @ over cell+ + aligned r@ = if
1.45 anton 374: \ we have at least s"
375: r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded =
376: r@ 5 cells + @ ['] type >body = and if
377: 6 s\" .\\\" "
378: else
379: 4 s\" s\\\" "
380: endif
381: \ !! make newline if string too long?
382: display? if
383: 0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit
384: else
385: 2drop
386: endif
387: nip cells r> + true exit
388: endif
1.49 ! anton 389: endif
! 390: ['] f@ xt>threaded = if
! 391: display? if
! 392: r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit
! 393: endif
! 394: drop r> 3 cells + true exit
1.45 anton 395: endif
396: \ !! check if count matches space?
397: display? if
398: s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit
399: endif
400: drop r> 2 cells + true ;
1.1 anton 401:
1.17 jwilke 402: : Forward? ( a-addr true | false -- a-addr true | false )
1.45 anton 403: \ a-addr is pointer into branch table
404: \ returns true when jump is a forward jump
405: IF
406: dup dup @ swap 1 cells - @ u> IF
407: true
408: ELSE
409: drop false
410: THEN
411: \ only if forward jump
412: ELSE
413: false
414: THEN ;
1.1 anton 415:
1.17 jwilke 416: : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
1.1 anton 417: IF BEGIN 2dup
1.45 anton 418: 1 cells - @ swap @
1.1 anton 419: u<=
420: WHILE drop dup cell+
421: MoreBranchAddr? 0=
422: UNTIL false
423: ELSE true
424: THEN
425: ELSE false
426: THEN ;
427:
1.45 anton 428: : c-branch ( addr1 -- addr2 )
429: c-string? ?exit
1.1 anton 430: Scan?
431: IF dup @ Branch!
432: dup @ back?
433: IF \ might be: AGAIN, REPEAT
434: dup cell+ BranchAddr? Forward?
435: RepeatCheck
436: IF RepeatCode Type!
437: cell+ Disable swap !
438: ELSE AgainCode Type!
439: THEN
440: ELSE dup cell+ BranchAddr? Forward?
441: IF ElseCode Type! drop
442: ELSE AheadCode Type!
443: THEN
444: THEN
445: THEN
446: Display?
447: IF
448: dup @ back?
449: IF \ might be: AGAIN, REPEAT
450: level- nl
451: dup cell+ BranchAddr? Forward?
452: RepeatCheck
453: IF drop S" REPEAT " .struc nl
454: ELSE S" AGAIN " .struc nl
455: THEN
1.17 jwilke 456: ELSE MyBranch cell+ @ LeaveCode =
457: IF S" LEAVE " .struc
458: ELSE
459: dup cell+ BranchAddr? Forward?
460: IF dup cell+ @ WhileCode2 =
461: IF nl S" ELSE" .struc level+
462: ELSE level- nl S" ELSE" .struc level+ THEN
463: cell+ Disable swap !
464: ELSE S" AHEAD" .struc level+
465: THEN
466: THEN
1.1 anton 467: THEN
468: THEN
469: Debug?
470: IF dup @ +
471: ELSE cell+
472: THEN ;
473:
474: : DebugBranch
475: Debug?
476: IF dup @ over + swap THEN ; \ return 2 different addresses
477:
478: : c-?branch
479: Scan?
480: IF dup @ Branch!
481: dup @ Back?
482: IF UntilCode Type! THEN
483: THEN
484: Display?
485: IF dup @ Back?
486: IF level- nl S" UNTIL " .struc nl
487: ELSE dup dup @ over +
488: CheckWhile
489: IF MyBranch
490: cell+ dup @ 0=
491: IF WhileCode2 swap !
492: ELSE drop THEN
493: level- nl
1.8 pazsan 494: S" WHILE " .struc
1.1 anton 495: level+
1.17 jwilke 496: ELSE MyBranch cell+ @ LeaveCode =
497: IF s" 0= ?LEAVE " .struc
498: ELSE nl S" IF " .struc level+
499: THEN
1.1 anton 500: THEN
501: THEN
502: THEN
503: DebugBranch
504: cell+ ;
505:
506: : c-for
507: Display? IF nl S" FOR" .struc level+ THEN ;
508:
509: : c-loop
1.15 pazsan 510: Display? IF level- nl .name-without bl cemit nl THEN
1.17 jwilke 511: DebugBranch cell+
512: Scan?
513: IF dup BranchAddr?
514: BEGIN WHILE cell+ LeaveCode swap !
515: dup MoreBranchAddr?
516: REPEAT
517: THEN
518: cell+ ;
1.1 anton 519:
1.15 pazsan 520: : c-do
521: Display? IF nl .name-without level+ THEN ;
1.1 anton 522:
1.45 anton 523: : c-?do ( addr1 -- addr2 )
524: Display? IF
525: nl .name-without level+
526: THEN
527: DebugBranch cell+ ;
1.8 pazsan 528:
1.1 anton 529: : c-exit dup 1 cells -
530: CheckEnd
531: IF Display? IF nlflag off S" ;" Com# .string THEN
532: C-Stop on
533: ELSE Display? IF S" EXIT " .struc THEN
534: THEN
535: Debug? IF drop THEN ;
536:
537: : c-abort"
538: count 2dup + aligned -rot
539: Display?
540: IF S" ABORT" .struc
541: [char] " cemit bl cemit 0 .string
542: [char] " cemit bl cemit
543: ELSE 2drop
544: THEN ;
545:
1.23 jwilke 546: [IFDEF] (does>)
547: : c-does> \ end of create part
548: Display? IF S" DOES> " Com# .string THEN
549: maxaligned /does-handler + ;
550: [THEN]
551:
552: [IFDEF] (compile)
553: : c-(compile)
554: Display?
555: IF
556: s" POSTPONE " Com# .string
557: dup @ look 0= ABORT" SEE: No valid XT"
558: name>string 0 .string bl cemit
559: THEN
560: cell+ ;
561: [THEN]
1.1 anton 562:
563: CREATE C-Table
1.18 jwilke 564: ' lit A, ' c-lit A,
1.44 anton 565: ' does-exec A, ' c-callxt A,
566: ' lit@ A, ' c-call A,
1.37 pazsan 567: [IFDEF] call ' call A, ' c-call A, [THEN]
1.44 anton 568: \ ' useraddr A, ....
569: ' lit-perform A, ' c-call A,
570: ' lit+ A, ' c-lit+ A,
1.42 anton 571: [IFDEF] (s") ' (s") A, ' c-c" A, [THEN]
572: [IFDEF] (.") ' (.") A, ' c-c" A, [THEN]
573: [IFDEF] "lit ' "lit A, ' c-c" A, [THEN]
1.18 jwilke 574: [IFDEF] (c") ' (c") A, ' c-c" A, [THEN]
575: ' (do) A, ' c-do A,
1.46 pazsan 576: [IFDEF] (+do) ' (+do) A, ' c-?do A, [THEN]
577: [IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN]
578: [IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN]
579: [IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN]
580: ' (?do) A, ' c-?do A,
1.18 jwilke 581: ' (for) A, ' c-for A,
1.46 pazsan 582: ' ?branch A, ' c-?branch A,
583: ' branch A, ' c-branch A,
584: ' (loop) A, ' c-loop A,
585: ' (+loop) A, ' c-loop A,
586: [IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN]
587: [IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]
588: ' (next) A, ' c-loop A,
1.18 jwilke 589: ' ;s A, ' c-exit A,
1.42 anton 590: [IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN]
1.23 jwilke 591: \ only defined if compiler is loaded
592: [IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN]
593: [IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN]
1.18 jwilke 594: 0 , here 0 ,
1.15 pazsan 595:
596: avariable c-extender
597: c-extender !
1.1 anton 598:
599: \ DOTABLE 15may93jaw
600:
1.44 anton 601: : DoTable ( ca/cfa -- flag )
602: decompile-prim C-Table BEGIN ( cfa table-entry )
603: dup @ dup 0= IF
604: drop cell+ @ dup IF ( next table!)
605: dup @
606: ELSE ( end!)
607: 2drop false EXIT
608: THEN
609: THEN
610: \ jump over to extender, if any 26jan97jaw
611: xt>threaded 2 pick <>
612: WHILE
613: 2 cells +
614: REPEAT
615: nip cell+ perform
616: true
617: ;
1.1 anton 618:
619: : BranchTo? ( a-addr -- a-addr )
1.17 jwilke 620: Display? IF dup BranchAddr?
1.15 pazsan 621: IF
622: BEGIN cell+ @ dup 20 u>
1.1 anton 623: IF drop nl S" BEGIN " .struc level+
624: ELSE
1.17 jwilke 625: dup Disable <> over LeaveCode <> and
1.1 anton 626: IF WhileCode2 =
627: IF nl S" THEN " .struc nl ELSE
628: level- nl S" THEN " .struc nl THEN
629: ELSE drop THEN
630: THEN
631: dup MoreBranchAddr? 0=
632: UNTIL
633: THEN
634: THEN ;
635:
636: : analyse ( a-addr1 -- a-addr2 )
1.34 anton 637: Branches @ IF BranchTo? THEN
638: dup cell+ swap @
639: dup >r DoTable r> swap IF drop EXIT THEN
640: Display?
641: IF
1.35 pazsan 642: .word bl cemit
1.34 anton 643: ELSE
644: drop
645: THEN ;
1.1 anton 646:
647: : c-init
648: 0 YPos ! 0 XPos !
649: 0 Level ! nlflag off
650: BranchTable BranchPointer !
651: c-stop off
652: Branches on ;
653:
654: : makepass ( a-addr -- )
1.14 anton 655: c-stop off
656: BEGIN
657: analyse
658: c-stop @
659: UNTIL drop ;
660:
661: Defer xt-see-xt ( xt -- )
662: \ this one is just a forward declaration for indirect recursion
663:
664: : .defname ( xt c-addr u -- )
665: rot look
666: if ( c-addr u nfa )
667: -rot type space .name
668: else
669: drop ." noname " type
670: then
671: space ;
672:
1.28 anton 673: Defer discode ( addr u -- ) \ gforth
674: \G hook for the disassembler: disassemble code at addr of length u
1.27 anton 675: ' dump IS discode
676:
677: : next-head ( addr1 -- addr2 ) \ gforth
678: \G find the next header starting after addr1, up to here (unreliable).
679: here swap u+do
1.43 anton 680: i head? -2 and if
1.27 anton 681: i unloop exit
682: then
683: cell +loop
684: here ;
685:
686: : umin ( u1 u2 -- u )
687: 2dup u>
688: if
689: swap
690: then
691: drop ;
692:
1.28 anton 693: : next-prim ( addr1 -- addr2 ) \ gforth
694: \G find the next primitive after addr1 (unreliable)
1.27 anton 695: 1+ >r -1 primstart
696: begin ( umin head R: boundary )
697: @ dup
698: while
1.28 anton 699: tuck name>int >code-address ( head1 umin ca R: boundary )
1.27 anton 700: r@ - umin
701: swap
702: repeat
1.28 anton 703: drop dup r@ negate u>=
704: \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
705: if ( umin R: boundary ) \ no primitive found behind -> use a default length
706: drop 31
707: then
708: r> + ;
1.14 anton 709:
710: : seecode ( xt -- )
711: dup s" Code" .defname
1.39 anton 712: >code-address
1.27 anton 713: dup in-dictionary? \ user-defined code word?
714: if
715: dup next-head
716: else
717: dup next-prim
718: then
719: over - discode
720: ." end-code" cr ;
1.14 anton 721: : seevar ( xt -- )
722: s" Variable" .defname cr ;
723: : seeuser ( xt -- )
724: s" User" .defname cr ;
725: : seecon ( xt -- )
726: dup >body ?
727: s" Constant" .defname cr ;
728: : seevalue ( xt -- )
729: dup >body ?
730: s" Value" .defname cr ;
731: : seedefer ( xt -- )
732: dup >body @ xt-see-xt cr
733: dup s" Defer" .defname cr
1.26 anton 734: >name ?dup-if
735: ." IS " .name cr
1.14 anton 736: else
1.26 anton 737: ." lastxt >body !"
1.14 anton 738: then ;
739: : see-threaded ( addr -- )
740: C-Pass @ DebugMode = IF
741: ScanMode c-pass !
742: EXIT
1.10 anton 743: THEN
744: ScanMode c-pass ! dup makepass
745: DisplayMode c-pass ! makepass ;
1.14 anton 746: : seedoes ( xt -- )
747: dup s" create" .defname cr
748: S" DOES> " Com# .string XPos @ Level !
749: >does-code see-threaded ;
750: : seecol ( xt -- )
1.15 pazsan 751: dup s" :" .defname nl
1.14 anton 752: 2 Level !
753: >body see-threaded ;
754: : seefield ( xt -- )
755: dup >body ." 0 " ? ." 0 0 "
756: s" Field" .defname cr ;
757:
1.29 anton 758: : xt-see ( xt -- ) \ gforth
759: \G Decompile the definition represented by @i{xt}.
1.14 anton 760: cr c-init
761: dup >does-code
762: if
763: seedoes EXIT
764: then
1.18 jwilke 765: dup xtprim?
1.14 anton 766: if
767: seecode EXIT
768: then
769: dup >code-address
770: CASE
771: docon: of seecon endof
772: docol: of seecol endof
773: dovar: of seevar endof
1.18 jwilke 774: [ [IFDEF] douser: ]
1.14 anton 775: douser: of seeuser endof
1.18 jwilke 776: [ [THEN] ]
777: [ [IFDEF] dodefer: ]
1.14 anton 778: dodefer: of seedefer endof
1.18 jwilke 779: [ [THEN] ]
780: [ [IFDEF] dofield: ]
1.14 anton 781: dofield: of seefield endof
1.18 jwilke 782: [ [THEN] ]
1.27 anton 783: over of seecode endof \ direct threaded code words
784: over >body of seecode endof \ indirect threaded code words
1.14 anton 785: 2drop abort" unknown word type"
786: ENDCASE ;
787:
788: : (xt-see-xt) ( xt -- )
789: xt-see cr ." lastxt" ;
790: ' (xt-see-xt) is xt-see-xt
791:
792: : (.immediate) ( xt -- )
793: ['] execute = if
794: ." immediate"
795: then ;
796:
797: : name-see ( nfa -- )
798: dup name>int >r
799: dup name>comp
800: over r@ =
801: if \ normal or immediate word
802: swap xt-see (.immediate)
803: else
1.40 anton 804: r@ ['] ticking-compile-only-error =
1.14 anton 805: if \ compile-only word
806: swap xt-see (.immediate) ." compile-only"
807: else \ interpret/compile word
808: r@ xt-see-xt cr
809: swap xt-see-xt cr
810: ." interpret/compile " over .name (.immediate)
811: then
812: then
813: rdrop drop ;
1.3 pazsan 814:
1.21 crook 815: : see ( "<spaces>name" -- ) \ tools
816: \G Locate @var{name} using the current search order. Display the
817: \G definition of @var{name}. Since this is achieved by decompiling
818: \G the definition, the formatting is mechanised and some source
819: \G information (comments, interpreted sequences within definitions
820: \G etc.) is lost.
1.13 anton 821: name find-name dup 0=
822: IF
1.24 anton 823: drop -&13 throw
1.13 anton 824: THEN
1.14 anton 825: name-see ;
1.1 anton 826:
827:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>