File:
[gforth] /
gforth /
see.fs
Revision
1.3:
download - view:
text,
annotated -
select for diffs
Wed Jul 13 19:21:08 1994 UTC (29 years, 8 months ago) by
pazsan
Branches:
MAIN
CVS tags:
HEAD
Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).
Added restrict's functionalitz to cross.fs
removed all occurency of cell+ name>, because the bug in name> is
fixed.
Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.
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,
389: ' ;s A, ' c-exit A,
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= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
431: ELSE dup cell+ count 31 and rot wordinfo .string THEN 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: dup cell+ 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 dup cell+ 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: : xtc ( xt -- ) \ do see at xt
500: Look 0= ABORT" SEE: No valid XT"
501: cr c-init
502: dosee ;
503:
504: : see name find 0= IF ." Word unknown" cr drop exit THEN
505: xtc ;
506:
507: : lfc cr c-init cell+ dosee ;
508: : nfc cr c-init dosee ;
509:
510:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>