[gforth] / gforth / see.fs  

gforth: gforth/see.fs

1 : anton 1.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 : pazsan 1.2 ' ;s A, ' c-exit A,
390 : anton 1.1 ' (;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 : pazsan 1.3 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 : anton 1.1 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 : pazsan 1.3 dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
469 : anton 1.1 ( 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 : pazsan 1.3 dup dup cell+ c@ 32 and IF over .name ." is an immediate word" cr THEN
488 : anton 1.1 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 : pazsan 1.3
504 :     : see name find 0= IF ." Word unknown" cr drop exit THEN
505 :     xtc ;
506 : anton 1.1
507 :     : lfc cr c-init cell+ dosee ;
508 :     : nfc cr c-init dosee ;
509 :    
510 :    
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help