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