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