| 1 | \ ========== Copyright Header Begin ========================================== |
| 2 | \ |
| 3 | \ Hypervisor Software File: test.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: @(#)test.fth 1.11 03/04/04 |
| 43 | purpose: test, test-dev, test-all, obdiag definitions |
| 44 | copyright: Copyright 2000-2003 Sun Microsystems, Inc. All Rights Reserved |
| 45 | copyright: Use is subject to license terms. |
| 46 | |
| 47 | \ |
| 48 | \ There are no public interfaces in this file. |
| 49 | \ |
| 50 | hex |
| 51 | headers |
| 52 | |
| 53 | headerless |
| 54 | |
| 55 | create has-no-selftest ( -- p$adr ) \ This location becomes the throw-code |
| 56 | ," device has no selftest method" \ and will also supply the message |
| 57 | |
| 58 | : .testing ( $adr,len -- $adr,len ) |
| 59 | ??cr ." Testing " 2dup type cr |
| 60 | ; |
| 61 | |
| 62 | [ifnexist] "selftest" |
| 63 | : "selftest" ( -- $adr,len ) " selftest" ; |
| 64 | [then] |
| 65 | |
| 66 | 0 value tested-device \ phandle of current device under test. |
| 67 | h# 100 buffer: error-buffer |
| 68 | |
| 69 | : abort-selftest-msg ( -- ) |
| 70 | error-buffer count set-abort-message -2 throw |
| 71 | ; |
| 72 | |
| 73 | : (save-string) ( str,len -- ) error-buffer $cat ; |
| 74 | |
| 75 | : save-signed ( n -- ) |
| 76 | l->n push-decimal (.) pop-base |
| 77 | (save-string) |
| 78 | ; |
| 79 | |
| 80 | : .error-message ( str,len -- ) |
| 81 | ??cr ." Error: " type cr |
| 82 | ; |
| 83 | |
| 84 | \ This is not exactly the same as execute-device-method because using |
| 85 | \ that routine doesn't permit the catching of a throw from selftest vs |
| 86 | \ a throw from a failed open, resulting in incorrect 'missing selftest' |
| 87 | \ messages. |
| 88 | |
| 89 | \ XXX The silent? param is ambiguous and confusing. See BugId 4788803 |
| 90 | |
| 91 | : ($call-selftest) ( path$ silent? -- status ) |
| 92 | -rot ( silent? path$ ) |
| 93 | 0 package( current-device >r ( silent? path$ ) |
| 94 | ['] open-path catch if ( silent? ??path$ ) |
| 95 | \ failure to open is not a fail. ( silent? path$ ) |
| 96 | 3drop 0 0 ( status throw? ) |
| 97 | else ( silent? ) |
| 98 | |
| 99 | \ XXX Search for selftest is unnecessary. See BugId 4788803 |
| 100 | \ |
| 101 | "selftest" my-voc (search-wordlist) 0= if ( silent? ) |
| 102 | drop true has-no-selftest ( status throw-code ) |
| 103 | else ( silent? acf ) |
| 104 | swap 0= if ( acf ) |
| 105 | error-buffer count .testing 2drop |
| 106 | then ( acf ) |
| 107 | catch ( ?? throw-code | status throw=0 ) |
| 108 | mark-as-no-boot |
| 109 | then ( status throw-code? ) |
| 110 | close-chain |
| 111 | device-end |
| 112 | then ( status throw-code? ) |
| 113 | r> push-device )package |
| 114 | throw ( status ) |
| 115 | ; |
| 116 | |
| 117 | \ We call diag-hook only when selftest returns non-zero |
| 118 | \ error code; in case of erroneous failures of the |
| 119 | \ selftest, like abort, throw or incorrect number |
| 120 | \ of arguments returned by the selftest, diag-hook is |
| 121 | \ not called. In such cases ,however test-dev always |
| 122 | \ returns non-zero status on the stack and prints an |
| 123 | \ associated message; test stores an associated message |
| 124 | \ in the abort-buffer and the message is printed by OBP; |
| 125 | \ test-all prints an associated messages for every |
| 126 | \ selftest which completes abnormally as well. |
| 127 | |
| 128 | : do-diag-hook ( status -- ) tested-device diag-hook ; |
| 129 | |
| 130 | \ a catch on stacked-$call-selftest can only return 0 or -2. |
| 131 | \ -2 for a throw from a selftest, 0 otherwise. |
| 132 | |
| 133 | : stacked-$call-selftest ( dev$ not-silent? -- status ) |
| 134 | \ push a few zeroes just in case a bad selftest consumes |
| 135 | \ the stack (we will throw anyway but this ensures that |
| 136 | \ the caller's stack remains unharmed) |
| 137 | |
| 138 | >r 2>r 0 0 0 0 0 2r> r> ( 0 0 0 0 0 $dev not-silent? ) |
| 139 | depth 2- >r \ Expected result depth |
| 140 | |
| 141 | \ XXX Test for no-selftest is unnecessary. See BugId 4788803 |
| 142 | \ |
| 143 | ['] ($call-selftest) catch ?dup if ( 0 0 0 0 0 ?? catch? ) |
| 144 | dup has-no-selftest = if ( ?? no-selftest-throw-code ) |
| 145 | count (save-string) ( ?? ) |
| 146 | else ( ?? catch? ) |
| 147 | " selftest terminated abnormally" ( ?? catch? str,len ) |
| 148 | (save-string) ( ?? catch? ) |
| 149 | dup -2 = if ( ?? catch? ) |
| 150 | drop " , reason: " (save-string) ( ?? ) |
| 151 | abort-message (save-string) ( ?? ) |
| 152 | else ( ?? catch? ) |
| 153 | dup in-dictionary? if ( ?? catch? ) |
| 154 | " , reason: " (save-string) ( ?? catch? ) |
| 155 | count (save-string) ( ?? ) |
| 156 | else ( ?? catch? ) |
| 157 | " , throw code = " (save-string) ( ?? catch? ) |
| 158 | save-signed ( ?? ) |
| 159 | then ( ?? ) |
| 160 | then ( ?? ) |
| 161 | then ( ?? ) |
| 162 | abort-selftest-msg ( ?? ) |
| 163 | then ( ?? ) |
| 164 | depth r> - ?dup if ( ?? delta ) |
| 165 | " selftest resulted in net stack depth change of " |
| 166 | (save-string) save-signed ( ?? ) |
| 167 | abort-selftest-msg ( ) |
| 168 | then ( 0 0 0 0 0 status ) |
| 169 | nip nip nip nip nip ( status ) |
| 170 | ; |
| 171 | |
| 172 | \ sets or modifies "status" property for the tested device |
| 173 | \ based on results of testing: if selftest passes, and there |
| 174 | \ is no "status" property, declare "status" property and |
| 175 | \ set it to "okay"; if there is already "status" property, |
| 176 | \ do nothing; Note that if the "status" property is set |
| 177 | \ to "fail", subsequent passes will not change "status" |
| 178 | \ to "okay". |
| 179 | \ if selftest fails and there is no "status" property, create |
| 180 | \ "status"="fail"; if "status" property exists but doesn't |
| 181 | \ start with "fail" change "status"="fail". |
| 182 | |
| 183 | : "status" ( -- $adr,len ) " status" ; |
| 184 | : "fail" ( -- $adr,len ) " fail" ; |
| 185 | |
| 186 | : set-fail-property ( -- ) "fail" "status" string-property ; |
| 187 | : set-okay-property ( -- ) " okay" "status" string-property ; |
| 188 | |
| 189 | : set-status-property ( status -- ) |
| 190 | my-self current-device 2>r ( R: ih ph) |
| 191 | 0 to my-self tested-device to current-device ( R: ih ph) |
| 192 | ?dup if ( R: ih ph) |
| 193 | do-diag-hook ( R: ih ph) |
| 194 | "status" tested-device get-package-property if ( R: ih ph) |
| 195 | set-fail-property \ create status="fail" ( R: ih ph) |
| 196 | else ( R: ih ph) |
| 197 | decode-string drop nip nip "fail" comp if ( R: ih ph) |
| 198 | set-fail-property \ change status="fail" ( R: ih ph) |
| 199 | then ( R: ih ph) |
| 200 | then ( R: ih ph) |
| 201 | else ( R: ih ph) |
| 202 | "status" tested-device get-package-property if ( R: ih ph) |
| 203 | set-okay-property ( R: ih ph) |
| 204 | else ( R: ih ph) |
| 205 | 2drop ( R: ih ph) |
| 206 | then ( R: ih ph) |
| 207 | then ( R: ih ph) |
| 208 | 2r> push-device to my-self ( R: ) |
| 209 | ; |
| 210 | |
| 211 | \ If not-silent? is true then we print the error-message here, |
| 212 | \ if not then we propogate the catch code assuming our caller |
| 213 | \ is catching. |
| 214 | |
| 215 | : $call-selftest ( not-silent? dev$ -- status ) |
| 216 | rot >r ( dev$ ) ( R: not-silent? ) |
| 217 | r@ ['] stacked-$call-selftest catch -2 = if ( ?? ) |
| 218 | r> if ( ?? ) ( R: ) |
| 219 | 3drop abort-message .error-message ( ?? ) |
| 220 | else ( ?? ) |
| 221 | -2 throw ( ?? ) |
| 222 | then ( ?? ) |
| 223 | true ( fail ) |
| 224 | else ( ?? status ) ( R: not-silent? ) |
| 225 | dup dup set-status-property if ( status ) |
| 226 | " selftest failed, return code = " ( status $adr,len ) |
| 227 | (save-string) ( status ) |
| 228 | dup save-signed ( status ) |
| 229 | r> if ( status ) ( R: ) |
| 230 | error-buffer count .error-message ( status ) |
| 231 | else ( status ) |
| 232 | abort-selftest-msg ( ) |
| 233 | then ( status ) |
| 234 | else ( status ) ( R: not-silent? ) |
| 235 | r> drop ( status ) ( R: ) |
| 236 | then ( status ) |
| 237 | then ( status ) |
| 238 | ; |
| 239 | |
| 240 | : (test-dev) ( not-silent? name,len -- status ) |
| 241 | 0 error-buffer c! ( not-silent? dev$ ) |
| 242 | 2dup locate-device if ( not-silent? dev$ ) |
| 243 | " Device " (save-string) (save-string) ( not-silent? ) |
| 244 | " not found" (save-string) ( not-silent? ) |
| 245 | if ( ) |
| 246 | error-buffer count .error-message ( ) |
| 247 | true exit ( status ) |
| 248 | else ( ) |
| 249 | abort-selftest-msg ( ) |
| 250 | then ( ) |
| 251 | then ( not-silent? dev$ phandle ) |
| 252 | to tested-device ( not-silent? dev$ ) |
| 253 | 2dup (save-string) ( not-silent? dev$ ) |
| 254 | tested-device load-selftest-dropin drop ( not-silent? dev$ ) |
| 255 | $call-selftest ( status ) |
| 256 | ; |
| 257 | |
| 258 | headerless |