Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: is.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: @(#)is.fth 2.10 03/12/08 13:22:08 | |
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 | \ Prefix word for setting the value of variables, constants, user variables, | |
49 | \ values, and deferred words. State-smart so it is used the same way whether | |
50 | [ifndef] in-dictionary-variables | |
51 | \ interpreting or compiling. You could now use IS in place of ! where speed | |
52 | \ matters, because the newer faster IS is actually 20% faster than ! (but | |
53 | \ it's still not recommended practice. Better to use VALUE.) | |
54 | [else] | |
55 | \ interpreting or compiling. Don't use IS in place of ! where speed matters, | |
56 | \ because IS is much slower than ! . | |
57 | [then] | |
58 | \ | |
59 | \ Examples: | |
60 | \ | |
61 | \ 3 constant foo | |
62 | \ 4 is foo | |
63 | \ | |
64 | \ defer money | |
65 | \ ' dollars is money | |
66 | \ : european ['] euros is money ; | |
67 | ||
68 | \ IS is a "generic store". | |
69 | \ IS figures out where the data for a word is stored, and replaces that data. | |
70 | \ The previous implementation was not particularly fast; this is much faster. | |
71 | ||
72 | \ This is loaded before "order.fth" | |
73 | \ only forth also hidden also definitions | |
74 | ||
75 | \ In-dictionary variables are a leftover from the earliest FORTH | |
76 | \ implementations. They have no place in a ROMable target-system | |
77 | \ and we are deprecating support for them; but Just In Case you | |
78 | \ ever want to restore support for them, define the command-line | |
79 | \ symbol: in-dictionary-variables | |
80 | [ifdef] in-dictionary-variables | |
81 | variable isvar | |
82 | [then] | |
83 | ||
84 | \ \ Replace this next one with something we actually use | |
85 | \ 0 value isval | |
86 | ||
87 | headerless | |
88 | ||
89 | [ifdef] run-time | |
90 | : is-error ( data acf -- ) true ( -32 ) abort" inappropriate use of `is'" ; | |
91 | [else] | |
92 | : is-error ( data acf -- ) ." Can't use is with " .name cr ( -32 ) abort ; | |
93 | [then] | |
94 | ||
95 | headers | |
96 | ||
97 | defer to-hook | |
98 | ' is-error is to-hook | |
99 | ||
100 | headerless | |
101 | ||
102 | : >bu ( acf -- data-adr ) >body >user ; | |
103 | ||
104 | create word-types | |
105 | ] limit \ value | |
106 | #user \ user variable | |
107 | key \ defer | |
108 | [ifdef] in-dictionary-variables | |
109 | isvar \ in-dictionary variable | |
110 | [then] | |
111 | bl \ constant | |
112 | [ origin token,-t \ END \ origin should be null | |
113 | ||
114 | create data-locs | |
115 | ] >bu \ value | |
116 | >bu \ user variable | |
117 | >bu \ defer | |
118 | [ifdef] in-dictionary-variables | |
119 | >body \ in-dictionary variable | |
120 | [then] | |
121 | >body \ constant | |
122 | [ | |
123 | ||
124 | \ One of these words will be called when interpreting IS , | |
125 | \ based on the word-type of the target-word. | |
126 | \ When compiling IS , the group below will be used. | |
127 | : is-user ( n acf -- ) >bu ! ; | |
128 | : is-defer ( n acf -- ) >bu token! ; | |
129 | : is-const ( n acf -- ) >body ! ; | |
130 | ||
131 | create !data-ops | |
132 | ] is-user \ value | |
133 | is-user \ user variable | |
134 | is-defer \ defer | |
135 | [ifdef] in-dictionary-variables | |
136 | is-const \ in-dictionary variable | |
137 | [then] | |
138 | is-const \ constant | |
139 | [ | |
140 | ||
141 | \ These are the words that are compiled-in when compiling IS | |
142 | [ifnexist] (is-user) | |
143 | : (is-user) ( n -- ) ip> dup ta1+ >ip token@ is-user ; | |
144 | [then] | |
145 | [ifnexist] (is-defer) | |
146 | : (is-defer) ( n -- ) ip> dup ta1+ >ip token@ is-defer ; | |
147 | [then] | |
148 | ||
149 | ||
150 | \ We may obsolete this eventually. Constants should stay constant... | |
151 | : (is-const) ( n -- ) ip> dup ta1+ >ip token@ is-const ; | |
152 | ||
153 | create (!data-ops) | |
154 | ] (is-user) \ value | |
155 | (is-user) \ user variable | |
156 | (is-defer) \ defer | |
157 | [ifdef] in-dictionary-variables | |
158 | (is-const) \ in-dictionary variable | |
159 | [then] | |
160 | (is-const) \ constant | |
161 | [ | |
162 | ||
163 | : associate ( acf -- true | index false ) | |
164 | word-type ( n ) | |
165 | word-types begin ( n adr ) | |
166 | 2dup get-token? ( n adr n false | acf true ) | |
167 | while ( n adr n acf ) | |
168 | word-type = if ( n adr ) | |
169 | word-types - ( n index ) | |
170 | \t32 2/ 2/ ( n index ) \ equiv. of '/token /' | |
171 | \t16 2/ ( n index ) | |
172 | nip false exit ( index false ) | |
173 | then ( n adr ) | |
174 | ta1+ ( n adr' ) | |
175 | repeat ( n adr n ) | |
176 | 3drop true ( true ) | |
177 | ; | |
178 | ||
179 | : +token@ ( index table -- acf ) swap ta+ token@ ; | |
180 | : +execute ( index table -- ) +token@ execute ; | |
181 | ||
182 | : kerntype? ( acf -- flag ) | |
183 | associate if false else drop true then ( flag ) | |
184 | ; | |
185 | ||
186 | headers | |
187 | : behavior ( defer-acf -- acf2 ) >bu token@ ; | |
188 | ||
189 | : (is ( data acf -- ) | |
190 | dup associate if is-error then ( data acf index ) | |
191 | !data-ops +execute ( ) | |
192 | ; | |
193 | ||
194 | : >data ( acf -- data-adr ) | |
195 | dup associate if ( acf ) | |
196 | >body ( data-adr ) | |
197 | else ( acf index ) | |
198 | data-locs +execute ( data-adr ) | |
199 | then ( data-adr ) | |
200 | ; | |
201 | ||
202 | [ifndef] run-time | |
203 | : compile-is ( acf -- ) | |
204 | dup associate drop \ Already filtered through kerntype ( acf index ) | |
205 | (!data-ops) +token@ ( acf is-acf ) | |
206 | token, token, | |
207 | ; | |
208 | : do-is ( data acf -- ) | |
209 | dup kerntype? if ( [data] acf ) | |
210 | state @ if compile-is else (is then | |
211 | else ( [data] acf ) | |
212 | to-hook | |
213 | then | |
214 | ; | |
215 | ||
216 | \ is is the word that is actually used by applications | |
217 | : is \ name ( data -- ) | |
218 | ' do-is | |
219 | ; immediate | |
220 | ||
221 | \ only forth also definitions | |
222 | ||
223 | [then] |