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