Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: definers.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: @(#)definers.fth 3.11 03/12/08 13:21:59 | |
43 | purpose: | |
44 | copyright: Copyright 1994-2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Copyright 1985-1994 Bradley Forthware | |
46 | copyright: Use is subject to license terms. | |
47 | ||
48 | \ Extensible Layer Defining Words | |
49 | ||
50 | headers | |
51 | ||
52 | defer $header | |
53 | ||
54 | defer header \ Create a new word | |
55 | ||
56 | : (header) \ name ( -- ) | |
57 | safe-parse-word $header | |
58 | ; | |
59 | ||
60 | ' (header) is header | |
61 | ||
62 | : $create ( adr len -- ) $header create-cf ; | |
63 | ||
64 | : create \ name ( -- ) | |
65 | header create-cf | |
66 | ; | |
67 | ||
68 | nuser csp \ for stack position error checking | |
69 | : !csp ( -- ) sp@ csp ! ; | |
70 | : ?csp ( -- ) sp@ csp @ <> ( -22 ) abort" Stack Changed " ; | |
71 | ||
72 | : (;code) ( -- ) ip> aligned acf-aligned used ; | |
73 | : (does>) ( -- ) ip> acf-aligned used ; | |
74 | ||
75 | defer do-entercode | |
76 | ' noop is do-entercode | |
77 | ||
78 | : code \ name ( -- ) | |
79 | header code-cf !csp do-entercode | |
80 | ; | |
81 | ||
82 | defer do-exitcode | |
83 | ' noop is do-exitcode | |
84 | ||
85 | : end-code ( -- ) | |
86 | do-exitcode ?csp | |
87 | ; | |
88 | : c; ( -- ) next end-code ; | |
89 | ||
90 | : ;code ( -- ) | |
91 | ?csp compile (;code) align acf-align place-;code | |
92 | [compile] [ reveal do-entercode | |
93 | ; immediate | |
94 | ||
95 | : does> ( -- ) | |
96 | state @ if | |
97 | compile (does>) | |
98 | else | |
99 | here aligned acf-aligned used !csp not-hidden ] | |
100 | then | |
101 | align acf-align place-does | |
102 | ; immediate | |
103 | ||
104 | : : ( -- ) ?exec !csp header hide ] colon-cf ; | |
105 | : :noname ( -- ) ?exec !csp not-hidden ] colon-cf ; | |
106 | : ; ( -- ) | |
107 | ?comp ?csp compile unnest reveal [compile] [ | |
108 | ; immediate | |
109 | ||
110 | : recursive ( -- ) reveal ; immediate | |
111 | ||
112 | : constant \ name ( n -- ) | |
113 | header constant-cf , | |
114 | ; | |
115 | : user \ name ( user# -- ) | |
116 | header user-cf | |
117 | \t32 l, | |
118 | \t16 w, | |
119 | ; | |
120 | : value \ name ( value -- ) | |
121 | header value-cf /n user#, ! | |
122 | ; | |
123 | \ In-dictionary variables are a leftover from the earliest FORTH | |
124 | \ implementations. They have no place in a ROMable target-system | |
125 | \ and we are deprecating support for them; but Just In Case you | |
126 | \ ever want to restore support for them, define the command-line | |
127 | \ symbol: in-dictionary-variables | |
128 | [ifdef] in-dictionary-variables | |
129 | : variable \ name ( -- ) | |
130 | header variable-cf 0 , | |
131 | ; | |
132 | : wvariable \ name ( -- ) | |
133 | create variable-cf 0 w, | |
134 | ; | |
135 | : lvariable \ name ( -- ) | |
136 | create variable-cf 0 l, | |
137 | ; | |
138 | [else] | |
139 | : variable \ name ( -- ) | |
140 | nuser | |
141 | ; | |
142 | : wvariable \ name ( -- ) | |
143 | /w ualloc user | |
144 | ; | |
145 | : lvariable \ name ( -- ) | |
146 | /l ualloc user | |
147 | ; | |
148 | [then] | |
149 | ||
150 | \ defer (is is | |
151 | \ Also known as execution vectors. | |
152 | \ Usage: defer bar | |
153 | \ : foo ." Hello" ; ' foo is bar | |
154 | \ Alternatively: ' foo ' bar (is | |
155 | ||
156 | \ Since the execution of an execution vector doesn't leave around | |
157 | \ information about which deferred word was used, we have to try | |
158 | \ to find it by looking on the return stack | |
159 | \ if the vector was EXECUTE'd, we don't know what it was. This | |
160 | \ will be the case if the deferred word was interpreted from the | |
161 | \ input stream | |
162 | ||
163 | : crash ( -- ) \ unitialized execution vector routine | |
164 | \ The following line may not always work right for token-threaded code | |
165 | \ with variable-length tokens | |
166 | ip@ /token - token@ \ use the return stack to see who called us | |
167 | dup ['] execute = if 'word count type space else .name then | |
168 | ." <--deferred word not initialized" abort | |
169 | ; | |
170 | ||
171 | \ Allocates a user area location to hold the vector | |
172 | : defer \ name ( -- ) | |
173 | header defer-cf | |
174 | ['] crash /token user#, token! \ Allocate user location | |
175 | ; | |
176 | ||
177 | : 2constant \ name ( d# -- ) | |
178 | header 2constant-cf swap , , | |
179 | ; | |
180 | ||
181 | \ buffer: \ name ( size -- ) | |
182 | \ Defines a word that returns the address of a buffer of the | |
183 | \ requested size. The buffer is allocated at initialization | |
184 | \ time from free memory, not from the dictionary. | |
185 | \ | |
186 | \ The parameter field contains three items as follows: | |
187 | \ -- Location Name ( Size ) | |
188 | \ pfa: user# ( /user# , which is either /l ) | |
189 | \ ( or, in the \t16 model, /w ) | |
190 | \ pfa+/user#: buffer-size ( /n , which is way too large!) | |
191 | \ pfa+/user#+/n: buffer-link ( /a , which is either /l ) | |
192 | \ ( or, in the \t16 model, /w ) | |
193 | \ | |
194 | \ When the buffer is defined, a single cell is allocated in user space, | |
195 | \ which holds the address of the allocated block of memory. | |
196 | ||
197 | headerless | |
198 | auser buffer-link | |
199 | 0 is buffer-link | |
200 | ||
201 | : make-buffer ( size -- ) | |
202 | ||
203 | 0 /n user#, ! ( size ) \ Cell in user space; initlz to zero. | |
204 | , ( ) | |
205 | buffer-link link@ link, | |
206 | lastacf buffer-link link! | |
207 | ; | |
208 | \ Return the buffer-size field of the buffer whose PFA is on the stack | |
209 | : /buffer ( buff-pfa -- size ) | |
210 | /user# + @ | |
211 | ; | |
212 | : init-buffer ( pfa usr-adr -- buff-adr ) | |
213 | >r ( apf ) ( R: usr-adr ) | |
214 | /buffer ( size ) ( R: usr-adr ) | |
215 | dup alloc-mem ( size buff-adr ) ( R: usr-adr ) | |
216 | tuck tuck r> ! ( buff-adr buff-adr size ) | |
217 | erase ( buff-adr ) | |
218 | ; | |
219 | : do-buffer ( pfa -- buff-adr ) | |
220 | dup >user dup @ ?dup if ( apf usr-adr [ buff-adr ] ) | |
221 | nip nip ( buff-adr ) | |
222 | else ( apf usr-adr ) | |
223 | init-buffer ( buff-adr ) | |
224 | then | |
225 | ; | |
226 | : (buffer:) ( size -- ) | |
227 | create-cf make-buffer does> do-buffer | |
228 | ; | |
229 | ||
230 | headers | |
231 | : buffer: \ name ( size -- ) | |
232 | header (buffer:) | |
233 | ; | |
234 | ||
235 | headerless | |
236 | : >buffer-link ( acf -- link-adr ) >body /user# + na1+ ; | |
237 | ||
238 | : clear-buffer:s ( -- ) | |
239 | buffer-link ( next-buffer-word ) | |
240 | begin another-link? while ( acf ) | |
241 | dup >body >user off ( acf ) | |
242 | >buffer-link ( prev-buffer:-acf ) | |
243 | repeat ( ) | |
244 | ; | |
245 | ||
246 | chain: init ( -- ) clear-buffer:s ; | |
247 | headers |