| 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 ; |