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