File:
[gforth] /
gforth /
see.fs
Revision
1.22:
download - view:
text,
annotated -
select for diffs
Tue Feb 16 06:32:30 1999 UTC (25 years, 2 months ago) by
crook
Branches:
MAIN
CVS tags:
HEAD
-Added my name to the ToDo file under documentation
-Glossed the oof files
-Minor glossary additions elsewhere
-Another set of changes to gforth.ds; mainly the addition of material
to the introductory chapter. Also, re-organised stuff in the oof
sections and made a typo pass over a few other bits.
1: \ SEE.FS highend SEE for ANSforth 16may93jaw
2:
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:
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 : .name name>string type space ; [THEN]
32:
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
56: VARIABLE uppercase \ structure words are in uppercase
57:
58: DEFER nlcount ' noop IS nlcount
59:
60: : nl nlflag on ;
61: : (nl) nlcount
62: XPos @ Level @ = IF EXIT THEN \ ?Exit
63: C-Formated @ IF
64: C-Output @
65: IF C-Clearline @ IF cols XPos @ - spaces
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
73: XPos @ over + cols u>= IF (nl) THEN ;
74:
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 ;
78:
79: : ctype ( adr len -- )
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 ;
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:
112: : .struc
113: uppercase on Str# .string ;
114:
115: \ CODES (Branchtypes) 15may93jaw
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
125: 15 CONSTANT LeaveCode
126:
127:
128: \ FORMAT WORDS 13jun93jaw
129:
130: VARIABLE C-Stop
131: VARIABLE Branches
132:
133: VARIABLE BranchPointer \ point to the end of branch table
134: VARIABLE SearchPointer
135:
136: \ The branchtable consists of three entrys:
137: \ address of branch , branch destination , branch type
138:
139: CREATE BranchTable 500 allot
140: here 3 cells -
141: ACONSTANT MaxTable
142:
143: : FirstBranch BranchTable cell+ SearchPointer ! ;
144:
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
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:
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:
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-(compile)
240: Display?
241: IF
242: s" POSTPONE " Com# .string
243: dup @ look 0= ABORT" SEE: No valid XT"
244: name>string 0 .string bl cemit
245: THEN
246: cell+ ;
247:
248: : c-lit
249: Display? IF
250: dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
251: THEN
252: cell+ ;
253:
254: : .name-without ( addr -- addr )
255: \ prints a name without () e.g. (+LOOP) or (s")
256: dup 1 cells - @ look
257: IF name>string over c@ '( = IF 1 /string THEN
258: 2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
259: THEN ;
260:
261: : c-c"
262: Display? IF nl .name-without THEN
263: count 2dup + aligned -rot
264: Display?
265: IF bl cemit 0 .string
266: [char] " cemit bl cemit
267: ELSE 2drop
268: THEN ;
269:
270:
271: : Forward? ( a-addr true | false -- a-addr true | false )
272: \ a-addr1 is pointer into branch table
273: \ returns true when jump is a forward jump
274: IF dup dup @ swap 1 cells - @ -
275: Ahead? IF true ELSE drop false THEN
276: \ only if forward jump
277: ELSE false THEN ;
278:
279: : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
280: IF BEGIN 2dup
281: 1 cells - @ swap dup @ +
282: u<=
283: WHILE drop dup cell+
284: MoreBranchAddr? 0=
285: UNTIL false
286: ELSE true
287: THEN
288: ELSE false
289: THEN ;
290:
291: : c-branch
292: Scan?
293: IF dup @ Branch!
294: dup @ back?
295: IF \ might be: AGAIN, REPEAT
296: dup cell+ BranchAddr? Forward?
297: RepeatCheck
298: IF RepeatCode Type!
299: cell+ Disable swap !
300: ELSE AgainCode Type!
301: THEN
302: ELSE dup cell+ BranchAddr? Forward?
303: IF ElseCode Type! drop
304: ELSE AheadCode Type!
305: THEN
306: THEN
307: THEN
308: Display?
309: IF
310: dup @ back?
311: IF \ might be: AGAIN, REPEAT
312: level- nl
313: dup cell+ BranchAddr? Forward?
314: RepeatCheck
315: IF drop S" REPEAT " .struc nl
316: ELSE S" AGAIN " .struc nl
317: THEN
318: ELSE MyBranch cell+ @ LeaveCode =
319: IF S" LEAVE " .struc
320: ELSE
321: dup cell+ BranchAddr? Forward?
322: IF dup cell+ @ WhileCode2 =
323: IF nl S" ELSE" .struc level+
324: ELSE level- nl S" ELSE" .struc level+ THEN
325: cell+ Disable swap !
326: ELSE S" AHEAD" .struc level+
327: THEN
328: THEN
329: THEN
330: THEN
331: Debug?
332: IF dup @ +
333: ELSE cell+
334: THEN ;
335:
336: : DebugBranch
337: Debug?
338: IF dup @ over + swap THEN ; \ return 2 different addresses
339:
340: : c-?branch
341: Scan?
342: IF dup @ Branch!
343: dup @ Back?
344: IF UntilCode Type! THEN
345: THEN
346: Display?
347: IF dup @ Back?
348: IF level- nl S" UNTIL " .struc nl
349: ELSE dup dup @ over +
350: CheckWhile
351: IF MyBranch
352: cell+ dup @ 0=
353: IF WhileCode2 swap !
354: ELSE drop THEN
355: level- nl
356: S" WHILE " .struc
357: level+
358: ELSE MyBranch cell+ @ LeaveCode =
359: IF s" 0= ?LEAVE " .struc
360: ELSE nl S" IF " .struc level+
361: THEN
362: THEN
363: THEN
364: THEN
365: DebugBranch
366: cell+ ;
367:
368: : c-for
369: Display? IF nl S" FOR" .struc level+ THEN ;
370:
371: : c-loop
372: Display? IF level- nl .name-without bl cemit nl THEN
373: DebugBranch cell+
374: Scan?
375: IF dup BranchAddr?
376: BEGIN WHILE cell+ LeaveCode swap !
377: dup MoreBranchAddr?
378: REPEAT
379: THEN
380: cell+ ;
381:
382: : c-do
383: Display? IF nl .name-without level+ THEN ;
384:
385: : c-?do
386: Display? IF nl S" ?DO" .struc level+ THEN
387: DebugBranch cell+ ;
388:
389: : c-exit dup 1 cells -
390: CheckEnd
391: IF Display? IF nlflag off S" ;" Com# .string THEN
392: C-Stop on
393: ELSE Display? IF S" EXIT " .struc THEN
394: THEN
395: Debug? IF drop THEN ;
396:
397: : c-does> \ end of create part
398: Display? IF S" DOES> " Com# .string THEN
399: maxaligned /does-handler + ;
400:
401: : c-abort"
402: count 2dup + aligned -rot
403: Display?
404: IF S" ABORT" .struc
405: [char] " cemit bl cemit 0 .string
406: [char] " cemit bl cemit
407: ELSE 2drop
408: THEN ;
409:
410:
411: CREATE C-Table
412: ' lit A, ' c-lit A,
413: ' (s") A, ' c-c" A,
414: ' (.") A, ' c-c" A,
415: ' "lit A, ' c-c" A,
416: [IFDEF] (c") ' (c") A, ' c-c" A, [THEN]
417: ' (do) A, ' c-do A,
418: [IFDEF] (+do) ' (+do) A, ' c-do A, [THEN]
419: [IFDEF] (u+do) ' (u+do) A, ' c-do A, [THEN]
420: [IFDEF] (-do) ' (-do) A, ' c-do A, [THEN]
421: [IFDEF] (u-do) ' (u-do) A, ' c-do A, [THEN]
422: ' (?do) A, ' c-?do A,
423: ' (for) A, ' c-for A,
424: ' ?branch A, ' c-?branch A,
425: ' branch A, ' c-branch A,
426: ' (loop) A, ' c-loop A,
427: ' (+loop) A, ' c-loop A,
428: [IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN]
429: [IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]
430: ' (next) A, ' c-loop A,
431: ' ;s A, ' c-exit A,
432: ' (does>) A, ' c-does> A,
433: ' (abort") A, ' c-abort" A,
434: ' (compile) A, ' c-(compile) A,
435: 0 , here 0 ,
436:
437: avariable c-extender
438: c-extender !
439:
440: \ DOTABLE 15may93jaw
441:
442: : DoTable ( cfa -- flag )
443: C-Table
444: BEGIN dup @ dup 0=
445: IF drop cell+ @ dup
446: IF ( next table!) dup @ ELSE
447: ( end!) 2drop false EXIT THEN
448: THEN
449: \ jump over to extender, if any 26jan97jaw
450: 2 pick <>
451: WHILE 2 cells +
452: REPEAT
453: nip cell+ perform
454: true
455: ;
456:
457: : BranchTo? ( a-addr -- a-addr )
458: Display? IF dup BranchAddr?
459: IF
460: BEGIN cell+ @ dup 20 u>
461: IF drop nl S" BEGIN " .struc level+
462: ELSE
463: dup Disable <> over LeaveCode <> and
464: IF WhileCode2 =
465: IF nl S" THEN " .struc nl ELSE
466: level- nl S" THEN " .struc nl THEN
467: ELSE drop THEN
468: THEN
469: dup MoreBranchAddr? 0=
470: UNTIL
471: THEN
472: THEN ;
473:
474: : analyse ( a-addr1 -- a-addr2 )
475: Branches @ IF BranchTo? THEN
476: dup cell+ swap @
477: dup >r DoTable r> swap IF drop EXIT THEN
478: Display?
479: IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
480: ELSE
481: dup cell+ count dup immediate-mask and
482: IF bl cemit ." POSTPONE " THEN
483: 31 and rot wordinfo .string THEN bl cemit
484: ELSE drop
485: THEN ;
486:
487: : c-init
488: 0 YPos ! 0 XPos !
489: 0 Level ! nlflag off
490: BranchTable BranchPointer !
491: c-stop off
492: Branches on ;
493:
494: : makepass ( a-addr -- )
495: c-stop off
496: BEGIN
497: analyse
498: c-stop @
499: UNTIL drop ;
500:
501: Defer xt-see-xt ( xt -- )
502: \ this one is just a forward declaration for indirect recursion
503:
504: : .defname ( xt c-addr u -- )
505: rot look
506: if ( c-addr u nfa )
507: -rot type space .name
508: else
509: drop ." noname " type
510: then
511: space ;
512:
513: Defer discode ( addr -- )
514: \ hook for the disassembler: disassemble code at addr (as far as the
515: \ disassembler thinks is sensible)
516: :noname ( addr -- )
517: drop ." ..." ;
518: IS discode
519:
520: : seecode ( xt -- )
521: dup s" Code" .defname
522: threading-method
523: if
524: >code-address
525: then
526: discode
527: ." end-code" cr ;
528: : seevar ( xt -- )
529: s" Variable" .defname cr ;
530: : seeuser ( xt -- )
531: s" User" .defname cr ;
532: : seecon ( xt -- )
533: dup >body ?
534: s" Constant" .defname cr ;
535: : seevalue ( xt -- )
536: dup >body ?
537: s" Value" .defname cr ;
538: : seedefer ( xt -- )
539: dup >body @ xt-see-xt cr
540: dup s" Defer" .defname cr
541: >name dup ??? = if
542: drop ." lastxt >body !"
543: else
544: ." IS " .name cr
545: then ;
546: : see-threaded ( addr -- )
547: C-Pass @ DebugMode = IF
548: ScanMode c-pass !
549: EXIT
550: THEN
551: ScanMode c-pass ! dup makepass
552: DisplayMode c-pass ! makepass ;
553: : seedoes ( xt -- )
554: dup s" create" .defname cr
555: S" DOES> " Com# .string XPos @ Level !
556: >does-code see-threaded ;
557: : seecol ( xt -- )
558: dup s" :" .defname nl
559: 2 Level !
560: >body see-threaded ;
561: : seefield ( xt -- )
562: dup >body ." 0 " ? ." 0 0 "
563: s" Field" .defname cr ;
564:
565: : xt-see ( xt -- )
566: cr c-init
567: dup >does-code
568: if
569: seedoes EXIT
570: then
571: dup xtprim?
572: if
573: seecode EXIT
574: then
575: dup >code-address
576: CASE
577: docon: of seecon endof
578: docol: of seecol endof
579: dovar: of seevar endof
580: [ [IFDEF] douser: ]
581: douser: of seeuser endof
582: [ [THEN] ]
583: [ [IFDEF] dodefer: ]
584: dodefer: of seedefer endof
585: [ [THEN] ]
586: [ [IFDEF] dofield: ]
587: dofield: of seefield endof
588: [ [THEN] ]
589: over >body of seecode endof
590: 2drop abort" unknown word type"
591: ENDCASE ;
592:
593: : (xt-see-xt) ( xt -- )
594: xt-see cr ." lastxt" ;
595: ' (xt-see-xt) is xt-see-xt
596:
597: : (.immediate) ( xt -- )
598: ['] execute = if
599: ." immediate"
600: then ;
601:
602: : name-see ( nfa -- )
603: dup name>int >r
604: dup name>comp
605: over r@ =
606: if \ normal or immediate word
607: swap xt-see (.immediate)
608: else
609: r@ ['] compile-only-error =
610: if \ compile-only word
611: swap xt-see (.immediate) ." compile-only"
612: else \ interpret/compile word
613: r@ xt-see-xt cr
614: swap xt-see-xt cr
615: ." interpret/compile " over .name (.immediate)
616: then
617: then
618: rdrop drop ;
619:
620: : see ( "<spaces>name" -- ) \ tools
621: \G Locate @var{name} using the current search order. Display the
622: \G definition of @var{name}. Since this is achieved by decompiling
623: \G the definition, the formatting is mechanised and some source
624: \G information (comments, interpreted sequences within definitions
625: \G etc.) is lost.
626: name find-name dup 0=
627: IF
628: drop -&13 bounce
629: THEN
630: name-see ;
631:
632:
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