Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) see.fth 98/01/26 1.4 |
2 | \ SEE ( <name> -- , disassemble pForth word ) | |
3 | \ | |
4 | \ Copyright 1996 Phil Burk | |
5 | ||
6 | ' file? >code rfence a! | |
7 | ||
8 | anew task-see.fth | |
9 | ||
10 | : .XT ( xt -- , print execution tokens name ) | |
11 | >name | |
12 | dup c@ flag_immediate and | |
13 | IF | |
14 | ." POSTPONE " | |
15 | THEN | |
16 | id. space | |
17 | ; | |
18 | ||
19 | \ dictionary may be defined as byte code or cell code | |
20 | 0 constant BYTE_CODE | |
21 | ||
22 | BYTE_CODE [IF] | |
23 | : CODE@ ( addr -- xt , fetch from code space ) C@ ; | |
24 | 1 constant CODE_CELL | |
25 | .( BYTE_CODE not implemented) abort | |
26 | [ELSE] | |
27 | : CODE@ ( addr -- xt , fetch from code space ) @ ; | |
28 | CELL constant CODE_CELL | |
29 | [THEN] | |
30 | ||
31 | private{ | |
32 | ||
33 | 0 value see_level \ level of conditional imdentation | |
34 | 0 value see_addr \ address of next token | |
35 | 0 value see_out | |
36 | ||
37 | : SEE.INDENT.BY ( -- n ) | |
38 | see_level 1+ 1 max 4 * | |
39 | ; | |
40 | ||
41 | : SEE.CR | |
42 | >newline | |
43 | see_addr ." ( ".hex ." )" | |
44 | see.indent.by spaces | |
45 | 0 -> see_out | |
46 | ; | |
47 | : SEE.NEWLINE | |
48 | see_out 0> | |
49 | IF see.cr | |
50 | THEN | |
51 | ; | |
52 | : SEE.CR? | |
53 | see_out 6 > | |
54 | IF | |
55 | see.newline | |
56 | THEN | |
57 | ; | |
58 | : SEE.OUT+ | |
59 | 1 +-> see_out | |
60 | ; | |
61 | ||
62 | : SEE.ADVANCE | |
63 | code_cell +-> see_addr | |
64 | ; | |
65 | : SEE.GET.INLINE ( -- n ) | |
66 | see_addr @ | |
67 | ; | |
68 | ||
69 | : SEE.GET.TARGET ( -- branch-target-addr ) | |
70 | see_addr @ see_addr + | |
71 | ; | |
72 | ||
73 | : SEE.SHOW.LIT ( -- ) | |
74 | see.get.inline . | |
75 | see.advance | |
76 | see.out+ | |
77 | ; | |
78 | ||
79 | exists? F* [IF] | |
80 | : SEE.SHOW.FLIT ( -- ) | |
81 | see_addr f@ f. | |
82 | 1 floats +-> see_addr | |
83 | see.out+ | |
84 | ; | |
85 | [THEN] | |
86 | ||
87 | : SEE.SHOW.ALIT ( -- ) | |
88 | see.get.inline >name id. space | |
89 | see.advance | |
90 | see.out+ | |
91 | ; | |
92 | ||
93 | : SEE.SHOW.STRING ( -- ) | |
94 | see_addr count 2dup + aligned -> see_addr type | |
95 | see.out+ | |
96 | ; | |
97 | : SEE.SHOW.TARGET ( -- ) | |
98 | see.get.target .hex see.advance | |
99 | ; | |
100 | ||
101 | : SEE.BRANCH ( -- addr | , handle branch ) | |
102 | -1 +-> see_level | |
103 | see.newline | |
104 | see.get.inline 0> | |
105 | IF \ forward branch | |
106 | ." ELSE " | |
107 | see.get.target \ calculate address of target | |
108 | 1 +-> see_level | |
109 | nip \ remove old address for THEN | |
110 | ELSE | |
111 | ." REPEAT " see.get.target .hex | |
112 | drop \ remove old address for THEN | |
113 | THEN | |
114 | see.advance | |
115 | see.cr | |
116 | ; | |
117 | ||
118 | : SEE.0BRANCH ( -- addr | , handle 0branch ) | |
119 | see.newline | |
120 | see.get.inline 0> | |
121 | IF \ forward branch | |
122 | ." IF or WHILE " | |
123 | see.get.target \ calculate adress of target | |
124 | 1 +-> see_level | |
125 | ELSE | |
126 | ." UNTIL=>" see.get.target .hex | |
127 | THEN | |
128 | see.advance | |
129 | see.cr | |
130 | ; | |
131 | ||
132 | : SEE.XT { xt -- } | |
133 | xt | |
134 | CASE | |
135 | 0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0 -> see_addr THEN ENDOF | |
136 | ['] (LITERAL) OF see.show.lit ENDOF | |
137 | ['] (ALITERAL) OF see.show.alit ENDOF | |
138 | [ exists? (FLITERAL) [IF] ] | |
139 | ['] (FLITERAL) OF see.show.flit ENDOF | |
140 | [ [THEN] ] | |
141 | ['] BRANCH OF see.branch ENDOF | |
142 | ['] 0BRANCH OF see.0branch ENDOF | |
143 | ['] (LOOP) OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr ENDOF | |
144 | ['] (+LOOP) OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr ENDOF | |
145 | ['] (DO) OF see.newline ." DO" 1 +-> see_level see.cr ENDOF | |
146 | ['] (?DO) OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF | |
147 | ['] (.") OF .' ." ' see.show.string .' " ' ENDOF | |
148 | ['] (C") OF .' C" ' see.show.string .' " ' ENDOF | |
149 | ['] (S") OF .' S" ' see.show.string .' " ' ENDOF | |
150 | ||
151 | see.cr? xt .xt see.out+ | |
152 | ENDCASE | |
153 | ; | |
154 | ||
155 | : (SEE) { cfa | xt -- } | |
156 | 0 -> see_level | |
157 | cfa -> see_addr | |
158 | see.cr | |
159 | 0 \ fake address for THEN handler | |
160 | BEGIN | |
161 | see_addr code@ -> xt | |
162 | BEGIN | |
163 | dup see_addr ( >newline .s ) = | |
164 | WHILE | |
165 | -1 +-> see_level see.newline | |
166 | ." THEN " see.cr | |
167 | drop | |
168 | REPEAT | |
169 | CODE_CELL +-> see_addr | |
170 | xt see.xt | |
171 | see_addr 0= | |
172 | UNTIL | |
173 | cr | |
174 | 0= not abort" SEE conditional analyser nesting failed!" | |
175 | ; | |
176 | ||
177 | }PRIVATE | |
178 | ||
179 | : SEE ( <name> -- , disassemble ) | |
180 | ' | |
181 | dup ['] FIRST_COLON > | |
182 | IF | |
183 | >code (see) | |
184 | ELSE | |
185 | >name id. | |
186 | ." is primitive defined in 'C' kernel." cr | |
187 | THEN | |
188 | ; | |
189 | ||
190 | PRIVATIZE | |
191 | ||
192 | 0 [IF] | |
193 | ||
194 | : SEE.JOKE | |
195 | dup swap drop | |
196 | ; | |
197 | ||
198 | : SEE.IF | |
199 | IF | |
200 | ." hello" cr | |
201 | ELSE | |
202 | ." bye" cr | |
203 | THEN | |
204 | see.joke | |
205 | ; | |
206 | : SEE.DO | |
207 | 4 0 | |
208 | DO | |
209 | i . cr | |
210 | LOOP | |
211 | ; | |
212 | : SEE." | |
213 | ." Here are some strings." cr | |
214 | c" Forth string." count type cr | |
215 | s" Addr/Cnt string" type cr | |
216 | ; | |
217 | ||
218 | [THEN] |