Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: kerncode.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: @(#)kerncode.fth 2.43 07/06/05 10:54:47 | |
43 | purpose: | |
44 | copyright: Copyright 2007 Sun Microsystems, Inc. All Rights Reserved. | |
45 | copyright: Copyright 1985-1990 Bradley Forthware | |
46 | copyright: Use is subject to license terms. | |
47 | ||
48 | \ ident "@(#)kerncode.fth 2.43 07/06/05 SMI" | |
49 | ||
50 | \ Meta compiler source for the Forth 83 kernel code words. | |
51 | \ TODO: | |
52 | \ separate heads. | |
53 | \ Change code-field: so that when compiled into a metacompiler definition, | |
54 | \ that word would return the 0-relative address. When compiled into a | |
55 | \ target definition, the word would return the absolute address. Essentially, | |
56 | \ we need to define "dolabel" very early in the kernel source. | |
57 | ||
58 | meta | |
59 | hex | |
60 | ||
61 | \ Allocate and clear the initial user area image | |
62 | \ mlabel init-user-area | |
63 | setup-user-area | |
64 | ||
65 | extend-meta-assembler | |
66 | ||
67 | \ ---- Assembler macros that reside in the host environment | |
68 | \ and assemble code for the target environment | |
69 | ||
70 | \ Forth Virtual Machine registers | |
71 | ||
72 | \ Note that the Forth Stack Pointer (%g7) is NOT the same register that | |
73 | \ C uses for the stack pointer (%o6). The hardware does all sorts of | |
74 | \ funny things with the C stack pointer when you do save and restore | |
75 | \ instructions, and when the register windows overflow. | |
76 | ||
77 | :-h sp %i5 ;-h :-h base %g2 ;-h :-h up %g3 ;-h | |
78 | :-h tos %g4 ;-h :-h ip %i3 ;-h :-h rp %i4 ;-h | |
79 | ||
80 | \ Scratch Registers | |
81 | :-h scr %l0 ;-h :-h sc1 %l1 ;-h :-h sc2 %l2 ;-h :-h sc3 %l3 ;-h | |
82 | :-h sc4 %l4 ;-h :-h sc5 %l5 ;-h :-h sc6 %l6 ;-h :-h sc7 %l7 ;-h | |
83 | ||
84 | :-h spc %o7 ;-h \ Saved Program Counter - set by the CALL instruction | |
85 | ||
86 | \ Macros: | |
87 | ||
88 | \ Parameter Field Address | |
89 | \t32-t \dtc-t :-h apf ( -- ) spc 8 ;-h | |
90 | \t32-t \itc-t :-h apf ( -- ) sc1 4 ;-h | |
91 | \t16-t :-h apf ( -- ) sc1 2 ;-h | |
92 | ||
93 | \ Put a bubble in the pipeline to patch the load interlock bug | |
94 | :-h bubble ( nop ) ;-h | |
95 | ||
96 | 32\ :-h slln ( rs1 rs2 rd -- ) sll ;-h | |
97 | 32\ :-h srln ( rs1 rs2 rd -- ) srl ;-h | |
98 | 32\ :-h sran ( rs1 rs2 rd -- ) sra ;-h | |
99 | 32\ :-h nget ( ptr off dst -- ) ld ;-h | |
100 | 32\ :-h nput ( src off ptr -- ) st ;-h | |
101 | ||
102 | 64\ :-h slln ( rs1 rs2 rd -- ) sllx ;-h | |
103 | 64\ :-h srln ( rs1 rs2 rd -- ) srlx ;-h | |
104 | 64\ :-h sran ( rs1 rs2 rd -- ) srax ;-h | |
105 | 64\ :-h nget ( ptr off dst -- ) ldx ;-h | |
106 | 64\ :-h nput ( src off ptr -- ) stx ;-h | |
107 | ||
108 | :-h lget ( ptr dst -- ) 0 swap ld ;-h | |
109 | :-h lput ( src ptr -- ) 0 swap st ;-h | |
110 | ||
111 | :-h get ( ptr dst -- ) 0 swap nget ;-h | |
112 | :-h put ( src ptr -- ) 0 swap nput ;-h | |
113 | ||
114 | :-h move ( src dst -- ) %g0 -rot add ;-h | |
115 | :-h ainc ( ptr -- ) dup /n swap add ;-h | |
116 | :-h adec ( ptr -- ) dup /n swap sub ;-h | |
117 | :-h push ( src ptr -- ) dup adec put ;-h | |
118 | :-h pop ( ptr dst -- ) over -rot get ainc ;-h | |
119 | :-h test ( src -- ) %g0 %g0 addcc ;-h | |
120 | :-h cmp ( s1 s2 -- ) %g0 subcc ;-h | |
121 | \ Get a token | |
122 | :-h rtget ( srca srcb dst -- ) | |
123 | \t16-t dup >r lduh r> ( dst ) | |
124 | \t16-t tshift-t over sll | |
125 | ||
126 | \t32-t ld bubble | |
127 | \t32-t \ We could increment a counter here to gather statistics with | |
128 | \t32-t \ no speed penalty in the 32-bit ! | |
129 | ||
130 | ;-h | |
131 | \ Get a branch offset | |
132 | :-h bget ( src dst -- ) | |
133 | \t8-t 0 swap ldsb \ Is the limited range a problem? | |
134 | \t16-t 0 swap ldsh | |
135 | 32\ \t32-t 0 swap ld | |
136 | 64\ \t32-t tuck 0 swap lduw | |
137 | 64\ \t32-t 0 over sra | |
138 | ;-h | |
139 | ||
140 | :-h /n* /n * ;-h | |
141 | ||
142 | :-h 'user# \ name ( -- user# ) | |
143 | ' ( acf-of-user-variable ) >body-t | |
144 | \t32-t l@-t | |
145 | \t16-t w@-t | |
146 | ;-h | |
147 | :-h 'user \ name ( -- user-addressing-mode ) | |
148 | meta-asm[ up 'user# ]meta-asm | |
149 | ;-h | |
150 | :-h 'body \ name ( -- variable-apf ) | |
151 | ' ( acf-of-user-variable ) >body-t | |
152 | ;-h | |
153 | :-h 'acf \ name ( -- variable-apf ) | |
154 | ' ( acf-of-user-variable ) >body-t | |
155 | ;-h | |
156 | :-h set ( value reg -- ) | |
157 | 2dup sethi swap h# 3ff land swap tuck add | |
158 | ;-h | |
159 | ||
160 | \ There are a few places in the code where moving the previous instruction | |
161 | \ to the delay slot of the "next jmp" instruction won't work. Generally | |
162 | \ these are places where a control structure ends just before "next". | |
163 | \ inhibit-delay assembles a nop instruction in cases where that is needed. | |
164 | \ This ought to be done by the assembler, but it is hard to figure out. | |
165 | :-h inhibit-delay | |
166 | \t16-t meta-asm[ nop ]meta-asm | |
167 | ;-h | |
168 | ||
169 | \ assembler macro to assemble next | |
170 | :-h next | |
171 | meta-asm[ | |
172 | \t8-t byte-next always branchif | |
173 | \t8-t nop \ XXX should be token-table sc2 sethi | |
174 | ||
175 | \t16-t here-t 4 - l@-t here-t l!-t \ Advance previous instruction | |
176 | \t16-t h# 81c0.e000 here-t 4 - l!-t 4 allot-t \ up 0 %g0 jmpl instr. | |
177 | ||
178 | \t32-t ip 0 scr rtget | |
179 | \t32-t scr base %g0 jmpl | |
180 | \t32-t ip /token-t ip add | |
181 | ]meta-asm | |
182 | ;-h | |
183 | :-h c; next end-code ;-h | |
184 | ||
185 | \t16-t \itc :-h tld ( src offset dst -- ) | |
186 | \t16-t \itc dup >r lduh | |
187 | \t16-t \itc r@ tshift-t r> sll | |
188 | \t16-t \itc ;-h | |
189 | ||
190 | \ Create the code for "next" in the user area | |
191 | ||
192 | \t16-t compile-in-user-area | |
193 | ||
194 | mlabel (next) \ Shared code for next; will be copied into user area | |
195 | \t16 ip 0 sc1 rtget | |
196 | \t16 sc1 base sc1 add | |
197 | \t16 sc1 0 scr rtget | |
198 | \t16 scr base %g0 jmpl | |
199 | \t16 ip /token-t ip add | |
200 | \t16-t end-code | |
201 | \t16-t restore-dictionary | |
202 | ||
203 | \itc-t d# 64 equ #user-init \ Leaves space for the shared "next" | |
204 | ||
205 | meta-compile | |
206 | ||
207 | ||
208 | \ ---- Action code for target words classes. | |
209 | ||
210 | \ "docode" eliminates the need to separately acf-align both the code field | |
211 | \ and the body of a code definition, thus saving 12 bytes per code definition | |
212 | \ in the t16s4 version. | |
213 | ||
214 | \t16-t tshift-t 4 = [if] | |
215 | \t16-t code-field: docode | |
216 | \t16-t apf 2 + %g0 jmpl | |
217 | \t16-t nop | |
218 | \t16-t end-code | |
219 | \t16-t [then] | |
220 | ||
221 | code-field: dolabel | |
222 | \itc sp adec | |
223 | \dtc \ The label's code field contains dolabel call sp adec | |
224 | ||
225 | tos sp put \ Push the apf of the variable | |
226 | apf tos add | |
227 | ||
228 | \itc tos 3 tos add \ Align to a longword boundary | |
229 | \itc tos 3 tos andn | |
230 | c; | |
231 | ||
232 | code-field: docolon | |
233 | \itc rp adec | |
234 | \dtc \ The colon definition's code field contains docolon call rp adec | |
235 | ip rp put \ Save the ip on the return stack | |
236 | apf ip add \ Reload ip with apf of colon definition | |
237 | c; | |
238 | ||
239 | code-field: docreate | |
240 | \itc sp adec | |
241 | \dtc \ The word's code field contains docreate call sp adec | |
242 | tos sp put \ Push the apf of the variable | |
243 | apf tos add | |
244 | c; | |
245 | ||
246 | \ In-dictionary variables are a leftover from the earliest FORTH | |
247 | \ implementations. They have no place in a ROMable target-system | |
248 | \ and we are deprecating support for them; but Just In Case you | |
249 | \ ever want to restore support for them, define the command-line | |
250 | \ symbol: in-dictionary-variables | |
251 | [ifdef] in-dictionary-variables | |
252 | \ Support for in-dictionary variables, i.e., where the variable's | |
253 | \ storage location is in the dictionary rather than in user-space. | |
254 | code-field: dovariable | |
255 | \itc sp adec | |
256 | \dtc \ The variable's code field contains dovariable call sp adec | |
257 | tos sp put \ Push the apf of the variable | |
258 | apf tos add | |
259 | c; | |
260 | \ Hey, waidaminit! This is the same as docreate just above! | |
261 | \ An in-dictionary variable could be as simple as create 0 , ... | |
262 | [then] | |
263 | ||
264 | code-field: douser | |
265 | \itc sp adec | |
266 | \dtc \ The user variable's code field contains douser call sp adec | |
267 | tos sp put | |
268 | \t16 apf scr lduh \ Get the user number | |
269 | \t32 apf scr ld \ Get the user number | |
270 | bubble | |
271 | scr up tos add \ Add the base address of the user area | |
272 | c; | |
273 | ||
274 | code-field: dovalue | |
275 | \itc sp adec | |
276 | \dtc \ The value's code field contains dovalue call sp adec | |
277 | tos sp put | |
278 | \t16 apf scr lduh \ Get the user number | |
279 | \t32 apf scr ld \ Get the user number | |
280 | bubble | |
281 | scr up tos nget \ Get the contents of the user area location | |
282 | c; | |
283 | ||
284 | \ Defers could run faster by compiling the defer offset into the instruction | |
285 | \ as in up user# scr ld scr base %g0 jmpl nop | |
286 | \ But it would be harder to compile, metacompile, decompile, and set | |
287 | ||
288 | code-field: dodefer | |
289 | \dtc \ The user variable's code field contains dodefer call apf scr ld | |
290 | \t32 scr up scr ld \ Get the acf stored in that user location | |
291 | \t32 bubble | |
292 | ||
293 | \t16 apf scr lduh | |
294 | \t16 scr up sc1 tld \ Get the acf stored in that user location | |
295 | \t16 sc1 base scr rtget \ Read the token | |
296 | ||
297 | scr base %g0 jmpl \ Execute that word | |
298 | \t16 sc1 base sc1 add | |
299 | ||
300 | nop | |
301 | end-code | |
302 | ||
303 | code-field: doconstant | |
304 | \itc sp adec | |
305 | \dtc \ The constant's code field contains doconstant call sp adec | |
306 | tos sp put | |
307 | \dtc apf tos ld \ Get the constant's value | |
308 | 64\ \dtc tos 20 tos sllx | |
309 | 64\ \dtc apf 4 + scr ld | |
310 | 64\ \dtc tos scr tos or | |
311 | ||
312 | \itc apf tos lduh \ Get the high halfword of the constant's value | |
313 | \itc tos 10 tos slln \ Shift into high halfword | |
314 | \itc apf 2 + scr lduh \ Get the low halfword of the constant's value | |
315 | \itc scr tos tos add \ Merge the two halves | |
316 | 64\ \itc tos 10 tos slln | |
317 | 64\ \itc apf 4 + scr lduh | |
318 | 64\ \itc scr tos tos add | |
319 | 64\ \itc tos 10 tos slln | |
320 | 64\ \itc apf 6 + scr lduh | |
321 | 64\ \itc scr tos tos add | |
322 | c; | |
323 | ||
324 | code-field: do2constant | |
325 | \itc sp adec | |
326 | \dtc \ The constant's code field contains do2constant call sp adec | |
327 | sp adec \ Make room on the stack | |
328 | tos sp /n nput \ Save the old tos on the memory stack | |
329 | ||
330 | \dtc apf tos ld \ Get the bottom constant's value | |
331 | ||
332 | 64\ \dtc tos th 20 tos sllx | |
333 | 64\ \dtc apf 4 + scr ld | |
334 | 64\ \dtc tos scr tos or | |
335 | ||
336 | \dtc tos sp put \ Put it on the memory stack | |
337 | \dtc apf /n + tos ld \ Get the top constant's value | |
338 | ||
339 | 64\ \dtc tos th 20 tos sllx | |
340 | 64\ \dtc apf /n 4 + + scr ld | |
341 | 64\ \dtc tos scr tos or | |
342 | ||
343 | \itc apf tos lduh \ Get the high halfword of the bottom value | |
344 | \itc tos sp 0 sth \ Store on stack | |
345 | \itc apf /w + tos lduh \ Get the low halfword of the bottom value | |
346 | \itc tos sp 2 sth \ Store on stack | |
347 | ||
348 | \itc apf /n + tos lduh \ Get the high halfword of the top value | |
349 | \itc tos 10 tos sll \ Shift into high halfword | |
350 | \itc apf /n /w + + scr lduh \ Get the low halfword of the top value | |
351 | \itc scr tos tos add \ Merge the two halves | |
352 | c; | |
353 | ||
354 | code-field: dodoes | |
355 | \itc \ The child word's code field contains a pointer to the doesclause | |
356 | \dtc \ The child word's code field contains doesclause call apf scr add | |
357 | \ The doesclause's code field contains dodoes call sp adec | |
358 | tos sp put | |
359 | \dtc scr tos move | |
360 | \itc apf tos add | |
361 | ip rp push | |
362 | \dtc apf ip add | |
363 | \itc spc 8 ip add | |
364 | c; | |
365 | ||
366 | \ ---- Define the format of target code fields by creating host | |
367 | \ words that will create target code fields. | |
368 | ||
369 | :-h place-cf-t ( action-apf -- ) | |
370 | aligned-t | |
371 | \dtc-t meta-asm[ ( action-adr ) call sp adec ]meta-asm | |
372 | \itc-t token,-t | |
373 | ;-h | |
374 | ||
375 | :-h code-cf ( -- ) | |
376 | \itc-t \t32-t here /token-t + aligned | |
377 | \itc-t \t16-t [ tshift-t 4 <> ]-h [if] here /token-t + aligned [else] docode [then] | |
378 | \itc-t place-cf-t align-t | |
379 | ;-h | |
380 | ||
381 | :-h colon-cf ( -- ) ( 'body-t ) docolon place-cf-t | |
382 | \dtc-t -4 allot-t meta-asm[ rp adec ]meta-asm | |
383 | ;-h | |
384 | ||
385 | :-h defer-cf ( -- ) | |
386 | ( 'body-t ) dodefer place-cf-t | |
387 | \dtc-t -4 allot-t meta-asm[ apf scr ld ]meta-asm | |
388 | ;-h | |
389 | ||
390 | :-h label-cf ( -- ) ( 'body-t ) dolabel place-cf-t align-t ;-h | |
391 | :-h constant-cf ( -- ) ( 'body-t ) doconstant place-cf-t ;-h | |
392 | :-h create-cf ( -- ) ( 'body-t ) docreate place-cf-t ;-h | |
393 | [ifdef] in-dictionary-variables | |
394 | :-h variable-cf ( -- ) ( 'body-t ) dovariable place-cf-t ;-h | |
395 | [then] | |
396 | :-h user-cf ( -- ) ( 'body-t ) douser place-cf-t ;-h | |
397 | :-h value-cf ( -- ) ( 'body-t ) dovalue place-cf-t ;-h | |
398 | :-h startdoes ( -- ) | |
399 | \dtc-t ( 'body-t ) dodoes place-cf-t | |
400 | \itc-t meta-asm[ dodoes call sp adec ]meta-asm | |
401 | ;-h | |
402 | :-h start;code ( -- ) ;-h | |
403 | :-h vocabulary-cf ( -- ) | |
404 | \ The forward reference will be resolved later by fix-vocabularies | |
405 | compile-t <vocabulary> | |
406 | ||
407 | \dtc-t meta-asm[ apf scr add ]meta-asm \ Address of parameter field | |
408 | ||
409 | ;-h | |
410 | ||
411 | ||
412 | \ ---- Run-time words compiled by compiling words. | |
413 | ||
414 | headerless | |
415 | \ We can do better; combine the incrementing in ip ainc with that in next | |
416 | code (lit) ( -- n ) | |
417 | tos sp push | |
418 | ||
419 | \t16 ip 0 scr lduh scr 10 scr slln ip 2 tos lduh scr tos tos add | |
420 | 64\ \t16 tos 10 tos slln ip 4 scr lduh | |
421 | 64\ \t16 tos scr tos add tos 10 tos slln ip 6 scr lduh scr tos tos add | |
422 | ||
423 | 32\ \t32 ip 0 tos nget | |
424 | 64\ \t32 ip 0 scr lduw scr 20 scr sllx ip 4 tos lduw scr tos tos add | |
425 | ip ainc | |
426 | c; | |
427 | ||
428 | code (wlit) ( -- n ) | |
429 | tos sp push | |
430 | \t16 ip 0 tos lduh ip 2 ip add tos 1 tos sub | |
431 | \t32 ip tos get ip ainc | |
432 | c; | |
433 | ||
434 | code (llit) ( -- n ) | |
435 | \t32 tos sp push | |
436 | \t32 ip tos lget | |
437 | 64\ \t32 tos 1 tos sub | |
438 | 64\ \t32 ip /l ip add | |
439 | 32\ \t32 ip ainc | |
440 | ||
441 | \t16 tos sp push | |
442 | \t16 ip 0 scr lduh | |
443 | \t16 scr 10 scr slln | |
444 | \t16 ip 2 tos lduh | |
445 | \t16 scr tos tos add | |
446 | 64\ \t16 tos 1 tos sub | |
447 | \t16 ip /l ip add | |
448 | c; | |
449 | ||
450 | \ High level branch. The branch offset is compiled in-line. | |
451 | code branch ( -- ) | |
452 | ( 0 L: ) mloclabel bran1 | |
453 | ip scr bget \ branch | |
454 | ip scr ip add | |
455 | c; | |
456 | ||
457 | \ High level conditional branch. | |
458 | code ?branch ( f -- ) \ Takes the branch if the flag is false | |
459 | tos 0 %g0 addcc | |
460 | sp tos get | |
461 | ( 0 B: ) bran1 0= brif | |
462 | sp ainc \ Delay slot | |
463 | ip /branch ip add | |
464 | c; | |
465 | ||
466 | \ Run time word for loop | |
467 | code (loop) ( -- ) | |
468 | rp scr get | |
469 | bubble | |
470 | scr 1 scr addcc \ increment loop index | |
471 | ( 0 B: ) bran1 vc brif \ branch if not done | |
472 | scr rp put \ Write back the loop index (delay slot) | |
473 | rp 3 /n* rp add \ done; remove loop params from stack | |
474 | ip /branch ip add \ Skip the branch offset | |
475 | c; | |
476 | ||
477 | \ Run time word for +loop | |
478 | code (+loop) ( increment -- ) | |
479 | rp scr get | |
480 | bubble | |
481 | scr tos scr addcc \ increment loop index | |
482 | scr rp put \ Write back the loop index | |
483 | sp tos get | |
484 | bran1 ( 0 B: ) vc brif \ branch if not done | |
485 | sp ainc \ Delay slot | |
486 | rp 3 /n* rp add \ done; remove loop params from stack | |
487 | ip /branch ip add \ Skip the branch offset | |
488 | c; | |
489 | ||
490 | \ Run time word for do | |
491 | code (do) ( l i -- ) | |
492 | tos sc1 move \ i in sc1 | |
493 | sp scr get \ l in scr | |
494 | sp 1 /n* tos nget | |
495 | sp 2 /n* sp add | |
496 | ( 1 L: ) mloclabel pd0 ( -- r: loop-end-offset l+0x8000 i-l-0x8000 ) | |
497 | ip rp push \ remember the do offset address | |
498 | ip /branch ip add \ skip the do offset | |
499 | h# 8000.0000 sc2 sethi | |
500 | 64\ sc2 h# 20 sc2 sllx | |
501 | scr sc2 scr add | |
502 | scr rp push | |
503 | sc1 scr sc1 sub | |
504 | sc1 rp push | |
505 | c; | |
506 | meta | |
507 | ||
508 | \ Run time word for ?do | |
509 | code (?do) ( l i -- ) | |
510 | tos sc1 move \ i in sc1 | |
511 | sp scr get \ l in scr | |
512 | sp 1 /n* tos nget | |
513 | sc1 scr cmp | |
514 | ( 1 B: ) pd0 0<> brif | |
515 | sp 2 /n* sp add | |
516 | ip scr bget \ branch | |
517 | scr ip ip add | |
518 | c; | |
519 | ||
520 | headers | |
521 | \ Loop index for current do loop | |
522 | code i ( -- n ) | |
523 | tos sp push | |
524 | rp tos get | |
525 | rp 1 /n* scr nget | |
526 | bubble | |
527 | tos scr tos add | |
528 | c; | |
529 | ||
530 | \ Loop index for next enclosing do loop | |
531 | code j ( -- n ) | |
532 | tos sp push | |
533 | rp 3 /n* tos nget | |
534 | rp 4 /n* scr nget | |
535 | bubble | |
536 | tos scr tos add | |
537 | c; | |
538 | ||
539 | headerless | |
540 | code (leave) ( -- ) | |
541 | ( 2 L: ) mloclabel pleave | |
542 | rp 2 /n* ip nget \ Get the address of the ending offset | |
543 | rp 3 /n* rp add \ get rid of the loop indices | |
544 | ip scr bget \ branch | |
545 | ip scr ip add | |
546 | c; | |
547 | ||
548 | code (?leave) ( f -- ) | |
549 | tos test | |
550 | sp tos get | |
551 | ( 2 B: ) pleave 0<> brif | |
552 | sp ainc | |
553 | inhibit-delay | |
554 | c; | |
555 | ||
556 | headers | |
557 | code unloop ( -- ) rp 3 /n* rp add c; \ Discard the loop indices | |
558 | ||
559 | headerless | |
560 | code (of) ( selector test -- [ selector ] ) | |
561 | sp scr pop \ Test in tos, Selector in scr | |
562 | scr tos cmp | |
563 | 0= if | |
564 | scr tos move \ Delay slot - Copy selector to tos | |
565 | sp tos pop | |
566 | ip /branch ip add \ Skip the branch offset | |
567 | next | |
568 | then | |
569 | ip scr bget | |
570 | ip scr ip add \ Take the branch | |
571 | c; | |
572 | ||
573 | \ (endof) is the same as branch, and (endcase) is the same as drop, | |
574 | \ but redefining them this way makes the decompiler much easier. | |
575 | ||
576 | code (endof) ( -- ) ip scr bget ip scr ip add c; | |
577 | code (endcase) ( n -- ) sp tos pop c; | |
578 | ||
579 | \ ---- Ordinary Forth words. | |
580 | ||
581 | headers | |
582 | \ Execute a Forth word given a code field address | |
583 | code execute ( acf -- ) | |
584 | \dtc tos scr move | |
585 | \dtc sp tos get | |
586 | \dtc scr 0 %g0 jmpl | |
587 | \dtc sp ainc | |
588 | ||
589 | \itc tos sc1 move | |
590 | \itc sp tos get | |
591 | \itc sc1 0 scr rtget | |
592 | \itc scr base %g0 jmpl | |
593 | \itc sp ainc | |
594 | end-code | |
595 | ||
596 | assembler ( 3 L: ) mlabel dofalse 0 tos move next meta | |
597 | ||
598 | \ Convert a character to a digit according to the current base | |
599 | code digit ( char base -- digit true | char false ) | |
600 | tos scr move \ base in scr | |
601 | sp tos get \ char in tos | |
602 | tos ascii 0 tos subcc \ convert to number | |
603 | ( 3 B: ) dofalse < brif \ Anything less than ascii 0 isn't a digit | |
604 | tos h# 0a cmp \ test for >= 10 | |
605 | >= if annul \ Try for a letter representing a digit | |
606 | tos scr cmp \ Compare digit to base | |
607 | ||
608 | tos ascii A ascii 0 - cmp | |
609 | ( 3 B: ) dofalse < brif \ bad if > '9' and < 'A' | |
610 | tos ascii a ascii 0 - cmp | |
611 | >= if | |
612 | tos ascii A ascii 0 - d# 10 - tos sub \ Delay | |
613 | tos ascii a ascii A - tos sub | |
614 | then | |
615 | tos scr cmp \ Compare digit to base | |
616 | then | |
617 | ( 3 B: ) dofalse >= brif \ Not a digit | |
618 | nop | |
619 | tos sp put \ Replace the char on the stack with the digit | |
620 | -1 tos move \ True to indicate success | |
621 | c; | |
622 | ||
623 | \ Copy cnt characters starting at from-addr to to-addr. Copying is done | |
624 | \ strictly from low to high addresses, so be careful of overlap between the | |
625 | \ two buffers. | |
626 | ||
627 | code cmove ( src dst cnt -- ) \ Copy from bottom to top | |
628 | sp 1 /n* scr nget \ Src into scr | |
629 | sp 0 /n* sc1 nget \ Dst into sc1 | |
630 | ||
631 | scr tos scr add \ Src = src+cnt (optimize for low-to-high copy) | |
632 | sc1 tos sc1 add \ Dst = dst+cnt | |
633 | sc1 1 sc1 sub \ Account for the position of the addcc instruction | |
634 | %g0 tos tos subcc \ Negate cnt | |
635 | ||
636 | <> if | |
637 | nop | |
638 | begin | |
639 | scr tos sc2 ldub \ (delay) Load byte | |
640 | tos 1 tos addcc \ (delay) Increment cnt | |
641 | >= until | |
642 | sc2 sc1 tos stb \ Store byte | |
643 | then | |
644 | ||
645 | sp 2 /n* tos nget \ Delete 3 stack items | |
646 | sp 3 /n* sp add \ " | |
647 | c; | |
648 | ||
649 | code cmove> ( src dst cnt -- ) \ Copy from top to bottom | |
650 | sp 1 /n* scr nget \ Src into scr | |
651 | sp 0 /n* sc1 nget \ Dst into sc1 | |
652 | ||
653 | sc1 1 sc1 add \ Account for the position of the subcc instruction | |
654 | ||
655 | tos 0 cmp \ Don't do anything if the count is 0. | |
656 | <> if | |
657 | tos 1 tos sub \ Decrement cnt (startup loop) | |
658 | ||
659 | begin | |
660 | scr tos sc2 ldub \ (delay) Load byte | |
661 | tos 1 tos subcc \ (delay) Decrement cnt | |
662 | < until | |
663 | sc2 sc1 tos stb \ Store byte | |
664 | then | |
665 | ||
666 | sp 2 /n* tos nget \ Delete 3 stack items | |
667 | sp 3 /n* sp add \ " | |
668 | c; | |
669 | ||
670 | code and ( n1 n2 -- n3 ) sp scr pop tos scr tos and c; | |
671 | code or ( n1 n2 -- n3 ) sp scr pop tos scr tos or c; | |
672 | code xor ( n1 n2 -- n3 ) sp scr pop tos scr tos xor c; | |
673 | ||
674 | code << ( n1 cnt -- n2 ) sp scr pop scr tos tos slln c; | |
675 | code >> ( n1 cnt -- n2 ) sp scr pop scr tos tos srln c; | |
676 | code >>a ( n1 cnt -- n2 ) sp scr pop scr tos tos sran c; | |
677 | code lshift ( n1 cnt -- n2 ) sp scr pop scr tos tos slln c; | |
678 | code rshift ( n1 cnt -- n2 ) sp scr pop scr tos tos srln c; | |
679 | ||
680 | code + ( n1 n2 -- n3 ) sp scr pop tos scr tos add c; | |
681 | code - ( n1 n2 -- n3 ) sp scr pop scr tos tos sub c; | |
682 | ||
683 | code invert ( n1 -- n2 ) tos -1 tos xor c; | |
684 | code negate ( n1 -- n2 ) %g0 tos tos sub c; | |
685 | ||
686 | \ Mark the first code-definition in the dictionary; | |
687 | \ we will need it later... | |
688 | \ XXX We might be able to make this low-dictionary-adr | |
689 | \ XXX and move that from debugm.fth (or debugm16.fth ) | |
690 | headerless | |
691 | : first-code-word ( -- acf ) (') (lit) ; | |
692 | headers | |
693 | ||
694 | : abs ( n1 -- n2 ) dup 0< if negate then ; | |
695 | ||
696 | : min ( n1 n2 -- n3 ) 2dup > if swap then drop ; | |
697 | : max ( n1 n2 -- n3 ) 2dup < if swap then drop ; | |
698 | : umin ( u1 u2 -- u3 ) 2dup u> if swap then drop ; | |
699 | : umax ( u1 u2 -- u3 ) 2dup u< if swap then drop ; | |
700 | ||
701 | code up@ ( -- addr ) tos sp push up tos move c; | |
702 | code sp@ ( -- addr ) tos sp push sp tos move c; | |
703 | code rp@ ( -- addr ) tos sp push rp tos move c; | |
704 | code up! ( addr -- ) tos up move sp tos pop c; | |
705 | code sp! ( addr -- ) tos sp move sp tos pop c; | |
706 | code rp! ( addr -- ) tos rp move sp tos pop c; | |
707 | code >r ( n -- ) tos rp push sp tos pop c; | |
708 | code r> ( -- n ) tos sp push rp tos pop c; | |
709 | code r@ ( -- n ) tos sp push rp tos get c; | |
710 | code >user ( pfa -- addr ) | |
711 | \t32 tos %g0 scr lduw | |
712 | \t16 tos %g0 scr lduh | |
713 | up scr tos add | |
714 | c; | |
715 | code 2>r ( n1 n2 -- ) | |
716 | rp /n 2* rp sub | |
717 | sp scr get | |
718 | scr rp /n nput | |
719 | tos rp 0 nput | |
720 | sp /n tos nget | |
721 | sp /n 2* sp add | |
722 | c; | |
723 | code 2r> ( -- n1 n2 ) | |
724 | sp /n 2* sp sub | |
725 | tos sp /n nput | |
726 | rp /n tos nget | |
727 | tos sp 0 nput | |
728 | rp 0 tos nget | |
729 | rp /n 2* rp add | |
730 | c; | |
731 | code 2r@ ( -- n1 n2 ) | |
732 | sp /n 2* sp sub | |
733 | tos sp /n nput | |
734 | rp /n tos nget | |
735 | tos sp 0 nput | |
736 | rp 0 tos nget | |
737 | c; | |
738 | ||
739 | code >ip ( n -- ) tos rp push sp tos pop c; | |
740 | code ip> ( -- n ) tos sp push rp tos pop c; | |
741 | code ip@ ( -- n ) tos sp push rp tos get c; | |
742 | : ip>token ( ip -- token-adr ) /token - ; | |
743 | ||
744 | code exit ( -- ) rp ip pop c; | |
745 | code unnest ( -- ) rp ip pop c; | |
746 | ||
747 | code tuck ( n1 n2 -- n2 n1 n2 ) | |
748 | sp scr get | |
749 | bubble | |
750 | scr sp push | |
751 | tos sp /n nput | |
752 | c; | |
753 | code nip ( n1 n2 -- n2 ) | |
754 | sp ainc | |
755 | c; | |
756 | code flip ( w1 -- w2 ) \ byte-swap the low two bytes; clear the rest. | |
757 | tos 0ff scr and \ lowest byte into scr | |
758 | scr 8 scr slln \ lowest byte into second byte of scr | |
759 | tos 8 tos srln \ second byte into lowest byte of tos | |
760 | tos 0ff tos and \ clear the rest of tos | |
761 | tos scr tos or | |
762 | c; | |
763 | ||
764 | extend-meta-assembler | |
765 | :-h leaveflag ( condition -- ) | |
766 | \ macro to assemble code to leave a flag on the stack | |
767 | if | |
768 | 0 tos move \ Delay slot | |
769 | -1 tos move | |
770 | then | |
771 | inhibit-delay | |
772 | ;-h | |
773 | ||
774 | meta-compile | |
775 | ||
776 | code 0= ( n -- f ) tos test 0= leaveflag c; | |
777 | code 0<> ( n -- f ) tos test 0<> leaveflag c; | |
778 | code 0< ( n -- f ) tos test 0< leaveflag c; | |
779 | code 0<= ( n -- f ) tos test <= leaveflag c; | |
780 | code 0> ( n -- f ) tos test > leaveflag c; | |
781 | code 0>= ( n -- f ) tos test 0>= leaveflag c; | |
782 | ||
783 | extend-meta-assembler | |
784 | :-h compare | |
785 | sp scr pop | |
786 | scr tos cmp | |
787 | ;-h | |
788 | meta-compile | |
789 | ||
790 | code < ( n1 n2 -- f ) compare < leaveflag c; | |
791 | code > ( n1 n2 -- f ) compare > leaveflag c; | |
792 | code = ( n1 n2 -- f ) compare 0= leaveflag c; | |
793 | code <> ( n1 n2 -- f ) compare <> leaveflag c; | |
794 | code u> ( n1 n2 -- f ) compare u> leaveflag c; | |
795 | code u<= ( n1 n2 -- f ) compare u<= leaveflag c; | |
796 | code u< ( n1 n2 -- f ) compare u< leaveflag c; | |
797 | code u>= ( n1 n2 -- f ) compare u>= leaveflag c; | |
798 | code >= ( n1 n2 -- f ) compare >= leaveflag c; | |
799 | code <= ( n1 n2 -- f ) compare <= leaveflag c; | |
800 | ||
801 | code drop ( n -- ) sp tos pop c; | |
802 | code ?dup ( n -- 0|n,n) | |
803 | tos %g0 %g0 subcc | |
804 | 0<> if | |
805 | nop | |
806 | tos sp push | |
807 | then | |
808 | inhibit-delay | |
809 | c; | |
810 | code dup ( n -- n n ) tos sp push c; | |
811 | code over ( n1 n2 -- n1 n2 n1 ) tos sp push sp /n tos nget c; | |
812 | code swap ( n1 n2 -- n2 n1 ) | |
813 | sp scr get | |
814 | tos sp put | |
815 | scr tos move | |
816 | c; | |
817 | code rot ( n1 n2 n3 -- n2 n3 n1 ) | |
818 | sp 0 /n* scr nget | |
819 | sp 1 /n* sc1 nget | |
820 | scr sp 1 /n* nput | |
821 | tos sp 0 /n* nput | |
822 | sc1 tos move | |
823 | c; | |
824 | code -rot ( n1 n2 n3 -- n3 n1 n2 ) | |
825 | sp 0 /n* scr nget | |
826 | sp 1 /n* sc1 nget | |
827 | tos sp 1 /n* nput | |
828 | sc1 sp 0 /n* nput | |
829 | scr tos move | |
830 | c; | |
831 | code 2drop ( d -- ) sp ainc sp tos pop c; | |
832 | code 2dup ( d -- d d ) | |
833 | sp scr get | |
834 | sp 2 /n* sp sub | |
835 | tos sp 1 /n* nput | |
836 | scr sp 0 /n* nput | |
837 | c; | |
838 | code 2over ( d1 d2 -- d1 d2 d1 ) | |
839 | sp 2 /n* sp sub | |
840 | tos sp 1 /n* nput | |
841 | sp 4 /n* tos nget | |
842 | bubble | |
843 | tos sp 0 /n* nput | |
844 | sp 3 /n* tos nget | |
845 | c; | |
846 | code 2swap ( d1 d2 -- d2 d1 ) | |
847 | sp 2 /n* sc2 nget | |
848 | sp 1 /n* sc1 nget | |
849 | sp 0 /n* scr nget | |
850 | bubble | |
851 | scr sp 2 /n* nput | |
852 | tos sp 1 /n* nput | |
853 | sc2 sp 0 /n* nput | |
854 | sc1 tos move | |
855 | c; | |
856 | code 3drop ( n1 n2 n3 -- ) | |
857 | sp 2 /n* tos nget | |
858 | sp 3 /n* sp add | |
859 | c; | |
860 | code 3dup ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 ) | |
861 | sp 1 /n* sc1 nget | |
862 | sp 0 /n* scr nget | |
863 | sp 3 /n* sp sub | |
864 | tos sp 2 /n* nput | |
865 | sc1 sp 1 /n* nput | |
866 | scr sp 0 /n* nput | |
867 | c; | |
868 | ||
869 | code pick ( nm ... n1 n0 k -- nm ... n2 n0 nk ) | |
870 | 32\ tos 2 tos sll \ Multiply by /n | |
871 | 64\ tos 3 tos sllx \ Multiply by /n | |
872 | sp tos tos nget \ Index into stack | |
873 | c; | |
874 | ||
875 | code 1+ ( n1 -- n2 ) tos 1 tos add c; | |
876 | code 2+ ( n1 -- n2 ) tos 2 tos add c; | |
877 | code 1- ( n1 -- n2 ) tos 1 tos sub c; | |
878 | code 2- ( n1 -- n2 ) tos 2 tos sub c; | |
879 | ||
880 | code 2/ ( n1 -- n2 ) tos 1 tos sran c; | |
881 | code u2/ ( n1 -- n2 ) tos 1 tos srln c; | |
882 | code 2* ( n1 -- n2 ) tos 1 tos slln c; | |
883 | code 4* ( n1 -- n2 ) tos 2 tos slln c; | |
884 | code 8* ( n1 -- n2 ) tos 3 tos slln c; | |
885 | ||
886 | code on ( addr -- ) | |
887 | -1 scr move | |
888 | \dtc scr tos 0 st | |
889 | 64\ \dtc scr tos 4 st | |
890 | 64\ \itc scr tos 4 sth | |
891 | 64\ \itc scr tos 6 sth | |
892 | \itc scr tos 0 sth | |
893 | \itc scr tos 2 sth | |
894 | sp tos pop | |
895 | c; | |
896 | code off ( addr -- ) | |
897 | \dtc %g0 tos 0 st | |
898 | 64\ \dtc %g0 tos 4 st | |
899 | 64\ \itc %g0 tos 6 sth | |
900 | 64\ \itc %g0 tos 4 sth | |
901 | \itc %g0 tos 0 sth | |
902 | \itc %g0 tos 2 sth | |
903 | sp tos pop | |
904 | c; | |
905 | ||
906 | code +! ( n addr -- ) | |
907 | sp 0 /n* scr nget | |
908 | \dtc tos sc1 lget | |
909 | ||
910 | 64\ \dtc sc1 20 sc1 slln | |
911 | 64\ \dtc tos /l sc2 ld | |
912 | 64\ \dtc sc1 sc2 sc1 add | |
913 | ||
914 | \itc tos 0 sc1 lduh | |
915 | \itc sc1 10 sc1 slln | |
916 | \itc tos 2 sc2 lduh | |
917 | \itc sc1 sc2 sc1 add | |
918 | ||
919 | 64\ \itc tos 4 sc2 lduh | |
920 | 64\ \itc sc1 10 sc1 slln | |
921 | 64\ \itc sc1 sc2 sc1 add | |
922 | ||
923 | 64\ \itc tos 6 sc2 lduh | |
924 | 64\ \itc sc1 10 sc1 slln | |
925 | 64\ \itc sc1 sc2 sc1 add | |
926 | ||
927 | sc1 scr sc1 add | |
928 | ||
929 | 64\ \dtc sc1 tos /l st | |
930 | 64\ \dtc sc1 20 sc1 srln | |
931 | \dtc sc1 tos lput | |
932 | ||
933 | 64\ \itc sc1 tos 6 sth | |
934 | 64\ \itc sc1 10 sc1 srln | |
935 | 64\ \itc sc1 tos 4 sth | |
936 | 64\ \itc sc1 10 sc1 srln | |
937 | ||
938 | \itc sc1 tos 2 sth | |
939 | \itc sc1 10 sc1 srln | |
940 | \itc sc1 tos 0 sth | |
941 | ||
942 | sp 1 /n* tos nget | |
943 | sp 2 /n* sp add | |
944 | c; | |
945 | ||
946 | code @ ( addr -- n ) | |
947 | 64\ \dtc tos 0 scr ld | |
948 | 64\ \dtc scr 20 scr slln | |
949 | 64\ \dtc tos 4 tos ld | |
950 | 64\ \dtc tos scr tos or | |
951 | ||
952 | 64\ \itc tos 0 sc1 lduh | |
953 | 64\ \itc sc1 10 scr slln | |
954 | 64\ \itc tos 2 sc1 lduh | |
955 | 64\ \itc sc1 scr scr or | |
956 | 64\ \itc scr 10 scr slln | |
957 | 64\ \itc tos 4 sc1 lduh | |
958 | 64\ \itc sc1 scr scr or | |
959 | 64\ \itc scr 10 scr slln | |
960 | 64\ \itc tos 6 sc1 lduh | |
961 | 64\ \itc sc1 scr tos or | |
962 | ||
963 | 32\ \dtc tos 0 tos ld | |
964 | ||
965 | 32\ \itc tos 2 scr lduh | |
966 | 32\ \itc tos 0 tos lduh | |
967 | 32\ \itc tos 10 tos slln | |
968 | 32\ \itc scr tos tos add | |
969 | c; | |
970 | ||
971 | code d@ ( addr -- nlow nhigh ) | |
972 | tos 0 scr ldd | |
973 | sc1 sp push | |
974 | scr tos move | |
975 | c; | |
976 | ||
977 | 64\ code x@ ( addr -- x ) \ doubleword aligned | |
978 | 64\ tos tos get | |
979 | 64\ c; | |
980 | ||
981 | code l@ ( addr -- l ) \ longword aligned | |
982 | tos tos lget | |
983 | c; | |
984 | ||
985 | 32\ code <l@ ( addr -- l ) tos 0 tos ld c; | |
986 | code w@ ( addr -- w ) \ 16-bit word aligned | |
987 | tos 0 tos lduh | |
988 | c; | |
989 | ||
990 | 32\ code <w@ ( addr -- w ) tos 0 tos ldsh c; \ with sign extension | |
991 | 64\ code <w@ ( addr -- w ) | |
992 | 64\ tos 0 tos lduh | |
993 | 64\ tos d# 48 tos sllx | |
994 | 64\ tos d# 48 tos srax | |
995 | 64\ c; | |
996 | 64\ code <l@ ( addr -- l ) | |
997 | 64\ tos 0 tos lduw | |
998 | 64\ tos 0 tos sra | |
999 | 64\ c; | |
1000 | ||
1001 | code c@ ( addr -- c ) | |
1002 | tos 0 tos ldub | |
1003 | c; | |
1004 | ||
1005 | code unaligned-@ ( addr -- l ) | |
1006 | tos 0 scr ldub | |
1007 | tos 1 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1008 | tos 2 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1009 | tos 3 sc1 ldub scr 8 scr slln | |
1010 | 64\ scr sc1 scr add | |
1011 | 64\ tos 4 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1012 | 64\ tos 5 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1013 | 64\ tos 6 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1014 | 64\ tos 7 sc1 ldub scr 8 scr slln | |
1015 | scr sc1 tos add | |
1016 | c; | |
1017 | code be-l@ ( addr -- l ) | |
1018 | tos 0 scr ldub | |
1019 | tos 1 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1020 | tos 2 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1021 | tos 3 sc1 ldub scr 8 scr slln scr sc1 tos add | |
1022 | c; | |
1023 | code unaligned-l@ ( addr -- l ) | |
1024 | tos 0 scr ldub | |
1025 | tos 1 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1026 | tos 2 sc1 ldub scr 8 scr slln scr sc1 scr add | |
1027 | tos 3 sc1 ldub scr 8 scr slln scr sc1 tos add | |
1028 | c; | |
1029 | code unaligned-w@ ( addr -- w ) | |
1030 | tos 0 scr ldub | |
1031 | tos 1 sc1 ldub scr 8 scr slln scr sc1 tos add | |
1032 | c; | |
1033 | ||
1034 | \ 16-bit token version doesn't require alignment on a word boundary | |
1035 | code ! ( n addr -- ) | |
1036 | ( 4 L: ) mloclabel start-of-! | |
1037 | sp 0 scr nget | |
1038 | bubble | |
1039 | ||
1040 | 64\ \dtc scr tos /l st | |
1041 | 64\ \dtc scr 20 scr srln | |
1042 | \dtc scr tos 0 st | |
1043 | ||
1044 | 64\ \itc scr tos 6 sth | |
1045 | 64\ \itc scr 10 scr srln | |
1046 | 64\ \itc scr tos 4 sth | |
1047 | 64\ \itc scr 10 scr srln | |
1048 | ||
1049 | \itc scr tos 2 sth | |
1050 | \itc scr 10 scr srln | |
1051 | \itc scr tos 0 sth | |
1052 | ||
1053 | sp 1 /n* tos nget | |
1054 | sp 2 /n* sp add | |
1055 | c; | |
1056 | ||
1057 | headerless | |
1058 | \ These two words are sufficient to implement a very fast IS | |
1059 | \ The first will be applied to USER definitions (primarily VALUEs | |
1060 | \ but also VARIABLEs) and the second to DEFER words. | |
1061 | \ Their actions are the same as the obsolete (is) used to be; | |
1062 | \ the main difference is that the determination of the word-type | |
1063 | \ of the target of the IS is made at compile-time rather than | |
1064 | \ at run-time. | |
1065 | ||
1066 | code (is-user) ( n -- ) | |
1067 | tos sp push \ Do the (') in-line | |
1068 | ip 0 tos rtget \ Next token in caller | |
1069 | tos base tos add \ TOS <= ACF-of-next-token-in-caller | |
1070 | ip /token ip add \ Complete the (') | |
1071 | \ Do the >body in-line | |
1072 | tos 0 >body-t tos add | |
1073 | ||
1074 | tos %g0 scr \ Do the >user in-line | |
1075 | \t32 lduw | |
1076 | \t16 lduh | |
1077 | ||
1078 | ( 4 B: ) start-of-! bra \ Go to the ! | |
1079 | up scr tos add \ TOS <= user-addr of IS-target | |
1080 | end-code | |
1081 | ||
1082 | code (is-defer) ( acf -- ) | |
1083 | tos base scr sub \ Start the token! | |
1084 | \t16 scr tshift-t scr srl \ SCR <= token to store | |
1085 | \ Do the (') in-line | |
1086 | ip 0 tos rtget \ Next token in caller | |
1087 | ip /token ip add \ Bump past next token in caller | |
1088 | tos base tos add \ TOS <= ACF of next token | |
1089 | \ That completed the (') | |
1090 | ||
1091 | \ Do the >body in-line | |
1092 | tos 0 >body-t tos add | |
1093 | ||
1094 | tos %g0 sc1 \ Do the >user in-line | |
1095 | \t32 lduw | |
1096 | \t16 lduh | |
1097 | up sc1 tos add \ TOS <= user-addr of IS-target | |
1098 | ||
1099 | scr tos \ Complete the token! | |
1100 | \t16 0 sth | |
1101 | \t32 lput ( ???XXX tput ) | |
1102 | ||
1103 | sp tos pop | |
1104 | c; | |
1105 | ||
1106 | ||
1107 | headers | |
1108 | ||
1109 | ||
1110 | code d! ( n-low n-high addr -- ) | |
1111 | sp 0 /n* scr nget | |
1112 | sp 1 /n* sc1 nget | |
1113 | bubble | |
1114 | scr tos 0 std | |
1115 | sp 2 /n* tos nget | |
1116 | sp 3 /n* sp add | |
1117 | c; | |
1118 | 64\ code x! ( x addr -- ) | |
1119 | 64\ sp 0 scr nget | |
1120 | 64\ bubble | |
1121 | 64\ scr tos put | |
1122 | 64\ sp 1 /n* tos nget | |
1123 | 64\ sp 2 /n* sp add | |
1124 | 64\ c; | |
1125 | ||
1126 | code l! ( n addr -- ) | |
1127 | sp 0 scr nget | |
1128 | bubble | |
1129 | scr tos 0 st | |
1130 | sp 1 /n* tos nget | |
1131 | sp 2 /n* sp add | |
1132 | c; | |
1133 | code w! ( w addr -- ) | |
1134 | sp 0 scr nget | |
1135 | bubble | |
1136 | scr tos 0 sth | |
1137 | sp 1 /n* tos nget | |
1138 | sp 2 /n* sp add | |
1139 | c; | |
1140 | code c! ( c addr -- ) | |
1141 | sp 0 scr nget | |
1142 | bubble | |
1143 | scr tos 0 stb | |
1144 | sp 1 /n* tos nget | |
1145 | sp 2 /n* sp add | |
1146 | c; | |
1147 | ||
1148 | code unaligned-d! ( d addr -- ) | |
1149 | sp 0 scr nget | |
1150 | ||
1151 | 64\ scr tos 1 /n* 7 + stb | |
1152 | 64\ scr 8 scr srln scr tos 1 /n* 6 + stb | |
1153 | 64\ scr 8 scr srln scr tos 1 /n* 5 + stb | |
1154 | 64\ scr 8 scr srln scr tos 1 /n* 4 + stb | |
1155 | 64\ scr 8 scr srln | |
1156 | scr tos 1 /n* 3 + stb | |
1157 | scr 8 scr srln scr tos 1 /n* 2 + stb | |
1158 | scr 8 scr srln scr tos 1 /n* 1 + stb | |
1159 | scr 8 scr srln scr tos 1 /n* 0 + stb | |
1160 | ||
1161 | sp 1 /n* scr nget | |
1162 | ||
1163 | 64\ scr tos 7 stb | |
1164 | 64\ scr 8 scr srln scr tos 6 stb | |
1165 | 64\ scr 8 scr srln scr tos 5 stb | |
1166 | 64\ scr 8 scr srln scr tos 4 stb | |
1167 | 64\ scr 8 scr srln | |
1168 | scr tos 3 stb | |
1169 | scr 8 scr srln scr tos 2 stb | |
1170 | scr 8 scr srln scr tos 1 stb | |
1171 | scr 8 scr srln scr tos 0 stb | |
1172 | ||
1173 | sp 2 /n* tos nget | |
1174 | sp 3 /n* sp add | |
1175 | c; | |
1176 | code unaligned-! ( n addr -- ) | |
1177 | sp 0 scr nget | |
1178 | bubble | |
1179 | ||
1180 | 64\ scr tos 7 stb | |
1181 | 64\ scr 8 scr srln scr tos 6 stb | |
1182 | 64\ scr 8 scr srln scr tos 5 stb | |
1183 | 64\ scr 8 scr srln scr tos 4 stb | |
1184 | 64\ scr 8 scr srln | |
1185 | ||
1186 | scr tos 3 stb | |
1187 | scr 8 scr srln scr tos 2 stb | |
1188 | scr 8 scr srln scr tos 1 stb | |
1189 | scr 8 scr srln scr tos 0 stb | |
1190 | ||
1191 | sp 1 /n* tos nget | |
1192 | sp 2 /n* sp add | |
1193 | c; | |
1194 | code be-l! ( n addr -- ) | |
1195 | sp 0 scr nget | |
1196 | bubble | |
1197 | scr tos 3 stb | |
1198 | scr 8 scr srln scr tos 2 stb | |
1199 | scr 8 scr srln scr tos 1 stb | |
1200 | scr 8 scr srln scr tos 0 stb | |
1201 | sp 1 /n* tos nget | |
1202 | sp 2 /n* sp add | |
1203 | c; | |
1204 | \ In some versions, be-l, needs to set a swap bit | |
1205 | : be-l, ( l -- ) here /l allot be-l! ; | |
1206 | code unaligned-l! ( n addr -- ) | |
1207 | sp 0 scr nget | |
1208 | bubble | |
1209 | scr tos 3 stb | |
1210 | scr 8 scr srln scr tos 2 stb | |
1211 | scr 8 scr srln scr tos 1 stb | |
1212 | scr 8 scr srln scr tos 0 stb | |
1213 | sp 1 /n* tos nget | |
1214 | sp 2 /n* sp add | |
1215 | c; | |
1216 | code unaligned-w! ( w addr -- ) | |
1217 | sp 0 scr nget | |
1218 | bubble | |
1219 | scr tos 1 stb | |
1220 | scr 8 scr srl | |
1221 | scr tos 0 stb | |
1222 | sp 1 /n* tos nget | |
1223 | sp 2 /n* sp add | |
1224 | c; | |
1225 | ||
1226 | code 2@ ( addr -- d ) | |
1227 | tos /n sc1 lduh tos /n 2 + scr lduh sc1 10 sc1 slln | |
1228 | 64\ scr sc1 sc1 add tos /n 4 + scr lduh sc1 10 sc1 slln | |
1229 | 64\ scr sc1 sc1 add tos /n 6 + scr lduh sc1 10 sc1 slln | |
1230 | scr sc1 scr add | |
1231 | ||
1232 | scr sp push | |
1233 | ||
1234 | tos 0 sc1 lduh tos 2 scr lduh sc1 10 sc1 slln | |
1235 | 64\ scr sc1 sc1 add tos 4 scr lduh sc1 10 sc1 slln | |
1236 | 64\ scr sc1 sc1 add tos 6 scr lduh sc1 10 sc1 slln | |
1237 | ||
1238 | scr sc1 tos add | |
1239 | c; | |
1240 | code 2! ( d addr -- ) | |
1241 | sp 0 scr nget | |
1242 | bubble | |
1243 | ||
1244 | 64\ scr tos 6 sth scr 10 scr srln | |
1245 | 64\ scr tos 4 sth scr 10 scr srln | |
1246 | scr tos 2 sth scr 10 scr srln | |
1247 | scr tos 0 sth | |
1248 | ||
1249 | sp /n scr nget | |
1250 | ||
1251 | bubble | |
1252 | ||
1253 | 64\ scr tos /n 6 + sth scr 10 scr srln | |
1254 | 64\ scr tos /n 4 + sth scr 10 scr srln | |
1255 | scr tos /n 2 + sth scr 10 scr srln | |
1256 | scr tos /n 0 + sth | |
1257 | ||
1258 | sp 2 /n* tos nget | |
1259 | sp 3 /n* sp add | |
1260 | c; | |
1261 | ||
1262 | \ code fill ( start-addr count char -- ) | |
1263 | \ \ char in tos | |
1264 | \ sp 0 /n* scr nget \ count in scr | |
1265 | \ | |
1266 | \ scr %g0 %g0 subcc | |
1267 | \ > if | |
1268 | \ nop | |
1269 | \ sp 1 /n* sc1 nget \ start in sc1 | |
1270 | \ begin | |
1271 | \ scr 1 scr subcc | |
1272 | \ tos sc1 scr stb | |
1273 | \ 0= until | |
1274 | \ nop | |
1275 | \ then | |
1276 | \ | |
1277 | \ sp 2 /n* tos nget | |
1278 | \ sp 3 /n* sp add | |
1279 | \ c; | |
1280 | ||
1281 | code fill ( start-addr count char -- ) | |
1282 | \ tos = data byte | |
1283 | sp 0 /n* scr nget \ scr = count | |
1284 | \ sc1 = addr | |
1285 | ||
1286 | scr 10 %g0 subcc | |
1287 | >= if \ Enough to bother optimizing? | |
1288 | sp 1 /n* sc1 nget \ ( delay) sc1 = addr | |
1289 | ||
1290 | \ Store stray bytes at top of range | |
1291 | scr sc1 sc2 add \ Last+1 byte location in range | |
1292 | sc2 3 sc3 andcc \ Count - # extra bytes at top of range (0-3) | |
1293 | scr sc3 scr sub \ Adjust main counter for later | |
1294 | 0 F: bra \ Jump to the until branch | |
1295 | sc2 3 sc2 andn \ (delay) Starting adr at top (X X X 0|4) | |
1296 | begin | |
1297 | tos sc2 sc3 stb \ Store data byte | |
1298 | 0 L: | |
1299 | 0<= until | |
1300 | sc3 1 sc3 subcc \ (delay) | |
1301 | ||
1302 | \ Fill sc4-sc5 pair with repeated data bytes | |
1303 | tos ff sc4 and \ Mask all but desired byte | |
1304 | sc4 8 sc2 sll | |
1305 | sc4 sc2 sc4 or \ sc4 = 0000abab | |
1306 | sc4 10 sc2 sll | |
1307 | sc4 sc2 sc4 or \ sc4 = abababab | |
1308 | ||
1309 | \ Store bulk of data, as 32-bit words (4 bytes at a time) | |
1310 | \ Guaranteed to execute at least once | |
1311 | scr 4 scr subcc \ Pre-subtract count | |
1312 | 0 F: bra \ Jump to the until branch | |
1313 | sc1 4 sc3 add \ (delay) Pre-add starting address | |
1314 | begin | |
1315 | sc4 sc3 scr st \ Store sc4 data (4 bytes) | |
1316 | 0 L: | |
1317 | 0< until | |
1318 | scr 4 scr subcc \ (delay) | |
1319 | ||
1320 | scr 8 scr add \ Restore correct remaining count | |
1321 | then | |
1322 | ||
1323 | \ Store the few remaining bytes at bottom of range | |
1324 | 0 F: bra \ Jump to the until branch | |
1325 | scr 0 %g0 subcc \ (delay) | |
1326 | begin | |
1327 | tos sc1 scr stb \ Store data byte | |
1328 | 0 L: | |
1329 | 0<= until | |
1330 | scr 1 scr subcc \ (delay) | |
1331 | ||
1332 | sp 2 /n* tos nget \ Remove 3 items off of stack | |
1333 | sp 3 /n* sp add \ " | |
1334 | c; | |
1335 | ||
1336 | code noop ( -- ) inhibit-delay c; | |
1337 | ||
1338 | 32\ code n->l ( n.unsigned -- l ) inhibit-delay c; | |
1339 | 64\ code n->l ( n.unsigned -- l ) tos 0 tos srl c; | |
1340 | : s>d ( n -- d ) dup 0< ; \ Depends on true=-1, false=0 | |
1341 | ||
1342 | code wbsplit ( l -- b.low b.high ) | |
1343 | tos h# ff scr and | |
1344 | scr sp push | |
1345 | tos 8 tos srln | |
1346 | tos h# ff tos and | |
1347 | c; | |
1348 | ||
1349 | code bwjoin ( b.low b.high -- w ) | |
1350 | sp scr pop | |
1351 | scr h# ff scr and | |
1352 | tos h# ff tos and | |
1353 | tos 8 tos slln | |
1354 | tos scr tos or | |
1355 | c; | |
1356 | ||
1357 | code lwsplit ( l -- w.low w.high ) \ split a long into two words | |
1358 | tos scr move | |
1359 | scr 10 scr sll | |
1360 | scr 10 scr srl | |
1361 | scr sp push | |
1362 | tos 10 tos srl | |
1363 | c; | |
1364 | code wljoin ( w.low w.high -- l ) | |
1365 | sp scr pop | |
1366 | scr 10 scr sll \ Throw away any high order bits in w.low | |
1367 | scr 10 scr srl | |
1368 | tos 10 tos sll | |
1369 | tos scr tos or | |
1370 | c; | |
1371 | ||
1372 | 64\ code xlsplit ( x -- l.lo l.hi ) | |
1373 | 64\ tos 0 scr srl \ Clear high order 32 bits | |
1374 | 64\ scr sp push | |
1375 | 64\ tos h# 20 tos srln | |
1376 | 64\ c; | |
1377 | ||
1378 | 64\ code lxjoin ( l.lo l.hi -- x ) | |
1379 | 64\ sp scr pop | |
1380 | 64\ scr 0 scr srl \ Clear high order 32 bits | |
1381 | 64\ tos h# 20 tos slln | |
1382 | 64\ tos scr tos or | |
1383 | 64\ c; | |
1384 | ||
1385 | 1 constant /c | |
1386 | 2 constant /w | |
1387 | 4 constant /l | |
1388 | 8 constant /x | |
1389 | ||
1390 | 16\ /w constant /n | |
1391 | 32\ /l constant /n | |
1392 | 64\ /x constant /n | |
1393 | ||
1394 | code ca+ ( addr index -- addr+index*/c ) | |
1395 | sp scr pop | |
1396 | tos scr tos add | |
1397 | c; | |
1398 | code wa+ ( addr index -- addr+index*/w ) | |
1399 | sp scr pop | |
1400 | tos 1 tos sll | |
1401 | tos scr tos add | |
1402 | c; | |
1403 | code la+ ( addr index -- addr+index*/l ) | |
1404 | sp scr pop | |
1405 | tos 2 tos sll | |
1406 | tos scr tos add | |
1407 | c; | |
1408 | 64\ code xa+ ( addr index -- addr+index*/x ) | |
1409 | 64\ sp scr pop | |
1410 | 64\ tos 3 tos slln | |
1411 | 64\ tos scr tos add | |
1412 | 64\ c; | |
1413 | code na+ ( addr index -- addr+index*/n ) | |
1414 | sp scr pop | |
1415 | 16\ tos 1 tos slln \ Multiply by /n | |
1416 | 32\ tos 2 tos slln \ Multiply by /n | |
1417 | 64\ tos 3 tos slln \ Multiply by /n | |
1418 | tos scr tos add | |
1419 | c; | |
1420 | code ta+ ( addr index -- addr+index*/t ) | |
1421 | sp scr pop | |
1422 | \t16 tos 1 tos slln | |
1423 | \t32 tos 2 tos slln | |
1424 | tos scr tos add | |
1425 | c; | |
1426 | ||
1427 | code ca1+ ( addr -- addr+/w ) tos /c tos add c; | |
1428 | code char+ ( addr -- addr+/w ) tos /c tos add c; | |
1429 | code wa1+ ( addr -- addr+/w ) tos /w tos add c; | |
1430 | code la1+ ( addr -- addr+/l ) tos /l tos add c; | |
1431 | 64\ code xa1+ ( addr -- addr+/x ) tos /x tos add c; | |
1432 | code na1+ ( addr -- addr+/n ) tos /n tos add c; | |
1433 | code cell+ ( addr -- addr+/n ) tos /n tos add c; | |
1434 | code ta1+ ( addr -- addr+/token ) tos /token tos add c; | |
1435 | ||
1436 | code /c* ( n -- n*/c ) inhibit-delay c; | |
1437 | code chars ( n -- n*/c ) inhibit-delay c; | |
1438 | code /w* ( n -- n*/w ) tos 1 tos slln c; | |
1439 | code /l* ( n -- n*/l ) tos 2 tos slln c; | |
1440 | code /x* ( n -- n*/x ) tos 3 tos slln c; | |
1441 | 16\ code /n* ( n -- n*/n ) tos 1 tos slln c; \ Multiply by /n | |
1442 | 32\ code /n* ( n -- n*/n ) tos 2 tos slln c; \ Multiply by /n | |
1443 | 64\ code /n* ( n -- n*/n ) tos 3 tos slln c; \ Multiply by /n | |
1444 | 16\ code cells ( n -- n*/n ) tos 1 tos slln c; \ Multiply by /n | |
1445 | 32\ code cells ( n -- n*/n ) tos 2 tos slln c; \ Multiply by /n | |
1446 | 64\ code cells ( n -- n*/n ) tos 3 tos slln c; \ Multiply by /n | |
1447 | ||
1448 | code upc ( char -- upper-case-char ) | |
1449 | tos ascii a cmp | |
1450 | >= if | |
1451 | tos ascii z cmp | |
1452 | > if annul | |
1453 | tos ascii A ascii a - tos add | |
1454 | then | |
1455 | then | |
1456 | inhibit-delay | |
1457 | c; | |
1458 | code lcc ( char -- lower-case-char ) | |
1459 | tos ascii A cmp | |
1460 | >= if | |
1461 | tos ascii Z cmp | |
1462 | > if annul | |
1463 | tos ascii a ascii A - tos add | |
1464 | then | |
1465 | then | |
1466 | inhibit-delay | |
1467 | c; | |
1468 | ||
1469 | \ string compare - case sensitive | |
1470 | code comp ( addr1 addr2 len -- -1 | 0 | 1 ) | |
1471 | \ len in tos | |
1472 | sp 0 /n* scr nget \ addr2 in scr | |
1473 | sp 1 /n* sc1 nget \ addr1 is sc1 | |
1474 | ||
1475 | 0 F: bra \ jump to the subcc instruction | |
1476 | nop | |
1477 | begin | |
1478 | sc1 1 sc1 add | |
1479 | scr 0 sc3 ldub | |
1480 | scr 1 scr add | |
1481 | sc2 sc3 cmp | |
1482 | <> if nop | |
1483 | < if | |
1484 | 1 tos move \ Delay slot | |
1485 | -1 tos move | |
1486 | then | |
1487 | sp 2 /n* sp add | |
1488 | next | |
1489 | then | |
1490 | ||
1491 | \ branch target | |
1492 | 0 L: | |
1493 | tos 1 tos subcc | |
1494 | 0< until annul | |
1495 | sc1 0 sc2 ldub \ Delay slot | |
1496 | ||
1497 | 0 tos move | |
1498 | sp 2 /n* sp add | |
1499 | c; | |
1500 | ||
1501 | \ string compare - case insensitive | |
1502 | code caps-comp ( addr1 addr2 len -- -1 | 0 | 1 ) | |
1503 | \ len in tos | |
1504 | sp 0 /n* scr nget \ addr2 in scr | |
1505 | sp 1 /n* sc1 nget \ addr1 is sc1 | |
1506 | ||
1507 | 0 F: bra \ jump to the subcc instruction | |
1508 | nop | |
1509 | begin | |
1510 | sc1 1 sc1 add | |
1511 | scr 0 sc3 ldub | |
1512 | scr 1 scr add | |
1513 | sc2 ascii a cmp | |
1514 | >= if | |
1515 | sc2 ascii z cmp \ Delay slot | |
1516 | <= if nop | |
1517 | sc2 ascii A ascii a - sc2 add | |
1518 | then | |
1519 | then | |
1520 | sc3 ascii a cmp | |
1521 | >= if | |
1522 | sc3 ascii z cmp \ Delay slot | |
1523 | <= if nop | |
1524 | sc3 ascii A ascii a - sc3 add | |
1525 | then | |
1526 | then | |
1527 | sc2 sc3 cmp | |
1528 | <> if nop | |
1529 | < if | |
1530 | 1 tos move \ Delay slot | |
1531 | -1 tos move | |
1532 | then | |
1533 | sp 2 /n* sp add | |
1534 | next | |
1535 | then | |
1536 | ||
1537 | \ branch target | |
1538 | 0 L: | |
1539 | tos 1 tos subcc | |
1540 | 0< until annul | |
1541 | sc1 0 sc2 ldub \ Delay slot | |
1542 | ||
1543 | 0 tos move | |
1544 | sp 2 /n* sp add | |
1545 | c; | |
1546 | ||
1547 | code pack ( str-addr len to -- to ) | |
1548 | sp scr pop \ scr is len | |
1549 | sp sc1 pop \ sc1 is "from"; tos is "to" | |
1550 | ||
1551 | scr ff scr and \ Never store more than 257 bytes | |
1552 | ||
1553 | scr tos 0 stb \ Place length byte | |
1554 | ||
1555 | tos 1 tos add \ Offset "to" by 1 to skip past the length byte | |
1556 | ||
1557 | %g0 tos scr stb \ Put a null byte at the end | |
1558 | ||
1559 | 0 F: bra \ jump to the until branch | |
1560 | scr 1 scr subcc \ Delay slot | |
1561 | ||
1562 | begin | |
1563 | sc2 tos scr stb | |
1564 | scr 1 scr subcc | |
1565 | 0 L: | |
1566 | 0< until annul | |
1567 | sc1 scr sc2 ldub \ Delay slot | |
1568 | ||
1569 | tos 1 tos sub \ Fix "to" to point to the length byte | |
1570 | c; | |
1571 | ||
1572 | code (') ( -- acf ) | |
1573 | tos sp push | |
1574 | ip 0 tos rtget | |
1575 | ip /token ip add | |
1576 | tos base tos add | |
1577 | c; | |
1578 | \ Modifies caller's ip to skip over an in-line string | |
1579 | code skipstr ( -- addr len) | |
1580 | sp 2 /n* sp sub | |
1581 | tos sp 1 /n* nput | |
1582 | rp 0 scr nget \ Get string address in scr | |
1583 | bubble | |
1584 | scr 0 tos ldub \ Get length byte in tos | |
1585 | scr 1 scr add \ Address of data bytes | |
1586 | scr sp 0 /n* nput \ Put addr on stack | |
1587 | ||
1588 | \ Now we have to skip the string | |
1589 | scr tos scr add \ Scr now points past the last data byte | |
1590 | scr #talign scr add \ Round up to token boundary + null byte | |
1591 | scr #talign 1- scr andn | |
1592 | scr rp 0 nput \ Put the modified ip back | |
1593 | c; | |
1594 | code (") ( -- addr len) | |
1595 | sp 2 /n* sp sub | |
1596 | tos sp /n nput | |
1597 | ip 0 tos ldub \ Get length byte in tos | |
1598 | ip 1 ip add \ Address of data bytes | |
1599 | ip sp 0 nput \ Put addr on stack | |
1600 | ||
1601 | \ Now we have to skip the string | |
1602 | ip tos ip add \ ip now points past the last data byte | |
1603 | ip #talign ip add \ Round up to a token boundary, plus null byte | |
1604 | ip #talign 1- ip andn | |
1605 | c; | |
1606 | code count ( addr -- addr+1 len ) | |
1607 | tos 1 tos add | |
1608 | tos -1 scr ldub | |
1609 | tos sp push | |
1610 | scr tos move | |
1611 | c; | |
1612 | ||
1613 | code between ( n min max -- f ) | |
1614 | tos scr move \ max | |
1615 | sp sc2 pop \ min | |
1616 | sp sc3 pop \ n | |
1617 | sc3 sc2 %g0 subcc | |
1618 | 0>= if | |
1619 | %g0 tos move \ (delay) | |
1620 | sc3 scr %g0 subcc | |
1621 | 0> if | |
1622 | %g0 1 tos sub \ (delay) | |
1623 | %g0 tos move | |
1624 | then | |
1625 | then | |
1626 | inhibit-delay | |
1627 | c; | |
1628 | ||
1629 | code within ( n1 min max+1 -- f ) | |
1630 | tos scr move \ max | |
1631 | sp sc2 pop \ min | |
1632 | sp sc3 pop \ n | |
1633 | sc3 sc2 %g0 subcc | |
1634 | 0>= if | |
1635 | %g0 tos move \ (delay) | |
1636 | sc3 scr %g0 subcc | |
1637 | 0< if | |
1638 | %g0 tos move \ (delay) | |
1639 | %g0 1 tos sub | |
1640 | then | |
1641 | then | |
1642 | inhibit-delay | |
1643 | c; | |
1644 | ||
1645 | code bounds ( adr len -- adr+len adr ) | |
1646 | tos scr move \ len | |
1647 | sp sc1 pop \ adr | |
1648 | sc1 tos sc2 add \ adr+len | |
1649 | sc2 sp push | |
1650 | sc1 tos move | |
1651 | c; | |
1652 | ||
1653 | code origin ( -- addr ) | |
1654 | tos sp push | |
1655 | base tos move | |
1656 | c; | |
1657 | code origin+ ( n -- adr ) | |
1658 | tos base tos add | |
1659 | c; | |
1660 | code origin- ( n -- adr ) | |
1661 | tos base tos sub | |
1662 | c; | |
1663 | ||
1664 | code i-flush ( adr -- ) | |
1665 | tos 0 iflush \ This may cause a trap on MP machines | |
1666 | sp tos pop | |
1667 | c; | |
1668 | ||
1669 | \ : instruction! ( bits adr -- ) | |
1670 | \ tuck l! i-flush | |
1671 | \ ; | |
1672 | code instruction! ( bits adr -- ) | |
1673 | sp scr get | |
1674 | scr tos 0 st | |
1675 | tos 0 iflush \ This may cause a trap on MP machines | |
1676 | sp 1 /n* tos nget | |
1677 | sp 2 /n* sp add | |
1678 | c; | |
1679 | ||
1680 | : instruction, ( opcode -- ) | |
1681 | here /l allot instruction! | |
1682 | ; | |
1683 | ||
1684 | \ ---- Support words for the incremental compiler | |
1685 | ||
1686 | headerless | |
1687 | ||
1688 | \ Create constants to represent the instructions that go into the | |
1689 | \ delay-slots of the code-fields of various definition-types. | |
1690 | \ We can use the assembler itself to construct the instruction. | |
1691 | \ This is more efficient and accurate than using literal numerics, | |
1692 | \ and will also be handy in determining definition-types. | |
1693 | ||
1694 | \ Because constant is not yet properly defined, we have to use the | |
1695 | \ assembler to create the code-field of a constant definition-type. | |
1696 | \ This turns out to be not too bad, because we need the assembler anyway... | |
1697 | ||
1698 | \ Integer value of the instruction that goes into the delay-slot | |
1699 | \ after the call in: create variable user value constant | |
1700 | \ and in the doesclause of a defining word that uses does> | |
1701 | \ | |
1702 | \ The instruction itself: | |
1703 | \ Decrements the Stack Pointer. | |
1704 | \dtc code dec-sp-instr | |
1705 | \dtc doconstant call | |
1706 | \dtc sp adec \ Execute this in the delay slot | |
1707 | \dtc 64\ 0 l, \ High-half of longword constant for 64-bit platforms | |
1708 | \dtc sp adec \ This is the constant! = 8e21e00 /n or | |
1709 | \dtc end-code | |
1710 | ||
1711 | \itc label dec-sp-instr #align-t negate allot-t \ Kind of suckey, | |
1712 | \ but at least it works. | |
1713 | \ \itc code-field: dec-sp-instr \ Tried this instead; it failed BIG TIME! | |
1714 | ||
1715 | \itc doconstant token,-t | |
1716 | \itc 64\ 0 l, \ High-half of longword constant for 64-bit platforms | |
1717 | \itc sp adec \ This is the constant! = 8e21e00 /n or | |
1718 | \itc do-exitcode | |
1719 | ||
1720 | ||
1721 | \dtc \ Integer value of the instruction that goes into the delay-slot | |
1722 | \dtc \ after the call in the CF of a word defined by : (colon). | |
1723 | \dtc \ | |
1724 | \dtc \ The instruction itself: | |
1725 | \dtc \ Decrements the Return-Stack Pointer. | |
1726 | \dtc code dec-rp-instr | |
1727 | \dtc doconstant call | |
1728 | \dtc sp adec \ Execute this in the delay slot | |
1729 | \dtc 64\ 0 l, \ High-half of longword constant for 64-bit platforms | |
1730 | \dtc rp adec \ This is the constant! = 8c21a000 /n or | |
1731 | \dtc end-code | |
1732 | ||
1733 | ||
1734 | \dtc \ Integer value of the instruction that goes into the delay-slot | |
1735 | \dtc \ after the call in the CF of a child word of a does> definer | |
1736 | \dtc \ or in the CF of an action: of a word defined with used . | |
1737 | \dtc \ | |
1738 | \dtc \ The instruction itself: | |
1739 | \dtc \ Adds 8 to the PC in %o7, yielding the PFA, which goes into scr | |
1740 | \dtc code pfa>scr-instr | |
1741 | \dtc doconstant call | |
1742 | \dtc sp adec \ Execute this in the delay slot | |
1743 | \dtc 64\ 0 l, \ High-half of longword constant for 64-bit platforms | |
1744 | \dtc apf scr add \ This is the constant! = a003e008 | |
1745 | \dtc end-code | |
1746 | ||
1747 | ||
1748 | \dtc \ Integer value of the instruction that goes into the delay-slot | |
1749 | \dtc \ after the call in the CF of a defer word. | |
1750 | \dtc \ | |
1751 | \dtc \ The instruction itself: | |
1752 | \dtc \ Adds 8 to the PC in %o7, yielding the PFA, and loads the | |
1753 | \dtc \ contents of that location (i.e., the first Parameter) into scr | |
1754 | \dtc code param>scr-instr | |
1755 | \dtc doconstant call | |
1756 | \dtc sp adec \ Execute this in the delay slot | |
1757 | \dtc 64\ 0 l, \ High-half of longword constant for 64-bit platforms | |
1758 | \dtc apf scr ld \ This is the constant! = e003e008 | |
1759 | \dtc end-code | |
1760 | ||
1761 | ||
1762 | ||
1763 | ||
1764 | \ Prepare the 30-bit-wide longword-offset for a call or branch instruction | |
1765 | : >offset-30 ( target-addr where -- longword-offset ) | |
1766 | - | |
1767 | 64\ n->l | |
1768 | 2 >> | |
1769 | ; | |
1770 | \ Put a call instruction to target-addr at where | |
1771 | : put-call ( target-addr where -- ) | |
1772 | tuck >offset-30 ( where longword-offset ) | |
1773 | 4000.0000 or ( where call-instruction ) | |
1774 | swap instruction! | |
1775 | ; | |
1776 | ||
1777 | \ Put a branch instruction to target-addr at where | |
1778 | : put-branch ( target-addr where -- ) | |
1779 | tuck >offset-30 ( where longword-offset ) | |
1780 | 3f.ffff and ( where branch-offset ) | |
1781 | 3080.0000 or ( where branch-instruction ) | |
1782 | swap instruction! | |
1783 | ; | |
1784 | ||
1785 | \ Replace the delay slot of the previous code field | |
1786 | : set-delay-slot ( delay-instruction -- ) here /l - instruction! ; | |
1787 | ||
1788 | : place-call ( action-adr -- ) | |
1789 | origin+ acf-align here /l 2* allot put-call | |
1790 | dec-sp-instr set-delay-slot \ sp adec | |
1791 | ; | |
1792 | ||
1793 | \ Place the "standard" code field, with a "sp /n sp sub" instruction | |
1794 | \ in the delay slot | |
1795 | : place-cf ( action-adr -- ) | |
1796 | \dtc place-call | |
1797 | \itc origin+ acf-align token, | |
1798 | ; | |
1799 | : code-cf ( -- ) | |
1800 | \dtc acf-align | |
1801 | \itc \t32 here ta1+ aligned origin - | |
1802 | \itc \t16 [ tshift-t 4 <> ] [if] here ta1+ aligned origin - [else] docode [then] | |
1803 | \itc place-cf align | |
1804 | ; | |
1805 | : >code ( acf-of-code-word -- address-of-start-of-machine-code ) | |
1806 | \itc >body aligned | |
1807 | ; | |
1808 | \dtc : code? ( acf -- f ) \ True if the acf is for a code word | |
1809 | \dtc c@ h# c0 and h# 40 <> \ Most non-code words start with a call instr. | |
1810 | \dtc ; | |
1811 | ||
1812 | \itc \t16 tshift-t 4 <> [if] | |
1813 | \itc \t16 : code? ( acf -- f ) | |
1814 | \itc \t16 dup token@ swap 2dup 2 + = >r 4 + = r> or | |
1815 | \itc \t16 ; | |
1816 | \itc \t16 [else] | |
1817 | \itc \t16 : code? ( acf -- f ) | |
1818 | \itc \t16 token@ origin- docode = | |
1819 | \itc \t16 ; | |
1820 | \itc \t16 [then] | |
1821 | ||
1822 | headers | |
1823 | : next ( --- ) | |
1824 | \ ip 0 scr ld | |
1825 | \ scr base %g0 jmpl | |
1826 | \ ip /token ip add | |
1827 | \t32 e006e000 instruction, \ ld [%i3], %l0 | |
1828 | \t32 81c40002 instruction, \ jmp %l0, %g2, %g0 | |
1829 | \t32 [ b606e000 /token or ] | |
1830 | \t32 literal instruction, \ add %i3, /token, %i3 | |
1831 | ||
1832 | \ up 0 %g0 jmpl | |
1833 | \ nop | |
1834 | \t16 81c0.e000 instruction, \ jmp %g3, 0, %g0 | |
1835 | \t16 8000.0000 instruction, \ add %g0, %g0, %g0 | |
1836 | ; | |
1837 | ||
1838 | headerless | |
1839 | ||
1840 | \ The "word type" is a number that distinguishes one type of | |
1841 | \ word from another. This is highly implementation-dependent. | |
1842 | ||
1843 | \ For the SPARC implementation, the magic number returned by | |
1844 | \ word-type is the offset of the action code from the origin | |
1845 | ||
1846 | \itc \ Indicate whether the given location is a call instruction | |
1847 | \itc \ and, if so, return the target address | |
1848 | \itc : call-placed? ( acf -- addr true | false ) | |
1849 | \itc dup l@ dup c000.0000 and 4000.0000 = tuck if | |
1850 | \itc 2 << l->n rot + swap | |
1851 | \itc else | |
1852 | \itc drop nip | |
1853 | \itc then | |
1854 | \itc ; | |
1855 | ||
1856 | headers | |
1857 | ||
1858 | : word-type ( acf -- word-type ) | |
1859 | \dtc dup l@ 2 << l->n + | |
1860 | \itc token@ | |
1861 | ; | |
1862 | ||
1863 | headerless | |
1864 | ||
1865 | : create-cf ( -- ) docreate place-cf ; | |
1866 | [ifdef] in-dictionary-variables | |
1867 | : variable-cf ( -- ) dovariable place-cf ; | |
1868 | [then] | |
1869 | : place-does ( -- ) dodoes place-call ; | |
1870 | : place-;code ( -- ) ; | |
1871 | ||
1872 | \ Ip is assumed to point to (;code . flag is true if | |
1873 | \ the code at ip is a does> clause as opposed to a ;code clause. | |
1874 | : does-ip? ( ip -- ip' flag ) | |
1875 | dup token@ ['] (does>) = ( ip flag ) | |
1876 | if ta1+ acf-aligned la1+ la1+ true else ta1+ acf-aligned false then | |
1877 | ; | |
1878 | ||
1879 | : put-cf ( action-clause-addr where -- ) | |
1880 | \dtc tuck put-call ( where ) | |
1881 | \dtc pfa>scr-instr swap la1+ instruction! \ apf scr add | |
1882 | \itc token! | |
1883 | ; | |
1884 | ||
1885 | \ used sets the code field of the most-recently-defined word | |
1886 | \ so that it executes the code at action-clause-addr | |
1887 | : used ( action-clause-addr -- ) lastacf put-cf ; | |
1888 | ||
1889 | ||
1890 | \ Indicate whether the given address has the code-field of a does-clause. | |
1891 | \ (I.e., the call to dodoes). | |
1892 | \ Leave the address, return a flag. | |
1893 | : does-clause? ( addr -- addr flag ) | |
1894 | dup la1+ l@ dec-sp-instr = if | |
1895 | dup \ Delay-slot instruction is right... | |
1896 | \dtc word-type | |
1897 | \itc call-placed? if | |
1898 | dodoes origin+ = exit | |
1899 | \itc then | |
1900 | then | |
1901 | false | |
1902 | ; | |
1903 | ||
1904 | \ Indicate whether given ACF is of a word that was defined with | |
1905 | \ does> . If so, return the does-cfa under the true. | |
1906 | : does-cf? ( possible-acf -- does-cfa true | false ) | |
1907 | \dtc \ Possible valid child word of a does> definer? | |
1908 | \dtc dup la1+ l@ pfa>scr-instr = if \ apf scr add | |
1909 | \dtc \ Delay-slot instruction is right... | |
1910 | word-type \ Possible address of the does-clause | |
1911 | does-clause? ?dup nip exit | |
1912 | \dtc then | |
1913 | drop false | |
1914 | ; | |
1915 | ||
1916 | headers | |
1917 | \ Need this to make headerless work | |
1918 | : colon-cf ( -- ) | |
1919 | docolon place-cf | |
1920 | \dtc dec-rp-instr set-delay-slot \ rp adec | |
1921 | ; | |
1922 | headerless | |
1923 | : colon-cf? ( possible-acf -- flag ) | |
1924 | \dtc dup word-type docolon origin+ = swap | |
1925 | \dtc la1+ l@ dec-rp-instr = and \ rp adec | |
1926 | \itc token@ ['] here token@ = | |
1927 | ; | |
1928 | : user-cf ( -- ) douser place-cf ; | |
1929 | : value-cf ( -- ) dovalue place-cf ; | |
1930 | : constant-cf ( -- ) doconstant place-cf ; | |
1931 | : defer-cf ( -- ) | |
1932 | dodefer place-cf | |
1933 | \dtc param>scr-instr set-delay-slot \ apf scr ld | |
1934 | ; | |
1935 | \ Indicate whether the word whose ACF is given | |
1936 | \ was defined with defer . | |
1937 | : defer? ( acf -- flag ) | |
1938 | \dtc dup | |
1939 | word-type dodefer origin+ = | |
1940 | \dtc swap la1+ l@ param>scr-instr = and \ apf scr ld | |
1941 | ; | |
1942 | : 2constant-cf ( -- ) do2constant place-cf ; | |
1943 | ||
1944 | \t16 2 constant /branch | |
1945 | \t32 4 constant /branch | |
1946 | : branch, ( offset -- ) | |
1947 | \t32 l, | |
1948 | \t16 w, | |
1949 | ; | |
1950 | : branch! ( offset where -- ) | |
1951 | \t16 w! | |
1952 | \t32 l! | |
1953 | ; | |
1954 | : branch@ ( where -- offset ) | |
1955 | \t16 <w@ | |
1956 | \t32 <l@ | |
1957 | ; | |
1958 | \ >target depends on the way that branches are compiled | |
1959 | : >target ( ip-of-branch-instruction -- target ) ta1+ dup branch@ + ; | |
1960 | ||
1961 | \ ---- More ordinary Forth words. | |
1962 | ||
1963 | headers | |
1964 | /a constant /a | |
1965 | [ifexist] t8 | |
1966 | : a@ ( adr -- adr' ) @ origin+ ; | |
1967 | : a! ( adr1 adr2 -- ) swap origin- swap ! ; | |
1968 | [else] | |
1969 | code a@ ( adr -- adr' ) | |
1970 | \t16 tos 0 tos lduh tos tshift-t tos sll | |
1971 | \ XX 64\ \t32 tos /l scr ld | |
1972 | \ XX 64\ \t32 tos tos lget | |
1973 | \ XX 64\ \t32 tos h# 20 tos sllx | |
1974 | \ XX 64\ \t32 tos scr tos or | |
1975 | \t32 tos tos lget | |
1976 | tos base tos add | |
1977 | c; | |
1978 | code a! ( adr1 adr2 -- ) | |
1979 | sp scr pop | |
1980 | scr base scr sub | |
1981 | \t16 scr tshift-t scr srl | |
1982 | \t16 scr tos 0 sth | |
1983 | \ XX 64\ \t32 scr tos /l st | |
1984 | \ XX 64\ \t32 scr h# 20 scr srlx | |
1985 | \t32 scr tos 0 st | |
1986 | sp tos pop | |
1987 | c; | |
1988 | [then] | |
1989 | : a, ( adr -- ) here /a allot a! ; | |
1990 | ||
1991 | /token constant /token | |
1992 | code token@ ( addr -- cfa ) | |
1993 | tos 0 tos rtget | |
1994 | tos base tos add | |
1995 | c; | |
1996 | code token! ( cfa addr -- ) | |
1997 | sp scr get | |
1998 | bubble | |
1999 | scr base scr sub | |
2000 | \t16 scr tshift-t scr srl | |
2001 | \t16 scr tos 0 sth | |
2002 | \t32 scr tos lput ( ???XXX tput ) | |
2003 | sp 1 /n* tos nget | |
2004 | sp 2 /n* sp add | |
2005 | c; | |
2006 | ||
2007 | : token, ( cfa -- ) here /token allot token! ; | |
2008 | ||
2009 | code null ( -- token ) | |
2010 | tos sp push | |
2011 | base tos move | |
2012 | c; | |
2013 | : !null-link ( adr -- ) null swap link! ; | |
2014 | : !null-token ( adr -- ) null swap token! ; | |
2015 | code non-null? ( link -- false | link true ) | |
2016 | tos base cmp | |
2017 | <> if | |
2018 | false scr move \ Delay slot | |
2019 | ||
2020 | tos sp push | |
2021 | true scr move | |
2022 | then | |
2023 | scr tos move | |
2024 | c; | |
2025 | : get-token? ( adr -- false | acf true ) token@ non-null? ; | |
2026 | : another-link? ( adr -- false | link true ) link@ non-null? ; | |
2027 | ||
2028 | ||
2029 | code body> ( pfa -- cfa ) | |
2030 | \dtc tos 8 tos sub | |
2031 | \itc tos /token tos sub | |
2032 | c; | |
2033 | code >body ( cfa -- pfa ) | |
2034 | \dtc tos 8 tos add | |
2035 | \itc tos /token tos add | |
2036 | c; | |
2037 | \t16 /w constant /user# | |
2038 | \t32 /l constant /user# | |
2039 | ||
2040 | \ Move to a machine alignment boundary. | |
2041 | \ SPARC requires alignment on 32-bit boundaries, but we only require | |
2042 | \ 16-bit alignment in the 16-bit token version, using halfword memory | |
2043 | \ accesses to make this work. | |
2044 | ||
2045 | : round-down ( adr granularity -- adr' ) 1- invert and ; | |
2046 | : round-up ( adr granularity -- adr' ) 1- tuck + swap invert and ; | |
2047 | : (align) ( size granularity -- ) | |
2048 | 1- begin dup here and while 0 c, repeat drop | |
2049 | ; | |
2050 | : aligned ( adr -- adr' ) 3 + -4 and ; | |
2051 | ||
2052 | code acf-aligned ( adr -- adr' ) | |
2053 | \t16 1 tshift-t << 1 - scr move | |
2054 | \t32 3 scr move | |
2055 | tos scr tos add | |
2056 | tos scr tos andn | |
2057 | c; | |
2058 | : acf-align ( -- ) #acf-align (align) here 'lastacf token! ; | |
2059 | ||
2060 | headers | |
2061 | : /mod ( dividend divisor -- remainder quotient ) | |
2062 | \ Check if either factor is negative | |
2063 | 2dup ( n1 n2 n1 n2) | |
2064 | or 0< if ( n1 n2) | |
2065 | ||
2066 | \ Both factors not non-negative do division by: | |
2067 | \ Take absolute value and do unsigned division | |
2068 | \ Convert to truncated signed divide by: | |
2069 | \ if dividend is negative then negate the remainder | |
2070 | \ if dividend and divisor have opposite signs then negate the quotient | |
2071 | \ Then convert to floored signed divide by: | |
2072 | \ if quotient is negative and remainder is non-zero | |
2073 | \ add divisor to remainder and decrement quotient | |
2074 | ||
2075 | 2dup swap abs swap abs ( n1 n2 u1 u2) \ Absolute values | |
2076 | ||
2077 | u/mod ( n1 n2 urem uqout) \ Unsigned divide | |
2078 | >r >r ( n1 n2) ( uquot urem) | |
2079 | ||
2080 | over 0< if ( n1 n2) ( uquot urem) | |
2081 | r> negate >r \ Negative dividend; negate remainder | |
2082 | then ( n1 n2) ( uquot trem) | |
2083 | ||
2084 | swap over ( n2 n1 n2) ( uquot trem) | |
2085 | xor 0< if ( n2) ( uquot trem) | |
2086 | r> r> | |
2087 | negate ( n2 trem tquot) \ Opposite signs; negate quotient | |
2088 | -rot ( tquot n2 trem) | |
2089 | dup 0<> if | |
2090 | + ( tquot rem) \ Negative quotient & non-zero remainder | |
2091 | swap 1- ( rem quot) \ add divisor to rem. & decrement quot. | |
2092 | else | |
2093 | nip swap ( rem quot) | |
2094 | then | |
2095 | else | |
2096 | drop r> r> ( rem quot) | |
2097 | then | |
2098 | ||
2099 | else \ Both factors non-negative | |
2100 | ||
2101 | u/mod ( rem quot) | |
2102 | then | |
2103 | ; | |
2104 | ||
2105 | : / ( n1 n2 -- quot ) /mod nip ; | |
2106 | ||
2107 | : mod ( n1 n2 -- rem ) /mod drop ; | |
2108 | ||
2109 | headerless | |
2110 | \ SPARC version is dynamically relocated, so we don't need a bitmap | |
2111 | : clear-relocation-bits ( adr len -- ) 2drop ; | |
2112 | headers |