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