Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: compilin.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | id: @(#)compilin.fth 3.15 03/12/08 13:22:30 | |
43 | purpose: | |
44 | copyright: Copyright 1994-2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Copyright 1985-1994 Bradley Forthware, Inc. | |
46 | copyright: Use is subject to license terms. | |
47 | ||
48 | forth definitions | |
49 | ||
50 | vocabulary transition | |
51 | ||
52 | meta definitions | |
53 | ||
54 | h# 80 constant metacompiling | |
55 | ||
56 | \ Non-immediate version which is compiled inside several | |
57 | \ meta and transition words | |
58 | : literal-t ( n -- ) n->l-t compile-t (lit) ,-t ; | |
59 | ||
60 | \ vocabularies: | |
61 | \ transition | |
62 | \ symbols \ entries are does> words | |
63 | \ labels \ entries are constants | |
64 | \ meta | |
65 | \ | |
66 | \ Compiling: order: transition symbols labels | |
67 | \ If found in transition, execute it | |
68 | \ If found in symbols, execute it | |
69 | \ If is immediate, complain (should have been in transition) | |
70 | \ If not found, addlink | |
71 | \ | |
72 | \ Interpreting: meta | |
73 | \ | |
74 | : metacompile-do-literal ( n -- ) | |
75 | state @ metacompiling = if | |
76 | [ifndef] oldhack | |
77 | 2 = if where ." oops double number " cr source type cr drop then | |
78 | [then] | |
79 | literal-t | |
80 | else | |
81 | (do-literal) | |
82 | then | |
83 | ; | |
84 | ||
85 | : metacompile-do-defined ( acf -1 | acf 1 -- ) | |
86 | drop execute | |
87 | ; | |
88 | : $metacompile-do-undefined ( adr len -- ) \ compile a forward reference | |
89 | $compile-t | |
90 | ; | |
91 | ||
92 | \ XXX need to include labels in the search path when interpreting | |
93 | ||
94 | \ XXX switch search order when going from metacompiling to interpreting | |
95 | \ and back. | |
96 | \ 3 states: | |
97 | \ interpreting is just the normal interpret state, with labels in the search | |
98 | \ path | |
99 | \ compiling is just the normal compile state, with labels in the search path | |
100 | \ metacompiling is the special state. | |
101 | ||
102 | : meta-base ( -- ) only forth also labels also meta also ; | |
103 | : meta-compile ( -- ) meta-base definitions ; | |
104 | : meta-assemble ( -- ) meta-base assembler ; | |
105 | : extend-meta-assembler ( -- ) meta-assemble also definitions ; | |
106 | : meta-asm[ ( -- ) also meta assembler ; immediate | |
107 | : ]meta-asm ( -- ) previous ; immediate | |
108 | ||
109 | variable doestarget | |
110 | ||
111 | \ "resolves" gives a name to the run-time clause specified by the most- | |
112 | \ recently-defined "does>" or ";code" word. A number of defining words | |
113 | \ assume that their appropriate run-time clause will be resolved with a | |
114 | \ particular word. For instance, "vocabulary" refers to a run-time clause | |
115 | \ called <vocabulary>. When the run-time code for vocabularies is defined | |
116 | \ in the kernel source, "resolves" is used to associate its address with | |
117 | \ the name <vocabulary>. See the kernel source for examples. | |
118 | ||
119 | : resolves \ name ( -- ) | |
120 | doestarget @ safe-parse-word $findsymbol resolution! | |
121 | ; | |
122 | ||
123 | \ This is a smart equ which defines words that can be later used | |
124 | \ inside colon definitions, in which case they will compile their | |
125 | \ value as a literal. Perhaps these should be created in the | |
126 | \ labels vocabulary. | |
127 | ||
128 | : $equ ( value adr len -- ) | |
129 | [ forth ] ['] labels $vcreate , immediate | |
130 | does> \ ( -- value ) or ( -- ) | |
131 | @ | |
132 | [ meta ] state @ metacompiling = if literal-t then | |
133 | ; | |
134 | : equ \ name ( value -- ) | |
135 | safe-parse-word $equ | |
136 | ; | |
137 | ||
138 | \ Tools for building control constructs. The details of the branch | |
139 | \ target (offset or absolute, # of bytes, etc) are hidden in | |
140 | \ /branch branch, and branch! which are defined earlier. | |
141 | ||
142 | : >mark ( -- addr ) here-t here-t branch, ; | |
143 | : >resolve ( addr -- ) here-t branch! ; | |
144 | : <mark ( -- addr ) here-t ; | |
145 | : <resolve ( addr -- ) branch, ; | |
146 | : ?comp ( -- ) state @ metacompiling <> abort" compile only" ; | |
147 | ||
148 | \ "Transition" words. Versions of compiling words which are defined | |
149 | \ in the host environment but which compile code into the target | |
150 | \ environment. | |
151 | \ Once compiling words are redefined, care must be taken to select | |
152 | \ the old instance of that word for use in other definitions. For instance, | |
153 | \ when "if" is redefined, subsequent definitions will frequently want to use | |
154 | \ the old "if", so the search order must be explicitly controlled in order | |
155 | \ to access the old one instead of the new one. | |
156 | ||
157 | : target ( -- ) only forth also transition ; immediate | |
158 | ||
159 | transition definitions | |
160 | ||
161 | \ Set the search path to exclude the transition vocabulary so that | |
162 | \ we can define transition words but still use the normal versions | |
163 | \ of compiling words like if and [compile] | |
164 | : host ( -- ) only forth also meta ; immediate | |
165 | ||
166 | \ Transition version of control constructs. | |
167 | ||
168 | : of ( [ addresses ] 4 -- 5 ) | |
169 | host ?comp 4 ?pairs compile-t (of) >mark 5 target | |
170 | ; immediate | |
171 | ||
172 | : case ( -- 4 ) host ?comp csp @ !csp 4 target ; immediate | |
173 | : endof ( [ addresses ] 5 -- [ one more address ] 4 ) | |
174 | host 5 ?pairs compile-t (endof) >mark swap >resolve 4 target | |
175 | ; immediate | |
176 | : endcase ( [ addresses ] 4 -- ) | |
177 | host 4 ?pairs compile-t (endcase) | |
178 | begin sp@ csp @ <> while >resolve repeat | |
179 | csp ! | |
180 | target | |
181 | ; immediate | |
182 | ||
183 | : if host ?comp compile-t ?branch >mark target ; immediate | |
184 | : ahead host ?comp compile-t branch >mark target ; immediate | |
185 | : else host ?comp compile-t branch >mark | |
186 | swap >resolve target ; immediate | |
187 | : then host ?comp >resolve target ; immediate | |
188 | ||
189 | : begin host ?comp <mark target ; immediate | |
190 | : until host ?comp compile-t ?branch <resolve target ; immediate | |
191 | : while host ?comp compile-t ?branch >mark swap target ; immediate | |
192 | : again host ?comp compile-t branch <resolve target ; immediate | |
193 | ||
194 | : repeat host ?comp compile-t branch <resolve >resolve target ; immediate | |
195 | ||
196 | : ?do host ?comp compile-t (?do) >mark target ; immediate | |
197 | : do host ?comp compile-t (do) >mark target ; immediate | |
198 | : leave host ?comp compile-t (leave) target ; immediate | |
199 | : ?leave host ?comp compile-t (?leave) target ; immediate | |
200 | : loop host ?comp compile-t (loop) | |
201 | dup /branch + <resolve >resolve target ; immediate | |
202 | : +loop host ?comp compile-t (+loop) | |
203 | dup /branch + <resolve >resolve target ; immediate | |
204 | ||
205 | \ Transition version of words which compile numeric literals | |
206 | : literal ( n -- ) | |
207 | host literal-t target | |
208 | ; immediate | |
209 | ||
210 | : ascii \ string ( -- char ) | |
211 | host bl word 1+ c@ state @ if literal-t then target | |
212 | ; immediate | |
213 | ||
214 | : control \ string ( -- char ) | |
215 | host bl word 1+ c@ bl 1- and state @ if literal-t then target | |
216 | ; immediate | |
217 | ||
218 | : [char] \ string ( -- char ) | |
219 | host bl word 1+ c@ literal-t target | |
220 | ; immediate | |
221 | ||
222 | : th \ string ( -- n ) | |
223 | host base @ >r hex | |
224 | parse-word $handle-literal? 0= if | |
225 | ." Bogus number after th" cr | |
226 | then | |
227 | r> base ! target | |
228 | ; immediate | |
229 | ||
230 | : td \ string ( -- n ) | |
231 | host base @ >r decimal | |
232 | parse-word $handle-literal? 0= if | |
233 | ." Bogus number after td" cr | |
234 | then | |
235 | r> base ! target | |
236 | ; immediate | |
237 | alias h# th | |
238 | alias d# td | |
239 | ||
240 | \ From now on we start to see familiar words with "-h" suffixes. These | |
241 | \ are aliases for the familiar word, used because we have redefined the | |
242 | \ word to operate in the target environment, but we still need to use the | |
243 | \ original word. Rather that having to do [ forth ] foo [ meta ] all the | |
244 | \ time, we make an alias foo-h for foo. | |
245 | ||
246 | forth definitions | |
247 | ||
248 | alias '-h ' | |
249 | alias [']-h ['] | |
250 | alias :-h : | |
251 | alias ;-h ; | |
252 | alias ]-h ] | |
253 | alias forth-h forth | |
254 | alias immediate-h immediate | |
255 | alias is-h is | |
256 | ||
257 | \ Transition versions of tick and bracket-tick. Forward references | |
258 | \ are not permitted with tick because there is no way to know how | |
259 | \ the address will be used. The mechanism for eventually resolving | |
260 | \ forward references depends on the assumption that the forward | |
261 | \ reference resolves to a compilation address that is compiled into | |
262 | \ a definition. This assumption doesn't hold for tick'ed words, so | |
263 | \ we don't allow them to be forward references. | |
264 | ||
265 | meta definitions | |
266 | : ' ( -- acf ) | |
267 | safe-parse-word | |
268 | 2dup $sfind if ( adr len acf ) \ The word has already been seen | |
269 | dup resolved? ( adr len acf flag ) | |
270 | if nip nip resolution@ ( resolution ) exit then | |
271 | drop | |
272 | then ( adr len adr len | adr len ) | |
273 | type ." hasn't been defined yet, so ' won't work" cr | |
274 | abort | |
275 | ; | |
276 | ||
277 | : [']-t \ name ( -- ) | |
278 | compile-t (') safe-parse-word $compile-t | |
279 | ; immediate | |
280 | ||
281 | : place-t ( adr len to-t -- ) | |
282 | 2dup + 1+ 0 swap c!-t \ Put a null byte at the end | |
283 | 2dup c!-t 1+ swap cmove-t | |
284 | ; | |
285 | ||
286 | \ Emplace a string into the target dictionary | |
287 | : ,"-t \ string" ( -- ) \ cram the string at here | |
288 | td 34 ( ascii " ) word count ( adr len ) | |
289 | here-t ( adr len here ) | |
290 | over 2+ note-string-t allot-t talign-t ( adr len here ) | |
291 | place-t | |
292 | ; | |
293 | ||
294 | transition definitions | |
295 | : ." host compile-t (.") ,"-t target ; immediate | |
296 | : abort" host compile-t (abort") ,"-t target ; immediate | |
297 | : " host compile-t (") ,"-t target ; immediate | |
298 | : p" host compile-t ("s) ,"-t target ; immediate | |
299 | ||
300 | \ Bogus 1024 constant b/buf | |
301 | ||
302 | meta also assembler definitions | |
303 | : end-code | |
304 | meta-compile | |
305 | \ current @ context ! | |
306 | ; | |
307 | previous definitions | |
308 | ||
309 | \ Some debugging words. Allow the printing of the name of words as they | |
310 | \ are defined. threshhold is the number of words that must be defined | |
311 | \ before any printing starts, and granularity is the interval between | |
312 | \ words that are printed after the threshhold is crossed. This is very | |
313 | \ useful if the metacompiler crashes, because it helps you to locate | |
314 | \ where the crash occurred. If needed, start with threshhold = 0 and | |
315 | \ granularity = 20, then set threshhold to whatever word was printed | |
316 | \ before the crash and granularity to 1. | |
317 | ||
318 | forth definitions | |
319 | variable #words 0 #words ! | |
320 | variable threshold 10000 threshold ! | |
321 | variable granularity 10 granularity ! | |
322 | variable prev-depth 0 prev-depth ! ( expected depth ) | |
323 | : .debug ( -- ) | |
324 | threshold @ -1 <> if | |
325 | base @ decimal #words @ 5 .r space base ! | |
326 | [ also meta ] .lastname [ previous ] | |
327 | depth 0 <> if space .x then cr | |
328 | then | |
329 | ; | |
330 | : ?debug ( -- ) | |
331 | depth prev-depth @ <> if | |
332 | .debug depth prev-depth ! | |
333 | else | |
334 | #words @ threshold @ >= | |
335 | if #words @ granularity @ mod | |
336 | 0= if .debug then | |
337 | then | |
338 | then | |
339 | 1 #words +! | |
340 | ; | |
341 | ||
342 | meta definitions | |
343 | ||
344 | 0 value lastacf-t \ acf of the most-recently-created target word | |
345 | ||
346 | variable show? \ True if we should show all the symbols | |
347 | show? off | |
348 | ||
349 | ||
350 | \ Header control: | |
351 | \ The kernel can be compiled in 3 modes: | |
352 | \ always-headers: All words have headers (default mode) | |
353 | \ never-headers: No words have headers | |
354 | \ sometimes-headers: Words have headers unless "headerless" is active | |
355 | ||
356 | \ -1 : never 0 : always 1 : yes 2 : no | |
357 | ||
358 | variable header-control 0 header-control ! | |
359 | ||
360 | : headerless ( -- ) header-control @ 0> if 2 header-control ! then ; | |
361 | : headers ( -- ) header-control @ 0> if 1 header-control ! then ; | |
362 | ||
363 | : always-headers ( -- ) 0 header-control ! ; | |
364 | : sometimes-headers ( -- ) 1 header-control ! ; | |
365 | : never-headers ( -- ) -1 header-control ! ; | |
366 | ||
367 | : make-header? ( -- flag ) header-control @ 0 1 between ; | |
368 | ||
369 | ||
370 | ||
371 | : initmeta ( -- ) initmeta 0 is lastacf-t ; | |
372 | ||
373 | variable flags-t | |
374 | ||
375 | \ Creates a header in the target image | |
376 | : $really-header-t ( str -- ) | |
377 | \ Find the metacompiler's copy of the threads | |
378 | 2dup current-t @ $hash-t ( str thread ) | |
379 | ||
380 | -rot dup 1+ /link-t + ( thread str,len n ) | |
381 | here-t + dup acf-aligned-t swap - allot-t ( thread str,len ) | |
382 | ||
383 | ||
384 | tuck here-t over 1+ note-string-t allot-t ( thread len str,len adr ) | |
385 | place-cstr-t over + c!-t ( thread ) | |
386 | ||
387 | here-t 1- dup c@-t h# 80 or swap c!-t | |
388 | here-t 1- flags-t ! | |
389 | ||
390 | \ get the link to the top word ( thread ) | |
391 | dup link-t@ ( thread top-word ) | |
392 | ||
393 | \ link the existing list to the new word | |
394 | link,-t ( thread ) | |
395 | ||
396 | \ link the thread to the new word | |
397 | here-t swap link-t! | |
398 | ||
399 | ||
400 | ; | |
401 | : showsym ( str -- ) | |
402 | base @ >r hex | |
403 | here-t 8 u.r ( drop ) space type cr | |
404 | r> base ! | |
405 | ; | |
406 | ||
407 | : $meta-execute ( pstr -- ) | |
408 | ['] labels $vfind if | |
409 | execute | |
410 | else | |
411 | ['] meta $vfind if execute else type ." ?" abort then | |
412 | then | |
413 | ; | |
414 | ||
415 | : $header-t ( name$ cf$ -- ) \ Make a header in the target area | |
416 | 2>r | |
417 | ||
418 | xref-header-hook \ for Xreferencing | |
419 | 2dup $create-s \ symbol table entry | |
420 | \ Make header unless headerless | |
421 | make-header? if 2dup $really-header-t then | |
422 | acf-align-t | |
423 | show? @ if showsym else 2drop then | |
424 | ||
425 | here-t is lastacf-t \ Remember where the code field starts | |
426 | ||
427 | here-t lastacf-s @ resolution! \ resolve it | |
428 | ||
429 | header-control @ 3 and lastacf-s @ info! | |
430 | ||
431 | 2r> $meta-execute | |
432 | ; | |
433 | ||
434 | \ Construct the list of "actions" that may be performed | |
435 | \ when a given target-word is the target of "is" | |
436 | \ Make these words state-smart so they can be used both | |
437 | \ when the "is" is applied at meta-compile time and when it | |
438 | \ is being compiled-in. The meta-compiling-state part will | |
439 | \ compile-in the appropriate run-time variant of "is". | |
440 | ||
441 | \ Support function for noting misuses: | |
442 | : don't-use-with-is ( $adr,len -- bufr ) \ Start off the message | |
443 | " Don't you know not to use IS with " "temp pack ( $adr,len bufr ) | |
444 | dup 2swap ( bufr bufr $adr,len ) | |
445 | rot $cat ( bufr ) | |
446 | ; | |
447 | : don't-use-is-while-metacomp ( bufr -- ) \ Finish off the message. | |
448 | dup " while metacompiling" rot $cat ( bufr ) | |
449 | count .not-found | |
450 | ; | |
451 | ||
452 | : don't-use-interp-is ( $adr,len -- ) \ Interpret-time message | |
453 | don't-use-with-is | |
454 | don't-use-is-while-metacomp | |
455 | ; | |
456 | ||
457 | \ The interpret-time variants | |
458 | \ I would have liked to call these is<whatever>-interp but there are | |
459 | \ a few of 'em scattered around for use in the defining process; I'll | |
460 | \ just continue to call them is<whatever> | |
461 | ||
462 | : isuser ( n acf-t -- ) >user-t n-t! ; | |
463 | : istuser ( acf-t1 acf-t -- ) >user-t token-t! ; | |
464 | : isvalue ( n acf-t -- ) >user-t n-t! ; | |
465 | : isdefer ( acf-t1 acf-t -- ) >user-t token-t! ; | |
466 | ||
467 | \ We'll allow a constant to be changed at metacompile-time | |
468 | : isconstant ( n acf-t -- ) >body-t !-t ; | |
469 | ||
470 | \ : iscreate ( acf-t -- addr ) >body-t ; \ This isn't used | |
471 | ||
472 | \ In-dictionary variables are a leftover from the earliest FORTH | |
473 | \ implementations. They have no place in a ROMable target-system | |
474 | \ and we are deprecating support for them; but Just In Case you | |
475 | \ ever want to restore support for them, define the command-line | |
476 | \ symbol: in-dictionary-variables | |
477 | [ifdef] in-dictionary-variables | |
478 | : isvariable ( n acf-t -- ) >body-t !-t ; | |
479 | [then] | |
480 | ||
481 | : isvocabulary ( threads acf-t -- ) | |
482 | >user-t ( threads threadsaddr-t ) | |
483 | #threads-t 0 | |
484 | do | |
485 | over link-t@ over link-t! ( threads threadsaddr-t ) | |
486 | /link-t + swap /link-t + swap | |
487 | loop | |
488 | 2drop | |
489 | ; | |
490 | ||
491 | \ The meta-compile-time variants | |
492 | ||
493 | \ Support function for noting misuses: | |
494 | : don't-use-meta-is ( $adr,len -- ) \ Meta-compile-time message | |
495 | don't-use-with-is ( bufr ) | |
496 | dup " inside a definition" rot $cat ( bufr ) | |
497 | don't-use-is-while-metacomp | |
498 | ; | |
499 | ||
500 | : don't-use-is-at-all ( [ | n ] $adr,len -- ) \ Dispatch to proper message | |
501 | state @ metacompiling = if ( $adr,len ) | |
502 | don't-use-meta-is \ Dispatch to meta-compile-time message | |
503 | else ( acf-t1 $adr,len ) | |
504 | rot drop don't-use-interp-is \ Dispatch to interpret-time message | |
505 | then | |
506 | ; | |
507 | ||
508 | : isvocabulary-meta ( acf-s -- ) | |
509 | drop " a VOCABULARY definition" don't-use-meta-is | |
510 | ; | |
511 | ||
512 | : isvalue-meta ( acf-s -- ) compile-t (is-user) compile,-t ; | |
513 | ||
514 | : isdefer-meta ( acf-s -- ) compile-t (is-defer) compile,-t ; | |
515 | ||
516 | : isuser-meta ( acf-s -- ) compile-t (is-user) compile,-t ; | |
517 | ||
518 | : istuser-meta ( acf-s -- ) compile-t (is-defer) compile,-t ; | |
519 | ||
520 | [ifdef] in-dictionary-variables | |
521 | : isvariable-meta ( acf -- ) compile-t (is-const) ; | |
522 | [then] | |
523 | ||
524 | \ The actual is<whatever>-action words. | |
525 | : isvalue-action ( [ | n ] acf-s acf-t -- ) | |
526 | state @ metacompiling = if ( acf-s acf-t ) | |
527 | drop isvalue-meta | |
528 | else ( n acf-s acf-t ) | |
529 | nip isvalue | |
530 | then | |
531 | ; | |
532 | ||
533 | : isdefer-action ( [ | acf-t1 ] acf-s acf-t -- ) | |
534 | state @ metacompiling = if ( acf-s acf-t ) | |
535 | drop isdefer-meta | |
536 | else ( acf-t1 acf-s acf-t ) | |
537 | nip isdefer | |
538 | then | |
539 | ; | |
540 | ||
541 | : isuser-action ( [ | n ] acf-s acf-t -- ) | |
542 | state @ metacompiling = if ( acf-s acf-t ) | |
543 | drop isuser-meta | |
544 | else ( n acf-s acf-t ) | |
545 | nip isuser | |
546 | then | |
547 | ; | |
548 | ||
549 | : istuser-action ( acf1 acf -- ) | |
550 | state @ metacompiling = if | |
551 | drop istuser-meta | |
552 | else ( acf1 acf) | |
553 | nip istuser | |
554 | then | |
555 | ; | |
556 | ||
557 | : isconstant-action ( [ | n ] acf-s acf-t -- n ) | |
558 | state @ metacompiling = if ( acf-s acf-t ) | |
559 | 2drop " a CONSTANT" don't-use-meta-is | |
560 | else ( n acf-s acf-t ) | |
561 | nip isconstant | |
562 | then | |
563 | ; | |
564 | : iscreate-action ( [ | acf-t1 ] acf-s acf-t -- ) \ Don't do this! | |
565 | 2drop " a CREATE definition" | |
566 | don't-use-is-at-all | |
567 | ; | |
568 | ||
569 | [ifdef] in-dictionary-variables | |
570 | : isvariable-action ( n acf -- ) | |
571 | state @ metacompiling = if | |
572 | drop isvariable-meta | |
573 | else | |
574 | nip isvariable | |
575 | then | |
576 | ; | |
577 | [then] | |
578 | ||
579 | : isvocabulary-action ( [ | threads ] acf-s acf-t -- ) | |
580 | state @ metacompiling = if ( acf-s acf-t ) | |
581 | drop isvocabulary-meta | |
582 | else ( threads acf-s acf-t ) | |
583 | nip isvocabulary | |
584 | then | |
585 | ; | |
586 | : iscolon-action ( [ | acf-t1 ] acf-s acf-t -- ) | |
587 | 2drop " a Colon or Code definition" | |
588 | don't-use-is-at-all | |
589 | ; | |
590 | ||
591 | ||
592 | \ Perform a create for the target system. This includes making or | |
593 | \ resolving a symbol table entry. A partial code field may be generated. | |
594 | ||
595 | : header-t \ name ( name-str -- ) | |
596 | safe-parse-word 2swap $header-t | |
597 | ; | |
598 | ||
599 | \ Automatic allocation of space in the user area | |
600 | variable #user-t | |
601 | /n constant #ualign-t | |
602 | : ualigned-t ( n -- n' ) #ualign-t 1- + #ualign-t negate and ; | |
603 | ||
604 | : ualloc-t ( n -- next-user-# ) \ allocate n bytes and leave a user number | |
605 | ( #bytes ) #user-t @ over #ualign-t >= if | |
606 | ualigned-t dup #user-t ! | |
607 | then ( #bytes user# ) | |
608 | ||
609 | swap #user-t +! | |
610 | ; | |
611 | ||
612 | : constant \ name ( n -- ) | |
613 | safe-parse-word 3dup $equ | |
614 | " constant-cf" $header-t s->l-t ,-t | |
615 | ['] isconstant-action setaction ?debug | |
616 | ; | |
617 | ||
618 | : create \ name ( -- ) | |
619 | " create-cf" header-t | |
620 | ['] iscreate-action setaction ?debug | |
621 | ; | |
622 | ||
623 | [ifdef] in-dictionary-variables | |
624 | : variable \ name ( -- ) | |
625 | " variable-cf" header-t 0 n->n-t ,-t | |
626 | ['] isvariable-action setaction ?debug | |
627 | ; | |
628 | [then] | |
629 | ||
630 | \ isuser is in target.fth | |
631 | \ X : isuser ( n acf -- ) >user-t n-t! ; | |
632 | : user \ name ( user# -- ) | |
633 | " user-cf" header-t n->n-t ,user#-t | |
634 | ['] isuser-action setaction ?debug | |
635 | ; | |
636 | : nuser \ name ( -- ) | |
637 | /n-t ualloc-t user | |
638 | ; | |
639 | ||
640 | \ istuser is in target.fth | |
641 | \ X : istuser ( acf1 acf -- ) >user-t token-t! ; | |
642 | : tuser \ name ( -- ) | |
643 | /token-t ualloc-t user ['] istuser-action setaction | |
644 | ; | |
645 | ||
646 | : isauser ( adr acf -- ) >user-t a-t! ; | |
647 | : auser \ name ( -- ) | |
648 | /a-t ualloc-t user ['] istuser-action setaction | |
649 | ; | |
650 | ||
651 | \ isvalue is in target.fth | |
652 | \ X : isvalue ( n acf -- ) >user-t n-t! ; | |
653 | : value \ name ( n -- ) | |
654 | safe-parse-word 3dup $equ | |
655 | " value-cf" $header-t /n-t ualloc-t n->n-t ,user#-t | |
656 | lastacf-t isvalue | |
657 | ['] isvalue-action setaction ?debug | |
658 | ; | |
659 | \ : buffer: \ name ( size -- ) | |
660 | \ " buffer-cf" header-t | |
661 | \ /n-t ualloc-t n->n-t ,user#-t \ user# | |
662 | \ n->n-t ,-t \ size | |
663 | \ here-t buffer-link-t a-t@ a,-t buffer-link-t ha-t! | |
664 | \ ; | |
665 | : code \ name ( -- ) | |
666 | " code-cf" header-t entercode ?debug | |
667 | ; | |
668 | ||
669 | : $label ( name$ -- ) | |
670 | show? @ if 2dup showsym then | |
671 | also labels definitions | |
672 | ['] labels $vcreate here-t , immediate-h | |
673 | previous definitions | |
674 | does> @ | |
675 | state @ case | |
676 | metacompiling of literal-t endof | |
677 | true of [compile] literal endof | |
678 | endcase | |
679 | ; | |
680 | : label \ name ( -- ) | |
681 | safe-parse-word 2dup " label-cf" $header-t entercode ( name$ ) | |
682 | $label | |
683 | ; | |
684 | ||
685 | \ Creates a label that will only exist in the metacompiler; | |
686 | \ When later executed, the label returns the target address where the | |
687 | \ label was defined. No changes are made to the target image as a result | |
688 | \ of defining the label. | |
689 | ||
690 | : mlabel \ name ( -- ) ( Later: -- adr-t ) | |
691 | safe-parse-word align-t acf-align-t $label | |
692 | ; | |
693 | : mloclabel \ name ( -- ) ( Later: -- adr-t ) | |
694 | safe-parse-word $label | |
695 | ; | |
696 | ||
697 | : code-field: \ name ( -- ) | |
698 | \ label | |
699 | mlabel meta-assemble entercode | |
700 | ; | |
701 | ||
702 | \ This vocabulary allocates space for its threads in the user area | |
703 | \ instead of in the dictionary. It is therefore ROMable. The existence | |
704 | \ of the voc-link in the dictionary does not compromise this, since | |
705 | \ the voc-link is only written once, when the vocabulary is created. | |
706 | lvariable voc-link-t | |
707 | : voc-link,-t ( -- ) | |
708 | lastacf-t voc-link-t link-t@ a,-t | |
709 | voc-link-t link-t! | |
710 | ; | |
711 | ||
712 | : set-threads-t ( name$ -- ) | |
713 | " forth" $= if | |
714 | threads-t lastacf-t isvocabulary | |
715 | else | |
716 | lastacf-t >user-t clear-threads-t | |
717 | then | |
718 | ; | |
719 | ||
720 | : definitions-t ( -- ) context-t @ >user-t current-t ! ; | |
721 | ||
722 | \ If we make several metacompiled vocabularies, we need to initialize | |
723 | \ the threads with link, to make them relocatable | |
724 | : vocabulary \ name ( -- ) | |
725 | safe-parse-word 2dup " vocabulary-cf" $header-t ( name ) | |
726 | \ The 1 extra thread is the "last" field | |
727 | #threads-t /link-t * ualloc-t ( name$ user# ) | |
728 | n->n-t ,user#-t ( name$ ) | |
729 | voc-link,-t ( name$ ) | |
730 | 2dup set-threads-t ( name$ ) | |
731 | ?debug ( name$ ) | |
732 | ['] isvocabulary-action setaction | |
733 | ['] meta $vcreate lastacf-t , does> @ context-t ! | |
734 | ; | |
735 | \ /defer-t is the number of user area bytes to alloc for a deferred word | |
736 | ||
737 | \ isdefer is in target.fth | |
738 | \ X : isdefer ( acf acf -- ) >user-t token-t! ; | |
739 | : defer-t \ name ( -- ) | |
740 | " defer-cf" header-t /defer-t ualloc-t n->n-t ,user#-t | |
741 | ?debug | |
742 | ['] isdefer-action setaction | |
743 | ; | |
744 | ||
745 | : compile-in-user-area ( -- compilation-base here ) | |
746 | compilation-base here-t | |
747 | 0 dp-t ! userarea-t is compilation-base \ Select user area | |
748 | ; | |
749 | : restore-dictionary ( compilation-base here -- ) | |
750 | dp-t ! is compilation-base | |
751 | ; | |
752 | ||
753 | transition definitions | |
754 | : does> ( -- ) | |
755 | host | |
756 | compile-t (does>) | |
757 | \ XXX the alignment should be done in startdoes; it is incorrect | |
758 | \ to assume that acf alignment is sufficient (code alignment might | |
759 | \ be stricter). | |
760 | align-t acf-align-t here-t doestarget ! | |
761 | " startdoes" $meta-execute | |
762 | target | |
763 | ; immediate | |
764 | ||
765 | : ;code ( -- ) | |
766 | host | |
767 | ?csp compile-t (;code) align-t acf-align-t here-t doestarget ! | |
768 | " start;code" $meta-execute | |
769 | [compile] [ reveal-t entercode | |
770 | target | |
771 | ; immediate | |
772 | ||
773 | : [compile] \ name ( -- ) | |
774 | host safe-parse-word $compile-t target | |
775 | ; immediate | |
776 | ||
777 | meta definitions | |
778 | ||
779 | \ Initialization of variables, defers, vocabularies, etc. | |
780 | \ Because this word is immediate, it can be used in the | |
781 | \ interpretive state as well as inside target-compiled | |
782 | \ colon definitions. | |
783 | \ The secret is that the "action" words set (via setaction ) | |
784 | \ for each defining-type are themselves state-smart, and will | |
785 | \ Do The Right Thing in either state. | |
786 | : is \ word ( ? -- ) | |
787 | safe-parse-word $sfind if ( acf-s ) | |
788 | dup resolution@ ( acf-s acf-t ) | |
789 | over do-action ( ) | |
790 | else | |
791 | .not-found | |
792 | then | |
793 | ; immediate | |
794 | ||
795 | alias is-t is immediate | |
796 | ||
797 | only forth also meta also definitions | |
798 | ||
799 | : metacompile-do-undefined ( pstr -- ) \ compile a forward reference | |
800 | count $compile-t | |
801 | ; | |
802 | ||
803 | : ]-t ( -- ) | |
804 | ['] metacompile-do-defined is-h do-defined | |
805 | [ifndef] oldhack | |
806 | ['] $metacompile-do-undefined is-h $do-undefined | |
807 | [else] | |
808 | ['] metacompile-do-undefined is-h do-undefined | |
809 | [then] | |
810 | ['] metacompile-do-literal is-h do-literal | |
811 | metacompiling state ! | |
812 | only forth labels also forth symbols also forth transition | |
813 | ; | |
814 | : [-t ( -- ) | |
815 | [compile] [ | |
816 | meta-base | |
817 | ; immediate | |
818 | : ;-t ( -- ) | |
819 | ?comp ?csp compile-t unnest reveal-t [compile] [-t | |
820 | ; immediate | |
821 | ||
822 | only forth also meta also definitions | |
823 | : immediate ( -- ) | |
824 | flags-t @ th 40 toggle-t \ fix target header | |
825 | immediate-s \ fix symbol table | |
826 | ; | |
827 | ||
828 | : :-t \ name ( -- ) | |
829 | !csp " colon-cf" header-t hide-t ]-t ?debug | |
830 | ['] iscolon-action setaction | |
831 | ; | |
832 | ||
833 | \ | |
834 | \ These are meta compiler versions of the fm/lib/chains.fth file | |
835 | \ the same rules apply just the implementation changes. | |
836 | \ | |
837 | : (overload:-t) ( str,len chain? -- ) | |
838 | -rot 2dup $sfind if ( chain? str,len acf ) | |
839 | resolved? if ( chain? str,len ) | |
840 | 2dup ( chain? str,len str,len ) | |
841 | else ( chain? str,len ) | |
842 | type ." must exist!" abort ( ) | |
843 | then ( chain? str,len ) | |
844 | else ( chain? str,len str,len ) | |
845 | 2drop 0 0 ( chain? str,len str,len ) | |
846 | then ( chain? str,len link,len ) | |
847 | 2swap ( chain? link,len str,len ) | |
848 | show? @ 0= if warning-t dup @ >r off then ( chain? link,len str,len ) | |
849 | header-control @ >r ( chain? link,len str,len ) | |
850 | r@ if headerless then ( chain? link,len str,len ) | |
851 | " colon-cf" $header-t hide-t ]-t ?debug ( chain? link,len ) | |
852 | ['] iscolon-action setaction ( chain? link,len ) | |
853 | rot if ( link,len ) | |
854 | ?dup if $compile-t else drop then ( ) | |
855 | else ( ) | |
856 | 2drop ( ) | |
857 | then ( ) | |
858 | r> header-control ! ( ) | |
859 | show? @ 0= if r> warning-t ! then ( ) | |
860 | ; | |
861 | ||
862 | : chain:-t \ name ( -- ) | |
863 | !csp safe-parse-word ( str,len ) | |
864 | true (overload:-t) ( ) | |
865 | ; | |
866 | ||
867 | : overload:-t \ name ( -- ) | |
868 | !csp safe-parse-word ( str,len ) | |
869 | false (overload:-t) ( ) | |
870 | ; | |
871 | ||
872 | \ Create functional equivalents of [ifexist] and [ifnexist] | |
873 | \ for use during metacompilation; these will search only the | |
874 | \ target dictionary instead of the host dictionary. | |
875 | \ If the word is found in the LABELS vocabulary, it "exists". | |
876 | \ Otherwise, if it is found in the SYMBOLS vocabulary it | |
877 | \ "exists" only if it is RESOLVED. | |
878 | \ We look in the SYMBOLS vocabulary first because things are | |
879 | \ more likely to be there. | |
880 | ||
881 | : meta-defined? ( -- meta-defined? ) \ name | |
882 | safe-parse-word $sfind if | |
883 | resolved? | |
884 | else ['] labels $vfind nip ?dup nip | |
885 | then | |
886 | ; | |
887 | ||
888 | : [ifnexist]-t ( -- ) \ name | |
889 | meta-defined? 0= postpone [if] | |
890 | ; | |
891 | : [ifexist]-t ( -- ) \ name | |
892 | meta-defined? postpone [if] | |
893 | ; | |
894 | ||
895 | ||
896 | \ Turn on the metacompiler by | |
897 | \ changing the words used by the assembler to store into the dictionary. | |
898 | \ They should store into the target dictionary instead of the host one. | |
899 | ||
900 | only forth meta also forth also definitions | |
901 | ||
902 | : metaon ( -- ) | |
903 | meta-compile | |
904 | install-target-assembler | |
905 | meta-xref-on | |
906 | ; | |
907 | : metaoff ( -- ) | |
908 | forth definitions | |
909 | install-host-assembler | |
910 | meta-xref-off | |
911 | ; | |
912 | ||
913 | meta assembler definitions | |
914 | : 'body \ name ( -- apf ) | |
915 | [ meta ] | |
916 | ' ( acf-of-variable ) | |
917 | >body-t | |
918 | [ assembler ] | |
919 | ; | |
920 | ||
921 | meta definitions | |
922 | alias [ifexist] [ifexist]-t | |
923 | alias [ifnexist] [ifnexist]-t | |
924 | alias : :-t | |
925 | alias chain: chain:-t | |
926 | alias overload: overload:-t | |
927 | alias ] ]-t | |
928 | alias /n /n-t | |
929 | alias /w /w-t | |
930 | alias /l /l-t | |
931 | alias /a /a-t | |
932 | alias #talign #talign-t | |
933 | alias /token /token-t | |
934 | alias /link /link-t | |
935 | alias , ,-t | |
936 | alias l, l,-t | |
937 | alias w, w,-t | |
938 | alias c, c,-t | |
939 | alias defer defer-t | |
940 | ||
941 | alias 16\ 16\ | |
942 | alias 32\ 32\ | |
943 | alias 64\ 64\ | |
944 | alias \itc \itc-t | |
945 | alias \dtc \dtc-t | |
946 | alias \t16 \t16-t | |
947 | alias \t32 \t32-t | |
948 | ||
949 | alias here here-t | |
950 | alias origin origin-t | |
951 | ||
952 | transition definitions | |
953 | alias [ [-t | |
954 | alias ; ;-t | |
955 | alias is is-t | |
956 | alias ['] [']-t | |
957 | alias 16\ 16\ | |
958 | alias 32\ 32\ | |
959 | alias 64\ 64\ | |
960 | alias \itc \itc-t | |
961 | alias \dtc \dtc-t | |
962 | alias \t16 \t16-t | |
963 | alias \t32 \t32-t | |
964 | alias .( .( | |
965 | alias ( ( | |
966 | alias (s ( | |
967 | alias \ \ | |
968 | alias [ifdef] [ifdef] | |
969 | alias [ifndef] [ifndef] | |
970 | alias [if] [if] | |
971 | alias [else] [else] | |
972 | alias [then] [then] | |
973 | alias [defined] [defined] | |
974 | alias [define] [define] | |
975 | alias [undef] [undef] | |
976 | alias [ifexist] [ifexist]-t | |
977 | alias [ifnexist] [ifnexist]-t | |
978 | ||
979 | only forth also meta assembler definitions | |
980 | alias .( .( | |
981 | alias ( ( | |
982 | alias (s ( | |
983 | alias \ \ | |
984 | ||
985 | only forth also definitions |