Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: objects.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 | \ objects.fth 2.16 01/05/18 | |
43 | \ Copyright 1985-1990 Bradley Forthware | |
44 | \ Copyright 1990-2001 Sun Microsystems, Inc. All Rights Reserved | |
45 | ||
46 | \ Action definition for multiple-code-field words. | |
47 | \ Data structures: | |
48 | \ nth-action-does-clause acfs unnest | |
49 | \ n-1th-action-does-clause acfs unnest | |
50 | \ ... | |
51 | \ 1th-action-does-clause acfs unnest | |
52 | \ nth-adr | |
53 | \ n-1th-adr | |
54 | \ ... | |
55 | \ 1th-adr | |
56 | \ n | |
57 | \ 0th-action-does-clause acfs unnest | |
58 | \ object-header build-acfs | |
59 | \ (') 0th-adr uses | |
60 | ||
61 | needs doaction objsup.fth \ Machine-dependent support routines | |
62 | ||
63 | decimal | |
64 | headerless | |
65 | ||
66 | 0 value action# | |
67 | 0 value #actions | |
68 | 0 value action-adr | |
69 | headers | |
70 | : actions ( #actions -- ) | |
71 | is #actions | |
72 | #actions 1- /token * na1+ allot ( #actions ) \ Make the jump table | |
73 | \ The default action is a code field, which must be aligned | |
74 | align acf-align here is action-adr | |
75 | 0 is action# | |
76 | #actions action-adr /n - ! | |
77 | ; | |
78 | headerless | |
79 | \ Sets the address entry in the action table | |
80 | : set-action ( -- ) | |
81 | action# #actions > abort" Too many actions defined" | |
82 | lastacf action-adr action# /token * - /n - token! | |
83 | ; | |
84 | headers | |
85 | : action: ( -- ) | |
86 | action# if \ Not the default action | |
87 | doaction set-action | |
88 | else \ The default action, like does> | |
89 | place-does | |
90 | then | |
91 | ||
92 | action# 1+ is action# | |
93 | !csp | |
94 | ] | |
95 | ; | |
96 | : action-code ( -- ) | |
97 | action# if \ Not the default action | |
98 | acf-align start-code set-action | |
99 | else \ The default action, like ;code | |
100 | start-;code | |
101 | then | |
102 | ||
103 | \ For the default action, the apf of the child word is found in | |
104 | \ the same way as with ;code words. | |
105 | ||
106 | action# 1+ is action# | |
107 | do-entercode | |
108 | ; | |
109 | : use-actions ( -- ) | |
110 | state @ if | |
111 | compile (') action-adr token, compile used | |
112 | else | |
113 | action-adr used | |
114 | then | |
115 | ; immediate | |
116 | ||
117 | headerless | |
118 | : .object-error | |
119 | ( object-acf action-adr false | acf action# #actions true -- ... ) | |
120 | ( ... -- object-acf action-adr ) | |
121 | if | |
122 | ." Unimplemented action # " swap .d ." on object " swap .name | |
123 | ." , whose maximum action # is " 1- .d cr | |
124 | abort | |
125 | then | |
126 | ; | |
127 | ||
128 | headers | |
129 | ||
130 | \ Executes the numbered action of the indicated object | |
131 | \ It might be worthwhile to implement perform-action entirely in code. | |
132 | : perform-action ( object-acf action# -- ) | |
133 | dup if | |
134 | >action-adr .object-error ( object-apf action-adr ) | |
135 | execute | |
136 | else | |
137 | drop execute | |
138 | then | |
139 | ; | |
140 | ||
141 | ||
142 | 1 action-name to | |
143 | 2 action-name addr | |
144 | ||
145 | \ Add these words to the decompiler case tables so that the | |
146 | \ debugger will display their arguments and so that the decompiler | |
147 | \ will not show the action name and its argument on separate lines | |
148 | \ if it happens to be near the end of a line. | |
149 | ||
150 | : .action ( ip -- ip' ) dup token@ .name ta1+ dup token@ .name ta1+ ; | |
151 | also hidden also | |
152 | ' to ' .action ' skip-(') install-decomp | |
153 | ' addr ' .action ' skip-(') install-decomp | |
154 | previous previous | |
155 | ||
156 | : ?has-action ( object-acf action-acf -- object-acf action-acf ) | |
157 | 2dup >body >action# >action-adr .object-error 2drop | |
158 | ; | |
159 | : action-compiler: \ name ( -- ) | |
160 | parse-word 2dup $find $?missing drop \ adr len xt | |
161 | warning @ >r warning off | |
162 | -rot $create token, immediate | |
163 | r> warning ! | |
164 | does> ( apf ) | |
165 | ' swap token@ ( object-acf action-acf ) | |
166 | ?has-action ( object-acf action-acf ) | |
167 | +level ( apf ) \ Enter temporary compile state if necessary | |
168 | compile, \ Compile run-time action-name word | |
169 | compile, \ Compile object acf | |
170 | -level \ Exit temporary compile state, perhaps run word | |
171 | ; | |
172 | \ action-compiler: to | |
173 | action-compiler: addr | |
174 | ||
175 | ||
176 | \ Makes "is" and "to" synonymous. "is" first checks to see if the | |
177 | \ object is of one of the kernel object types (which don't have multiple | |
178 | \ code fields), and if so, compiles or executes the "(is) <token>" form. | |
179 | \ If the object is not of one of the kernel object types, "is" calls | |
180 | \ "to-hook" to handle the object as a multiple-code field type object. | |
181 | ||
182 | : (to) ( [data] acf -- ) +level compile to compile, -level ; | |
183 | ' (to) is to-hook | |
184 | warning @ warning off | |
185 | alias to is | |
186 | warning ! | |
187 | ||
188 | \ 3 actions | |
189 | \ action: @ ; | |
190 | \ action: ! ; ( is ) | |
191 | \ action: ; ( addr ) | |
192 | \ : value \ name ( initial-value -- ) | |
193 | \ create , | |
194 | \ use-actions | |
195 | \ ; | |
196 | ||
197 | 3 actions | |
198 | action: >user 2@ ; | |
199 | action: >user 2! ; | |
200 | action: >user ; | |
201 | : 2value ( n1 n2 "name" -- ) create 2 /n* user#, 2! use-actions ; |