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