Annotation of gforth/see.fs, revision 1.23
1.1 anton 1: \ SEE.FS highend SEE for ANSforth 16may93jaw
2:
1.9 anton 3: \ Copyright (C) 1995 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., 675 Mass Ave, Cambridge, MA 02139, USA.
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
31: [IFUNDEF] .name : .name name>string type space ; [THEN]
1.10 anton 32:
1.1 anton 33: decimal
34:
35: \ Screen format words 16may93jaw
36:
37: VARIABLE C-Output 1 C-Output !
38: VARIABLE C-Formated 1 C-Formated !
39: VARIABLE C-Highlight 0 C-Highlight !
40: VARIABLE C-Clearline 0 C-Clearline !
41:
42: VARIABLE XPos
43: VARIABLE YPos
44: VARIABLE Level
45:
46: : Format C-Formated @ C-Output @ and
47: IF dup spaces XPos +! ELSE drop THEN ;
48:
49: : level+ 7 Level +!
50: Level @ XPos @ -
51: dup 0> IF Format ELSE drop THEN ;
52:
53: : level- -7 Level +! ;
54:
55: VARIABLE nlflag
1.15 pazsan 56: VARIABLE uppercase \ structure words are in uppercase
1.1 anton 57:
58: DEFER nlcount ' noop IS nlcount
59:
60: : nl nlflag on ;
61: : (nl) nlcount
1.18 jwilke 62: XPos @ Level @ = IF EXIT THEN \ ?Exit
1.1 anton 63: C-Formated @ IF
64: C-Output @
1.10 anton 65: IF C-Clearline @ IF cols XPos @ - spaces
1.1 anton 66: ELSE cr THEN
67: 1 YPos +! 0 XPos !
68: Level @ spaces
69: THEN Level @ XPos ! THEN ;
70:
71: : warp? ( len -- len )
72: nlflag @ IF (nl) nlflag off THEN
1.10 anton 73: XPos @ over + cols u>= IF (nl) THEN ;
1.1 anton 74:
1.22 crook 75: : c-to-upper ( c1 -- c2 ) \ gforth
76: \ nac05feb1999 there is a primitive, toupper, with this function
77: dup [char] a >= over [char] z <= and if bl - then ;
1.15 pazsan 78:
1.1 anton 79: : ctype ( adr len -- )
1.15 pazsan 80: warp? dup XPos +! C-Output @
81: IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP
82: uppercase off ELSE type THEN
83: ELSE 2drop THEN ;
1.1 anton 84:
85: : cemit 1 warp?
86: over bl = Level @ XPos @ = and
87: IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
88: THEN ;
89:
90: DEFER .string
91:
92: [IFDEF] Green
93: VARIABLE Colors Colors on
94:
95: : (.string) ( c-addr u n -- )
96: over warp? drop
97: Colors @
98: IF C-Highlight @ ?dup
99: IF CT@ swap CT@ or
100: ELSE CT@
101: THEN
102: attr! ELSE drop THEN
103: ctype ct @ attr! ;
104: [ELSE]
105: : (.string) ( c-addr u n -- )
106: drop ctype ;
107: [THEN]
108:
109: ' (.string) IS .string
110:
111:
1.15 pazsan 112: : .struc
113: uppercase on Str# .string ;
1.1 anton 114:
1.17 jwilke 115: \ CODES (Branchtypes) 15may93jaw
1.1 anton 116:
117: 21 CONSTANT RepeatCode
118: 22 CONSTANT AgainCode
119: 23 CONSTANT UntilCode
120: \ 09 CONSTANT WhileCode
121: 10 CONSTANT ElseCode
122: 11 CONSTANT AheadCode
123: 13 CONSTANT WhileCode2
124: 14 CONSTANT Disable
1.17 jwilke 125: 15 CONSTANT LeaveCode
126:
1.1 anton 127:
128: \ FORMAT WORDS 13jun93jaw
129:
130: VARIABLE C-Stop
131: VARIABLE Branches
132:
1.17 jwilke 133: VARIABLE BranchPointer \ point to the end of branch table
1.1 anton 134: VARIABLE SearchPointer
1.17 jwilke 135:
136: \ The branchtable consists of three entrys:
137: \ address of branch , branch destination , branch type
138:
1.1 anton 139: CREATE BranchTable 500 allot
140: here 3 cells -
141: ACONSTANT MaxTable
142:
143: : FirstBranch BranchTable cell+ SearchPointer ! ;
144:
1.17 jwilke 145: : (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
146: \ searches a branch with destination a-addr1
147: \ a-addr1: branch destination
148: \ a-addr2: pointer in branch table
1.1 anton 149: SearchPointer @
150: BEGIN dup BranchPointer @ u<
151: WHILE
152: dup @ 2 pick <>
153: WHILE 3 cells +
154: REPEAT
155: nip dup 3 cells + SearchPointer ! true
156: ELSE
157: 2drop false
158: THEN ;
159:
160: : BranchAddr?
161: FirstBranch (BranchAddr?) ;
162:
163: ' (BranchAddr?) ALIAS MoreBranchAddr?
164:
165: : CheckEnd ( a-addr -- true | false )
166: BranchTable cell+
167: BEGIN dup BranchPointer @ u<
168: WHILE
169: dup @ 2 pick u<=
170: WHILE 3 cells +
171: REPEAT
172: 2drop false
173: ELSE
174: 2drop true
175: THEN ;
176:
1.17 jwilke 177: : MyBranch ( a-addr -- a-addr a-addr2 )
178: \ finds branch table entry for branch at a-addr
179: dup @ over +
180: BranchAddr?
181: BEGIN
182: WHILE 1 cells - @
183: over <>
184: WHILE dup @ over +
185: MoreBranchAddr?
186: REPEAT
187: SearchPointer @ 3 cells -
188: ELSE true ABORT" SEE: Table failure"
189: THEN ;
190:
1.1 anton 191: \
192: \ addrw addrt
193: \ BEGIN ... WHILE ... AGAIN ... THEN
194: \ ^ ! ! ^
195: \ ----------+--------+ !
196: \ ! !
197: \ +-------------------+
198: \
199: \
200:
201: : CheckWhile ( a-addrw a-addrt -- true | false )
202: BranchTable
203: BEGIN dup BranchPointer @ u<
204: WHILE dup @ 3 pick u>
205: over @ 3 pick u< and
206: IF dup cell+ @ 3 pick u<
207: IF 2drop drop true EXIT THEN
208: THEN
209: 3 cells +
210: REPEAT
211: 2drop drop false ;
212:
213: : ,Branch ( a-addr -- )
214: BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
215: !
216: 1 cells BranchPointer +! ;
217:
218: : Type! ( u -- )
219: BranchPointer @ 1 cells - ! ;
220:
221: : Branch! ( a-addr rel -- a-addr )
222: over + over ,Branch ,Branch 0 ,Branch ;
223:
224: \ DEFER CheckUntil
225: VARIABLE NoOutput
226: VARIABLE C-Pass
227:
228: 0 CONSTANT ScanMode
229: 1 CONSTANT DisplayMode
230: 2 CONSTANT DebugMode
231:
232: : Scan? ( -- flag ) C-Pass @ 0= ;
233: : Display? ( -- flag ) C-Pass @ 1 = ;
234: : Debug? ( -- flag ) C-Pass @ 2 = ;
235:
236: : back? ( n -- flag ) 0< ;
237: : ahead? ( n -- flag ) 0> ;
238:
239: : c-lit
1.8 pazsan 240: Display? IF
241: dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
242: THEN
243: cell+ ;
244:
1.18 jwilke 245: : .name-without ( addr -- addr )
246: \ prints a name without () e.g. (+LOOP) or (s")
247: dup 1 cells - @ look
248: IF name>string over c@ '( = IF 1 /string THEN
249: 2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
250: THEN ;
1.1 anton 251:
252: : c-c"
1.18 jwilke 253: Display? IF nl .name-without THEN
1.1 anton 254: count 2dup + aligned -rot
255: Display?
1.18 jwilke 256: IF bl cemit 0 .string
1.1 anton 257: [char] " cemit bl cemit
258: ELSE 2drop
259: THEN ;
260:
261:
1.17 jwilke 262: : Forward? ( a-addr true | false -- a-addr true | false )
263: \ a-addr1 is pointer into branch table
264: \ returns true when jump is a forward jump
1.1 anton 265: IF dup dup @ swap 1 cells - @ -
266: Ahead? IF true ELSE drop false THEN
267: \ only if forward jump
268: ELSE false THEN ;
269:
1.17 jwilke 270: : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
1.1 anton 271: IF BEGIN 2dup
272: 1 cells - @ swap dup @ +
273: u<=
274: WHILE drop dup cell+
275: MoreBranchAddr? 0=
276: UNTIL false
277: ELSE true
278: THEN
279: ELSE false
280: THEN ;
281:
282: : c-branch
283: Scan?
284: IF dup @ Branch!
285: dup @ back?
286: IF \ might be: AGAIN, REPEAT
287: dup cell+ BranchAddr? Forward?
288: RepeatCheck
289: IF RepeatCode Type!
290: cell+ Disable swap !
291: ELSE AgainCode Type!
292: THEN
293: ELSE dup cell+ BranchAddr? Forward?
294: IF ElseCode Type! drop
295: ELSE AheadCode Type!
296: THEN
297: THEN
298: THEN
299: Display?
300: IF
301: dup @ back?
302: IF \ might be: AGAIN, REPEAT
303: level- nl
304: dup cell+ BranchAddr? Forward?
305: RepeatCheck
306: IF drop S" REPEAT " .struc nl
307: ELSE S" AGAIN " .struc nl
308: THEN
1.17 jwilke 309: ELSE MyBranch cell+ @ LeaveCode =
310: IF S" LEAVE " .struc
311: ELSE
312: dup cell+ BranchAddr? Forward?
313: IF dup cell+ @ WhileCode2 =
314: IF nl S" ELSE" .struc level+
315: ELSE level- nl S" ELSE" .struc level+ THEN
316: cell+ Disable swap !
317: ELSE S" AHEAD" .struc level+
318: THEN
319: THEN
1.1 anton 320: THEN
321: THEN
322: Debug?
323: IF dup @ +
324: ELSE cell+
325: THEN ;
326:
327: : DebugBranch
328: Debug?
329: IF dup @ over + swap THEN ; \ return 2 different addresses
330:
331: : c-?branch
332: Scan?
333: IF dup @ Branch!
334: dup @ Back?
335: IF UntilCode Type! THEN
336: THEN
337: Display?
338: IF dup @ Back?
339: IF level- nl S" UNTIL " .struc nl
340: ELSE dup dup @ over +
341: CheckWhile
342: IF MyBranch
343: cell+ dup @ 0=
344: IF WhileCode2 swap !
345: ELSE drop THEN
346: level- nl
1.8 pazsan 347: S" WHILE " .struc
1.1 anton 348: level+
1.17 jwilke 349: ELSE MyBranch cell+ @ LeaveCode =
350: IF s" 0= ?LEAVE " .struc
351: ELSE nl S" IF " .struc level+
352: THEN
1.1 anton 353: THEN
354: THEN
355: THEN
356: DebugBranch
357: cell+ ;
358:
359: : c-for
360: Display? IF nl S" FOR" .struc level+ THEN ;
361:
362: : c-loop
1.15 pazsan 363: Display? IF level- nl .name-without bl cemit nl THEN
1.17 jwilke 364: DebugBranch cell+
365: Scan?
366: IF dup BranchAddr?
367: BEGIN WHILE cell+ LeaveCode swap !
368: dup MoreBranchAddr?
369: REPEAT
370: THEN
371: cell+ ;
1.1 anton 372:
1.15 pazsan 373: : c-do
374: Display? IF nl .name-without level+ THEN ;
1.1 anton 375:
1.15 pazsan 376: : c-?do
377: Display? IF nl S" ?DO" .struc level+ THEN
378: DebugBranch cell+ ;
1.8 pazsan 379:
1.1 anton 380: : c-exit dup 1 cells -
381: CheckEnd
382: IF Display? IF nlflag off S" ;" Com# .string THEN
383: C-Stop on
384: ELSE Display? IF S" EXIT " .struc THEN
385: THEN
386: Debug? IF drop THEN ;
387:
388: : c-abort"
389: count 2dup + aligned -rot
390: Display?
391: IF S" ABORT" .struc
392: [char] " cemit bl cemit 0 .string
393: [char] " cemit bl cemit
394: ELSE 2drop
395: THEN ;
396:
1.23 ! jwilke 397: [IFDEF] (does>)
! 398: : c-does> \ end of create part
! 399: Display? IF S" DOES> " Com# .string THEN
! 400: maxaligned /does-handler + ;
! 401: [THEN]
! 402:
! 403: [IFDEF] (compile)
! 404: : c-(compile)
! 405: Display?
! 406: IF
! 407: s" POSTPONE " Com# .string
! 408: dup @ look 0= ABORT" SEE: No valid XT"
! 409: name>string 0 .string bl cemit
! 410: THEN
! 411: cell+ ;
! 412: [THEN]
1.1 anton 413:
414: CREATE C-Table
1.18 jwilke 415: ' lit A, ' c-lit A,
416: ' (s") A, ' c-c" A,
417: ' (.") A, ' c-c" A,
418: ' "lit A, ' c-c" A,
419: [IFDEF] (c") ' (c") A, ' c-c" A, [THEN]
420: ' (do) A, ' c-do A,
421: [IFDEF] (+do) ' (+do) A, ' c-do A, [THEN]
422: [IFDEF] (u+do) ' (u+do) A, ' c-do A, [THEN]
423: [IFDEF] (-do) ' (-do) A, ' c-do A, [THEN]
424: [IFDEF] (u-do) ' (u-do) A, ' c-do A, [THEN]
425: ' (?do) A, ' c-?do A,
426: ' (for) A, ' c-for A,
427: ' ?branch A, ' c-?branch A,
428: ' branch A, ' c-branch A,
429: ' (loop) A, ' c-loop A,
430: ' (+loop) A, ' c-loop A,
431: [IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN]
432: [IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]
433: ' (next) A, ' c-loop A,
434: ' ;s A, ' c-exit A,
435: ' (abort") A, ' c-abort" A,
1.23 ! jwilke 436: \ only defined if compiler is loaded
! 437: [IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN]
! 438: [IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN]
1.18 jwilke 439: 0 , here 0 ,
1.15 pazsan 440:
441: avariable c-extender
442: c-extender !
1.1 anton 443:
444: \ DOTABLE 15may93jaw
445:
446: : DoTable ( cfa -- flag )
447: C-Table
1.15 pazsan 448: BEGIN dup @ dup 0=
449: IF drop cell+ @ dup
450: IF ( next table!) dup @ ELSE
451: ( end!) 2drop false EXIT THEN
452: THEN
453: \ jump over to extender, if any 26jan97jaw
454: 2 pick <>
1.1 anton 455: WHILE 2 cells +
456: REPEAT
1.11 anton 457: nip cell+ perform
1.1 anton 458: true
1.15 pazsan 459: ;
1.1 anton 460:
461: : BranchTo? ( a-addr -- a-addr )
1.17 jwilke 462: Display? IF dup BranchAddr?
1.15 pazsan 463: IF
464: BEGIN cell+ @ dup 20 u>
1.1 anton 465: IF drop nl S" BEGIN " .struc level+
466: ELSE
1.17 jwilke 467: dup Disable <> over LeaveCode <> and
1.1 anton 468: IF WhileCode2 =
469: IF nl S" THEN " .struc nl ELSE
470: level- nl S" THEN " .struc nl THEN
471: ELSE drop THEN
472: THEN
473: dup MoreBranchAddr? 0=
474: UNTIL
475: THEN
476: THEN ;
477:
478: : analyse ( a-addr1 -- a-addr2 )
479: Branches @ IF BranchTo? THEN
480: dup cell+ swap @
481: dup >r DoTable r> swap IF drop EXIT THEN
482: Display?
1.3 pazsan 483: IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
1.16 anton 484: ELSE
485: dup cell+ count dup immediate-mask and
486: IF bl cemit ." POSTPONE " THEN
487: 31 and rot wordinfo .string THEN bl cemit
1.1 anton 488: ELSE drop
489: THEN ;
490:
491: : c-init
492: 0 YPos ! 0 XPos !
493: 0 Level ! nlflag off
494: BranchTable BranchPointer !
495: c-stop off
496: Branches on ;
497:
498: : makepass ( a-addr -- )
1.14 anton 499: c-stop off
500: BEGIN
501: analyse
502: c-stop @
503: UNTIL drop ;
504:
505: Defer xt-see-xt ( xt -- )
506: \ this one is just a forward declaration for indirect recursion
507:
508: : .defname ( xt c-addr u -- )
509: rot look
510: if ( c-addr u nfa )
511: -rot type space .name
512: else
513: drop ." noname " type
514: then
515: space ;
516:
517: Defer discode ( addr -- )
518: \ hook for the disassembler: disassemble code at addr (as far as the
519: \ disassembler thinks is sensible)
520: :noname ( addr -- )
521: drop ." ..." ;
522: IS discode
523:
524: : seecode ( xt -- )
525: dup s" Code" .defname
1.19 anton 526: threading-method
527: if
528: >code-address
529: then
530: discode
1.14 anton 531: ." end-code" cr ;
532: : seevar ( xt -- )
533: s" Variable" .defname cr ;
534: : seeuser ( xt -- )
535: s" User" .defname cr ;
536: : seecon ( xt -- )
537: dup >body ?
538: s" Constant" .defname cr ;
539: : seevalue ( xt -- )
540: dup >body ?
541: s" Value" .defname cr ;
542: : seedefer ( xt -- )
543: dup >body @ xt-see-xt cr
544: dup s" Defer" .defname cr
545: >name dup ??? = if
546: drop ." lastxt >body !"
547: else
548: ." IS " .name cr
549: then ;
550: : see-threaded ( addr -- )
551: C-Pass @ DebugMode = IF
552: ScanMode c-pass !
553: EXIT
1.10 anton 554: THEN
555: ScanMode c-pass ! dup makepass
556: DisplayMode c-pass ! makepass ;
1.14 anton 557: : seedoes ( xt -- )
558: dup s" create" .defname cr
559: S" DOES> " Com# .string XPos @ Level !
560: >does-code see-threaded ;
561: : seecol ( xt -- )
1.15 pazsan 562: dup s" :" .defname nl
1.14 anton 563: 2 Level !
564: >body see-threaded ;
565: : seefield ( xt -- )
566: dup >body ." 0 " ? ." 0 0 "
567: s" Field" .defname cr ;
568:
569: : xt-see ( xt -- )
570: cr c-init
571: dup >does-code
572: if
573: seedoes EXIT
574: then
1.18 jwilke 575: dup xtprim?
1.14 anton 576: if
577: seecode EXIT
578: then
579: dup >code-address
580: CASE
581: docon: of seecon endof
582: docol: of seecol endof
583: dovar: of seevar endof
1.18 jwilke 584: [ [IFDEF] douser: ]
1.14 anton 585: douser: of seeuser endof
1.18 jwilke 586: [ [THEN] ]
587: [ [IFDEF] dodefer: ]
1.14 anton 588: dodefer: of seedefer endof
1.18 jwilke 589: [ [THEN] ]
590: [ [IFDEF] dofield: ]
1.14 anton 591: dofield: of seefield endof
1.18 jwilke 592: [ [THEN] ]
1.14 anton 593: over >body of seecode endof
594: 2drop abort" unknown word type"
595: ENDCASE ;
596:
597: : (xt-see-xt) ( xt -- )
598: xt-see cr ." lastxt" ;
599: ' (xt-see-xt) is xt-see-xt
600:
601: : (.immediate) ( xt -- )
602: ['] execute = if
603: ." immediate"
604: then ;
605:
606: : name-see ( nfa -- )
607: dup name>int >r
608: dup name>comp
609: over r@ =
610: if \ normal or immediate word
611: swap xt-see (.immediate)
612: else
613: r@ ['] compile-only-error =
614: if \ compile-only word
615: swap xt-see (.immediate) ." compile-only"
616: else \ interpret/compile word
617: r@ xt-see-xt cr
618: swap xt-see-xt cr
619: ." interpret/compile " over .name (.immediate)
620: then
621: then
622: rdrop drop ;
1.3 pazsan 623:
1.21 crook 624: : see ( "<spaces>name" -- ) \ tools
625: \G Locate @var{name} using the current search order. Display the
626: \G definition of @var{name}. Since this is achieved by decompiling
627: \G the definition, the formatting is mechanised and some source
628: \G information (comments, interpreted sequences within definitions
629: \G etc.) is lost.
1.13 anton 630: name find-name dup 0=
631: IF
632: drop -&13 bounce
633: THEN
1.14 anton 634: name-see ;
1.1 anton 635:
636:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>