[gforth] / gforth / see.fs  

gforth: gforth/see.fs

1 : anton 1.1 \ SEE.FS highend SEE for ANSforth 16may93jaw
2 :    
3 : anton 1.9 \ Copyright (C) 1995 Free Software Foundation, Inc.
4 :    
5 :     \ This file is part of Gforth.
6 :    
7 :     \ Gforth is free software; you can redistribute it and/or
8 :     \ modify it under the terms of the GNU General Public License
9 :     \ as published by the Free Software Foundation; either version 2
10 :     \ of the License, or (at your option) any later version.
11 :    
12 :     \ This program is distributed in the hope that it will be useful,
13 :     \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     \ GNU General Public License for more details.
16 :    
17 :     \ You should have received a copy of the GNU General Public License
18 :     \ along with this program; if not, write to the Free Software
19 :     \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 :    
21 :    
22 : anton 1.1 \ May be cross-compiled
23 :    
24 :     \ I'm sorry. This is really not "forthy" enough.
25 :    
26 :     \ Ideas: Level should be a stack
27 :    
28 :     decimal
29 :    
30 :     \ Screen format words 16may93jaw
31 :    
32 :     VARIABLE C-Output 1 C-Output !
33 :     VARIABLE C-Formated 1 C-Formated !
34 :     VARIABLE C-Highlight 0 C-Highlight !
35 :     VARIABLE C-Clearline 0 C-Clearline !
36 :    
37 :     VARIABLE XPos
38 :     VARIABLE YPos
39 :     VARIABLE Level
40 :    
41 :     : Format C-Formated @ C-Output @ and
42 :     IF dup spaces XPos +! ELSE drop THEN ;
43 :    
44 :     : level+ 7 Level +!
45 :     Level @ XPos @ -
46 :     dup 0> IF Format ELSE drop THEN ;
47 :    
48 :     : level- -7 Level +! ;
49 :    
50 :     VARIABLE nlflag
51 :    
52 :     DEFER nlcount ' noop IS nlcount
53 :    
54 :     : nl nlflag on ;
55 :     : (nl) nlcount
56 :     XPos @ Level @ = ?Exit
57 :     C-Formated @ IF
58 :     C-Output @
59 :     IF C-Clearline @ IF 80 XPos @ - spaces
60 :     ELSE cr THEN
61 :     1 YPos +! 0 XPos !
62 :     Level @ spaces
63 :     THEN Level @ XPos ! THEN ;
64 :    
65 :     : warp? ( len -- len )
66 :     nlflag @ IF (nl) nlflag off THEN
67 :     XPos @ over + 79 u> IF (nl) THEN ;
68 :    
69 :     : ctype ( adr len -- )
70 :     warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ;
71 :    
72 :     : cemit 1 warp?
73 :     over bl = Level @ XPos @ = and
74 :     IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
75 :     THEN ;
76 :    
77 :     DEFER .string
78 :    
79 :     [IFDEF] Green
80 :     VARIABLE Colors Colors on
81 :    
82 :     : (.string) ( c-addr u n -- )
83 :     over warp? drop
84 :     Colors @
85 :     IF C-Highlight @ ?dup
86 :     IF CT@ swap CT@ or
87 :     ELSE CT@
88 :     THEN
89 :     attr! ELSE drop THEN
90 :     ctype ct @ attr! ;
91 :     [ELSE]
92 :     : (.string) ( c-addr u n -- )
93 :     drop ctype ;
94 :     [THEN]
95 :    
96 :     ' (.string) IS .string
97 :    
98 :    
99 :     : .struc Str# .string ;
100 :    
101 :     \ CODES 15may93jaw
102 :    
103 :     21 CONSTANT RepeatCode
104 :     22 CONSTANT AgainCode
105 :     23 CONSTANT UntilCode
106 :     \ 09 CONSTANT WhileCode
107 :     10 CONSTANT ElseCode
108 :     11 CONSTANT AheadCode
109 :     13 CONSTANT WhileCode2
110 :     14 CONSTANT Disable
111 :    
112 :     \ FORMAT WORDS 13jun93jaw
113 :    
114 :     VARIABLE C-Stop
115 :     VARIABLE Branches
116 :    
117 :     VARIABLE BranchPointer
118 :     VARIABLE SearchPointer
119 :     CREATE BranchTable 500 allot
120 :     here 3 cells -
121 :     ACONSTANT MaxTable
122 :    
123 :     : FirstBranch BranchTable cell+ SearchPointer ! ;
124 :    
125 :     : (BranchAddr?) ( a-addr -- a-addr true | false )
126 :     SearchPointer @
127 :     BEGIN dup BranchPointer @ u<
128 :     WHILE
129 :     dup @ 2 pick <>
130 :     WHILE 3 cells +
131 :     REPEAT
132 :     nip dup 3 cells + SearchPointer ! true
133 :     ELSE
134 :     2drop false
135 :     THEN ;
136 :    
137 :     : BranchAddr?
138 :     FirstBranch (BranchAddr?) ;
139 :    
140 :     ' (BranchAddr?) ALIAS MoreBranchAddr?
141 :    
142 :     : CheckEnd ( a-addr -- true | false )
143 :     BranchTable cell+
144 :     BEGIN dup BranchPointer @ u<
145 :     WHILE
146 :     dup @ 2 pick u<=
147 :     WHILE 3 cells +
148 :     REPEAT
149 :     2drop false
150 :     ELSE
151 :     2drop true
152 :     THEN ;
153 :    
154 :     \
155 :     \ addrw addrt
156 :     \ BEGIN ... WHILE ... AGAIN ... THEN
157 :     \ ^ ! ! ^
158 :     \ ----------+--------+ !
159 :     \ ! !
160 :     \ +-------------------+
161 :     \
162 :     \
163 :    
164 :     : CheckWhile ( a-addrw a-addrt -- true | false )
165 :     BranchTable
166 :     BEGIN dup BranchPointer @ u<
167 :     WHILE dup @ 3 pick u>
168 :     over @ 3 pick u< and
169 :     IF dup cell+ @ 3 pick u<
170 :     IF 2drop drop true EXIT THEN
171 :     THEN
172 :     3 cells +
173 :     REPEAT
174 :     2drop drop false ;
175 :    
176 :     : ,Branch ( a-addr -- )
177 :     BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
178 :     !
179 :     1 cells BranchPointer +! ;
180 :    
181 :     : Type! ( u -- )
182 :     BranchPointer @ 1 cells - ! ;
183 :    
184 :     : Branch! ( a-addr rel -- a-addr )
185 :     over + over ,Branch ,Branch 0 ,Branch ;
186 :    
187 :     \ DEFER CheckUntil
188 :     VARIABLE NoOutput
189 :     VARIABLE C-Pass
190 :    
191 :     0 CONSTANT ScanMode
192 :     1 CONSTANT DisplayMode
193 :     2 CONSTANT DebugMode
194 :    
195 :     : Scan? ( -- flag ) C-Pass @ 0= ;
196 :     : Display? ( -- flag ) C-Pass @ 1 = ;
197 :     : Debug? ( -- flag ) C-Pass @ 2 = ;
198 :    
199 :     : back? ( n -- flag ) 0< ;
200 :     : ahead? ( n -- flag ) 0> ;
201 :    
202 :     : c-(compile)
203 :     Display? IF s" POSTPONE " Com# .string
204 :     dup @ look 0= ABORT" SEE: No valid XT"
205 :     cell+ count $1F and 0 .string bl cemit
206 :     THEN
207 :     cell+ ;
208 :    
209 :     : c-lit
210 : pazsan 1.8 Display? IF
211 :     dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
212 :     THEN
213 :     cell+ ;
214 :    
215 :     : c-@local#
216 :     Display? IF
217 :     S" @local" 0 .string
218 :     dup @ dup 1 cells / abs 0 <# #S rot sign #> 0 .string bl cemit
219 :     THEN
220 :     cell+ ;
221 : anton 1.1
222 : pazsan 1.6 : c-flit
223 : pazsan 1.8 Display? IF
224 :     dup f@ scratch represent 0=
225 :     IF 2drop scratch 3 min 0 .string
226 :     ELSE
227 :     IF '- cemit THEN 1-
228 :     scratch over c@ cemit '. cemit 1 /string 0 .string
229 :     'E cemit
230 :     dup abs 0 <# #S rot sign #> 0 .string bl cemit
231 :     THEN THEN
232 :     float+ ;
233 :    
234 :     : c-f@local#
235 :     Display? IF
236 :     S" f@local" 0 .string
237 :     dup @ dup 1 floats / abs 0 <# #S rot sign #> 0 .string bl cemit
238 :     THEN
239 :     cell+ ;
240 :    
241 :     : c-laddr#
242 :     Display? IF
243 :     S" laddr# " 0 .string
244 :     dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
245 :     THEN
246 :     cell+ ;
247 :    
248 :     : c-lp+!#
249 :     Display? IF
250 :     S" lp+!# " 0 .string
251 :     dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
252 :     THEN
253 :     cell+ ;
254 : pazsan 1.6
255 : anton 1.1 : c-s"
256 :     count 2dup + aligned -rot
257 :     Display?
258 :     IF [char] S cemit [char] " cemit bl cemit 0 .string
259 :     [char] " cemit bl cemit
260 :     ELSE 2drop
261 :     THEN ;
262 :    
263 :     : c-."
264 :     count 2dup + aligned -rot
265 :     Display?
266 :     IF [char] . cemit
267 :     [char] " cemit bl cemit 0 .string
268 :     [char] " cemit bl cemit
269 :     ELSE 2drop
270 :     THEN ;
271 :    
272 :     : c-c"
273 :     count 2dup + aligned -rot
274 :     Display?
275 :     IF [char] C cemit [char] " cemit bl cemit 0 .string
276 :     [char] " cemit bl cemit
277 :     ELSE 2drop
278 :     THEN ;
279 :    
280 :    
281 :     : Forward? ( a-addr true | false -- )
282 :     IF dup dup @ swap 1 cells - @ -
283 :     Ahead? IF true ELSE drop false THEN
284 :     \ only if forward jump
285 :     ELSE false THEN ;
286 :    
287 :     : RepeatCheck
288 :     IF BEGIN 2dup
289 :     1 cells - @ swap dup @ +
290 :     u<=
291 :     WHILE drop dup cell+
292 :     MoreBranchAddr? 0=
293 :     UNTIL false
294 :     ELSE true
295 :     THEN
296 :     ELSE false
297 :     THEN ;
298 :    
299 :     : c-branch
300 :     Scan?
301 :     IF dup @ Branch!
302 :     dup @ back?
303 :     IF \ might be: AGAIN, REPEAT
304 :     dup cell+ BranchAddr? Forward?
305 :     RepeatCheck
306 :     IF RepeatCode Type!
307 :     cell+ Disable swap !
308 :     ELSE AgainCode Type!
309 :     THEN
310 :     ELSE dup cell+ BranchAddr? Forward?
311 :     IF ElseCode Type! drop
312 :     ELSE AheadCode Type!
313 :     THEN
314 :     THEN
315 :     THEN
316 :     Display?
317 :     IF
318 :     dup @ back?
319 :     IF \ might be: AGAIN, REPEAT
320 :     level- nl
321 :     dup cell+ BranchAddr? Forward?
322 :     RepeatCheck
323 :     IF drop S" REPEAT " .struc nl
324 :     ELSE S" AGAIN " .struc nl
325 :     THEN
326 :     ELSE dup cell+ BranchAddr? Forward?
327 :     IF dup cell+ @ WhileCode2 =
328 :     IF nl S" ELSE" .struc level+
329 :     ELSE level- nl S" ELSE" .struc level+ THEN
330 :     cell+ Disable swap !
331 :     ELSE S" AHEAD" .struc level+
332 :     THEN
333 :     THEN
334 :     THEN
335 :     Debug?
336 :     IF dup @ +
337 :     ELSE cell+
338 :     THEN ;
339 :    
340 :     : MyBranch ( a-addr -- a-addr a-addr2 )
341 :     dup @ over +
342 :     BranchAddr?
343 :     BEGIN
344 :     WHILE 1 cells - @
345 :     over <>
346 :     WHILE dup @ over +
347 :     MoreBranchAddr?
348 :     REPEAT
349 :     SearchPointer @ 3 cells -
350 :     ELSE true ABORT" SEE: Table failure"
351 :     THEN ;
352 :    
353 :     : DebugBranch
354 :     Debug?
355 :     IF dup @ over + swap THEN ; \ return 2 different addresses
356 :    
357 :     : c-?branch
358 :     Scan?
359 :     IF dup @ Branch!
360 :     dup @ Back?
361 :     IF UntilCode Type! THEN
362 :     THEN
363 :     Display?
364 :     IF dup @ Back?
365 :     IF level- nl S" UNTIL " .struc nl
366 :     ELSE dup dup @ over +
367 :     CheckWhile
368 :     IF MyBranch
369 :     cell+ dup @ 0=
370 :     IF WhileCode2 swap !
371 :     ELSE drop THEN
372 :     level- nl
373 : pazsan 1.8 S" WHILE " .struc
374 : anton 1.1 level+
375 : pazsan 1.8 ELSE nl S" IF " .struc level+
376 : anton 1.1 THEN
377 :     THEN
378 :     THEN
379 :     DebugBranch
380 :     cell+ ;
381 :    
382 : pazsan 1.8 : c-?branch-lp+!# c-?branch cell+ ;
383 :     : c-branch-lp+!# c-branch cell+ ;
384 :    
385 : anton 1.1 : c-do
386 :     Display? IF nl S" DO" .struc level+ THEN ;
387 :    
388 :     : c-?do
389 :     Display? IF nl S" ?DO" .struc level+ THEN
390 :     DebugBranch cell+ ;
391 :    
392 :     : c-for
393 :     Display? IF nl S" FOR" .struc level+ THEN ;
394 :    
395 :     : c-next
396 :     Display? IF level- nl S" NEXT " .struc nl THEN
397 :     DebugBranch cell+ cell+ ;
398 :    
399 :     : c-loop
400 :     Display? IF level- nl S" LOOP " .struc nl THEN
401 :     DebugBranch cell+ cell+ ;
402 :    
403 :     : c-+loop
404 :     Display? IF level- nl S" +LOOP " .struc nl THEN
405 :     DebugBranch cell+ cell+ ;
406 :    
407 : pazsan 1.8 : c-s+loop
408 :     Display? IF level- nl S" S+LOOP " .struc nl THEN
409 :     DebugBranch cell+ cell+ ;
410 :    
411 :     : c--loop
412 :     Display? IF level- nl S" -LOOP " .struc nl THEN
413 :     DebugBranch cell+ cell+ ;
414 :    
415 :     : c-next-lp+!# c-next cell+ ;
416 :     : c-loop-lp+!# c-loop cell+ ;
417 :     : c-+loop-lp+!# c-+loop cell+ ;
418 :     : c-s+loop-lp+!# c-s+loop cell+ ;
419 :     : c--loop-lp+!# c--loop cell+ ;
420 :    
421 : anton 1.1 : c-leave
422 :     Display? IF S" LEAVE " .struc THEN
423 :     Debug? IF dup @ + THEN cell+ ;
424 :    
425 :     : c-?leave
426 :     Display? IF S" ?LEAVE " .struc THEN
427 :     cell+ DebugBranch swap cell+ swap cell+ ;
428 :    
429 :     : c-exit dup 1 cells -
430 :     CheckEnd
431 :     IF Display? IF nlflag off S" ;" Com# .string THEN
432 :     C-Stop on
433 :     ELSE Display? IF S" EXIT " .struc THEN
434 :     THEN
435 :     Debug? IF drop THEN ;
436 :    
437 : anton 1.7 : c-does> \ end of create part
438 : anton 1.1 Display? IF S" DOES> " Com# .string THEN
439 :     Cell+ cell+ ;
440 :    
441 :     : c-abort"
442 :     count 2dup + aligned -rot
443 :     Display?
444 :     IF S" ABORT" .struc
445 :     [char] " cemit bl cemit 0 .string
446 :     [char] " cemit bl cemit
447 :     ELSE 2drop
448 :     THEN ;
449 :    
450 :    
451 :     CREATE C-Table
452 : pazsan 1.8 ' lit A, ' c-lit A,
453 :     ' @local# A, ' c-@local# A,
454 :     ' flit A, ' c-flit A,
455 :     ' f@local# A, ' c-f@local# A,
456 :     ' laddr# A, ' c-laddr# A,
457 :     ' lp+!# A, ' c-lp+!# A,
458 :     ' (s") A, ' c-s" A,
459 :     ' (.") A, ' c-." A,
460 :     ' "lit A, ' c-c" A,
461 :     ' leave A, ' c-leave A,
462 :     ' ?leave A, ' c-?leave A,
463 :     ' (do) A, ' c-do A,
464 :     ' (?do) A, ' c-?do A,
465 :     ' (for) A, ' c-for A,
466 :     ' ?branch A, ' c-?branch A,
467 :     ' branch A, ' c-branch A,
468 :     ' (loop) A, ' c-loop A,
469 :     ' (+loop) A, ' c-+loop A,
470 :     ' (s+loop) A, ' c-s+loop A,
471 :     ' (-loop) A, ' c--loop A,
472 :     ' (next) A, ' c-next A,
473 :     ' ?branch-lp+!# A, ' c-?branch-lp+!# A,
474 :     ' branch-lp+!# A, ' c-branch-lp+!# A,
475 :     ' (loop)-lp+!# A, ' c-loop-lp+!# A,
476 :     ' (+loop)-lp+!# A, ' c-+loop-lp+!# A,
477 :     ' (s+loop)-lp+!# A, ' c-s+loop-lp+!# A,
478 :     ' (-loop)-lp+!# A, ' c--loop-lp+!# A,
479 :     ' (next)-lp+!# A, ' c-next-lp+!# A,
480 :     ' ;s A, ' c-exit A,
481 :     ' (does>) A, ' c-does> A,
482 :     ' (abort") A, ' c-abort" A,
483 :     ' (compile) A, ' c-(compile) A,
484 : anton 1.1 0 ,
485 :    
486 :     \ DOTABLE 15may93jaw
487 :    
488 :     : DoTable ( cfa -- flag )
489 :     C-Table
490 :     BEGIN dup @ dup
491 :     WHILE 2 pick <>
492 :     WHILE 2 cells +
493 :     REPEAT
494 :     nip cell+ @ EXECUTE
495 :     true
496 :     ELSE
497 :     2drop drop false
498 :     THEN ;
499 :    
500 :     : BranchTo? ( a-addr -- a-addr )
501 :     Display? IF dup BranchAddr?
502 :     IF BEGIN cell+ @ dup 20 u>
503 :     IF drop nl S" BEGIN " .struc level+
504 :     ELSE
505 :     dup Disable <>
506 :     IF WhileCode2 =
507 :     IF nl S" THEN " .struc nl ELSE
508 :     level- nl S" THEN " .struc nl THEN
509 :     ELSE drop THEN
510 :     THEN
511 :     dup MoreBranchAddr? 0=
512 :     UNTIL
513 :     THEN
514 :     THEN ;
515 :    
516 :     : analyse ( a-addr1 -- a-addr2 )
517 :     Branches @ IF BranchTo? THEN
518 :     dup cell+ swap @
519 :     dup >r DoTable r> swap IF drop EXIT THEN
520 :     Display?
521 : pazsan 1.3 IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
522 :     ELSE dup cell+ count 31 and rot wordinfo .string THEN bl cemit
523 : anton 1.1 ELSE drop
524 :     THEN ;
525 :    
526 :     : c-init
527 :     0 YPos ! 0 XPos !
528 :     0 Level ! nlflag off
529 :     BranchTable BranchPointer !
530 :     c-stop off
531 :     Branches on ;
532 :    
533 :     : makepass ( a-addr -- )
534 :     c-stop off
535 :     BEGIN
536 :     analyse
537 :     c-stop @
538 :     UNTIL drop ;
539 :    
540 :     DEFER dosee
541 :    
542 :     : dopri .name ." is primitive" cr ;
543 : pazsan 1.4 : dovar ." Variable " .name cr ;
544 :     : douse ." User " .name cr ;
545 :     : docon dup cell+ (name>) >body @ . ." Constant " .name cr ;
546 :     : doval dup cell+ (name>) >body @ . ." Value " .name cr ;
547 :     : dodef ." Defer " dup >r .name cr
548 : pazsan 1.8 r@ cell+ (name>) >body @ look
549 :     0= ABORT" SEE: No valid xt in deferred word"
550 :     dup dosee cr
551 :     ." ' " .name r> ." IS " .name cr ;
552 : pazsan 1.5 : dodoe ." Create " dup .name cr
553 :     S" DOES> " Com# .string XPos @ Level ! name>
554 :     >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
555 : anton 1.1 ScanMode c-pass ! dup makepass
556 :     DisplayMode c-pass ! makepass ;
557 : pazsan 1.4 : doali here @ .name ." Alias " .name cr
558 : anton 1.1 here @ dosee ;
559 :     : docol S" : " Com# .string
560 : pazsan 1.3 dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
561 : anton 1.1 ( XPos @ ) 2 Level !
562 :     name> >body
563 :     C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
564 :     ScanMode c-pass ! dup makepass
565 :     DisplayMode c-pass ! makepass ;
566 :    
567 :     create wordtypes
568 :     Pri# , ' dopri A,
569 :     Var# , ' dovar A,
570 :     Con# , ' docon A,
571 :     Val# , ' doval A,
572 :     Def# , ' dodef A,
573 :     Doe# , ' dodoe A,
574 :     Ali# , ' doali A,
575 :     Col# , ' docol A,
576 : pazsan 1.4 Use# , ' douse A,
577 : anton 1.1 0 ,
578 :    
579 :     : (dosee) ( lfa -- )
580 : pazsan 1.4 dup dup cell+ c@ >r
581 : anton 1.1 wordinfo
582 :     wordtypes
583 :     BEGIN dup @ dup
584 : pazsan 1.4 WHILE 2 pick = IF cell+ @ nip EXECUTE
585 :     r> dup 32 and IF ." immediate" THEN
586 :     64 and IF ." restrict" THEN EXIT THEN
587 : anton 1.1 2 cells +
588 :     REPEAT
589 : pazsan 1.4 2drop rdrop
590 : anton 1.1 .name ." Don't know how to handle" cr ;
591 :    
592 :     ' (dosee) IS dosee
593 :    
594 :     : xtc ( xt -- ) \ do see at xt
595 :     Look 0= ABORT" SEE: No valid XT"
596 :     cr c-init
597 :     dosee ;
598 : pazsan 1.3
599 : pazsan 1.4 : see name sfind 0= IF ." Word unknown" cr exit THEN
600 : pazsan 1.3 xtc ;
601 : anton 1.1
602 :     : lfc cr c-init cell+ dosee ;
603 :     : nfc cr c-init dosee ;
604 :    
605 :    
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help