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