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