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