File:
[gforth] /
gforth /
see.fs
Revision
1.7:
download - view:
text,
annotated -
select for diffs
Sat Oct 7 17:38:19 1995 UTC (28 years, 6 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
added code.fs (code, ;code, end-code, assembler)
renamed dostruc to dofield
made index and doc-entries nicer
Only words containing 'e' or 'E' are converted to FP numbers.
added many wordset comments
added flush-icache primitive and FLUSH_ICACHE macro
added +DO, U+DO, -DO, U-DO and -LOOP
added code address labels (`docol:' etc.)
fixed sparc cache_flush
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-flit
195: Display? IF dup f@ scratch represent 0=
196: IF 2drop scratch 3 min 0 .string
197: ELSE IF '- cemit THEN 1-
198: scratch over c@ cemit '. cemit 1 /string 0 .string
199: 'E cemit
200: dup abs 0 <# #S rot sign #> 0 .string bl cemit
201: THEN THEN
202: float+ ;
203:
204: : c-s"
205: count 2dup + aligned -rot
206: Display?
207: IF [char] S cemit [char] " cemit bl cemit 0 .string
208: [char] " cemit bl cemit
209: ELSE 2drop
210: THEN ;
211:
212: : c-."
213: count 2dup + aligned -rot
214: Display?
215: IF [char] . cemit
216: [char] " cemit bl cemit 0 .string
217: [char] " cemit bl cemit
218: ELSE 2drop
219: THEN ;
220:
221: : c-c"
222: count 2dup + aligned -rot
223: Display?
224: IF [char] C cemit [char] " cemit bl cemit 0 .string
225: [char] " cemit bl cemit
226: ELSE 2drop
227: THEN ;
228:
229:
230: : Forward? ( a-addr true | false -- )
231: IF dup dup @ swap 1 cells - @ -
232: Ahead? IF true ELSE drop false THEN
233: \ only if forward jump
234: ELSE false THEN ;
235:
236: : RepeatCheck
237: IF BEGIN 2dup
238: 1 cells - @ swap dup @ +
239: u<=
240: WHILE drop dup cell+
241: MoreBranchAddr? 0=
242: UNTIL false
243: ELSE true
244: THEN
245: ELSE false
246: THEN ;
247:
248: : c-branch
249: Scan?
250: IF dup @ Branch!
251: dup @ back?
252: IF \ might be: AGAIN, REPEAT
253: dup cell+ BranchAddr? Forward?
254: RepeatCheck
255: IF RepeatCode Type!
256: cell+ Disable swap !
257: ELSE AgainCode Type!
258: THEN
259: ELSE dup cell+ BranchAddr? Forward?
260: IF ElseCode Type! drop
261: ELSE AheadCode Type!
262: THEN
263: THEN
264: THEN
265: Display?
266: IF
267: dup @ back?
268: IF \ might be: AGAIN, REPEAT
269: level- nl
270: dup cell+ BranchAddr? Forward?
271: RepeatCheck
272: IF drop S" REPEAT " .struc nl
273: ELSE S" AGAIN " .struc nl
274: THEN
275: ELSE dup cell+ BranchAddr? Forward?
276: IF dup cell+ @ WhileCode2 =
277: IF nl S" ELSE" .struc level+
278: ELSE level- nl S" ELSE" .struc level+ THEN
279: cell+ Disable swap !
280: ELSE S" AHEAD" .struc level+
281: THEN
282: THEN
283: THEN
284: Debug?
285: IF dup @ +
286: ELSE cell+
287: THEN ;
288:
289: : MyBranch ( a-addr -- a-addr a-addr2 )
290: dup @ over +
291: BranchAddr?
292: BEGIN
293: WHILE 1 cells - @
294: over <>
295: WHILE dup @ over +
296: MoreBranchAddr?
297: REPEAT
298: SearchPointer @ 3 cells -
299: ELSE true ABORT" SEE: Table failure"
300: THEN ;
301:
302: : DebugBranch
303: Debug?
304: IF dup @ over + swap THEN ; \ return 2 different addresses
305:
306: : c-?branch
307: Scan?
308: IF dup @ Branch!
309: dup @ Back?
310: IF UntilCode Type! THEN
311: THEN
312: Display?
313: IF dup @ Back?
314: IF level- nl S" UNTIL " .struc nl
315: ELSE dup dup @ over +
316: CheckWhile
317: IF MyBranch
318: cell+ dup @ 0=
319: IF WhileCode2 swap !
320: ELSE drop THEN
321: level- nl
322: S" WHILE" .struc
323: level+
324: ELSE nl S" IF" .struc level+
325: THEN
326: THEN
327: THEN
328: DebugBranch
329: cell+ ;
330:
331: : c-do
332: Display? IF nl S" DO" .struc level+ THEN ;
333:
334: : c-?do
335: Display? IF nl S" ?DO" .struc level+ THEN
336: DebugBranch cell+ ;
337:
338: : c-for
339: Display? IF nl S" FOR" .struc level+ THEN ;
340:
341: : c-next
342: Display? IF level- nl S" NEXT " .struc nl THEN
343: DebugBranch cell+ cell+ ;
344:
345: : c-loop
346: Display? IF level- nl S" LOOP " .struc nl THEN
347: DebugBranch cell+ cell+ ;
348:
349:
350: : c-+loop
351: Display? IF level- nl S" +LOOP " .struc nl THEN
352: DebugBranch cell+ cell+ ;
353:
354: : c-leave
355: Display? IF S" LEAVE " .struc THEN
356: Debug? IF dup @ + THEN cell+ ;
357:
358: : c-?leave
359: Display? IF S" ?LEAVE " .struc THEN
360: cell+ DebugBranch swap cell+ swap cell+ ;
361:
362: : c-exit dup 1 cells -
363: CheckEnd
364: IF Display? IF nlflag off S" ;" Com# .string THEN
365: C-Stop on
366: ELSE Display? IF S" EXIT " .struc THEN
367: THEN
368: Debug? IF drop THEN ;
369:
370: : c-does> \ end of create part
371: Display? IF S" DOES> " Com# .string THEN
372: Cell+ cell+ ;
373:
374: : c-abort"
375: count 2dup + aligned -rot
376: Display?
377: IF S" ABORT" .struc
378: [char] " cemit bl cemit 0 .string
379: [char] " cemit bl cemit
380: ELSE 2drop
381: THEN ;
382:
383:
384: CREATE C-Table
385: ' lit A, ' c-lit A,
386: ' flit A, ' c-flit A,
387: ' (s") A, ' c-s" A,
388: ' (.") A, ' c-." A,
389: ' "lit A, ' c-c" A,
390: ' ?branch A, ' c-?branch A,
391: ' branch A, ' c-branch A,
392: ' leave A, ' c-leave A,
393: ' ?leave A, ' c-?leave A,
394: ' (do) A, ' c-do A,
395: ' (?do) A, ' c-?do A,
396: ' (for) A, ' c-for A,
397: ' (loop) A, ' c-loop A,
398: ' (+loop) A, ' c-+loop A,
399: ' (next) A, ' c-next A,
400: ' ;s A, ' c-exit A,
401: ' (does>) A, ' c-does> A,
402: ' (abort") A, ' c-abort" A,
403: ' (compile) A, ' c-(compile) A,
404: 0 ,
405:
406: \ DOTABLE 15may93jaw
407:
408: : DoTable ( cfa -- flag )
409: C-Table
410: BEGIN dup @ dup
411: WHILE 2 pick <>
412: WHILE 2 cells +
413: REPEAT
414: nip cell+ @ EXECUTE
415: true
416: ELSE
417: 2drop drop false
418: THEN ;
419:
420: : BranchTo? ( a-addr -- a-addr )
421: Display? IF dup BranchAddr?
422: IF BEGIN cell+ @ dup 20 u>
423: IF drop nl S" BEGIN " .struc level+
424: ELSE
425: dup Disable <>
426: IF WhileCode2 =
427: IF nl S" THEN " .struc nl ELSE
428: level- nl S" THEN " .struc nl THEN
429: ELSE drop THEN
430: THEN
431: dup MoreBranchAddr? 0=
432: UNTIL
433: THEN
434: THEN ;
435:
436: : analyse ( a-addr1 -- a-addr2 )
437: Branches @ IF BranchTo? THEN
438: dup cell+ swap @
439: dup >r DoTable r> swap IF drop EXIT THEN
440: Display?
441: IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
442: ELSE dup cell+ count 31 and rot wordinfo .string THEN bl cemit
443: ELSE drop
444: THEN ;
445:
446: : c-init
447: 0 YPos ! 0 XPos !
448: 0 Level ! nlflag off
449: BranchTable BranchPointer !
450: c-stop off
451: Branches on ;
452:
453: : makepass ( a-addr -- )
454: c-stop off
455: BEGIN
456: analyse
457: c-stop @
458: UNTIL drop ;
459:
460: DEFER dosee
461:
462: : dopri .name ." is primitive" cr ;
463: : dovar ." Variable " .name cr ;
464: : douse ." User " .name cr ;
465: : docon dup cell+ (name>) >body @ . ." Constant " .name cr ;
466: : doval dup cell+ (name>) >body @ . ." Value " .name cr ;
467: : dodef ." Defer " dup >r .name cr
468: here @ look 0= ABORT" SEE: No valid xt in defered word"
469: here @ look drop dosee cr
470: ." ' " .name r> ." IS " .name cr ;
471: : dodoe ." Create " dup .name cr
472: S" DOES> " Com# .string XPos @ Level ! name>
473: >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
474: ScanMode c-pass ! dup makepass
475: DisplayMode c-pass ! makepass ;
476: : doali here @ .name ." Alias " .name cr
477: here @ dosee ;
478: : docol S" : " Com# .string
479: dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
480: ( XPos @ ) 2 Level !
481: name> >body
482: C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
483: ScanMode c-pass ! dup makepass
484: DisplayMode c-pass ! makepass ;
485:
486: create wordtypes
487: Pri# , ' dopri A,
488: Var# , ' dovar A,
489: Con# , ' docon A,
490: Val# , ' doval A,
491: Def# , ' dodef A,
492: Doe# , ' dodoe A,
493: Ali# , ' doali A,
494: Col# , ' docol A,
495: Use# , ' douse A,
496: 0 ,
497:
498: : (dosee) ( lfa -- )
499: dup dup cell+ c@ >r
500: wordinfo
501: wordtypes
502: BEGIN dup @ dup
503: WHILE 2 pick = IF cell+ @ nip EXECUTE
504: r> dup 32 and IF ." immediate" THEN
505: 64 and IF ." restrict" THEN EXIT THEN
506: 2 cells +
507: REPEAT
508: 2drop rdrop
509: .name ." Don't know how to handle" cr ;
510:
511: ' (dosee) IS dosee
512:
513: : xtc ( xt -- ) \ do see at xt
514: Look 0= ABORT" SEE: No valid XT"
515: cr c-init
516: dosee ;
517:
518: : see name sfind 0= IF ." Word unknown" cr exit THEN
519: xtc ;
520:
521: : lfc cr c-init cell+ dosee ;
522: : nfc cr c-init dosee ;
523:
524:
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