\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: test.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)test.fth 1.11 03/04/04
purpose: test, test-dev, test-all, obdiag definitions
copyright: Copyright 2000-2003 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
\ There are no public interfaces in this file.
create has-no-selftest ( -- p$adr ) \ This location becomes the throw-code
," device has no selftest method" \ and will also supply the message
: .testing ( $adr,len -- $adr,len )
??cr ." Testing " 2dup type cr
: "selftest" ( -- $adr,len ) " selftest" ;
0 value tested-device \ phandle of current device under test.
h# 100 buffer: error-buffer
: abort-selftest-msg ( -- )
error-buffer count set-abort-message -2 throw
: (save-string) ( str,len -- ) error-buffer $cat ;
l->n push-decimal (.) pop-base
: .error-message ( str,len -- )
\ This is not exactly the same as execute-device-method because using
\ that routine doesn't permit the catching of a throw from selftest vs
\ a throw from a failed open, resulting in incorrect 'missing selftest'
\ XXX The silent? param is ambiguous and confusing. See BugId 4788803
: ($call-selftest) ( path$ silent? -- status )
0 package( current-device >r ( silent? path$ )
['] open-path catch if ( silent? ??path$ )
\ failure to open is not a fail. ( silent? path$ )
3drop 0 0 ( status throw? )
\ XXX Search for selftest is unnecessary. See BugId 4788803
"selftest" my-voc (search-wordlist) 0= if ( silent? )
drop true has-no-selftest ( status throw-code )
error-buffer count .testing 2drop
catch ( ?? throw-code | status throw=0 )
then ( status throw-code? )
then ( status throw-code? )
\ We call diag-hook only when selftest returns non-zero
\ error code; in case of erroneous failures of the
\ selftest, like abort, throw or incorrect number
\ of arguments returned by the selftest, diag-hook is
\ not called. In such cases ,however test-dev always
\ returns non-zero status on the stack and prints an
\ associated message; test stores an associated message
\ in the abort-buffer and the message is printed by OBP;
\ test-all prints an associated messages for every
\ selftest which completes abnormally as well.
: do-diag-hook ( status -- ) tested-device diag-hook ;
\ a catch on stacked-$call-selftest can only return 0 or -2.
\ -2 for a throw from a selftest, 0 otherwise.
: stacked-$call-selftest ( dev$ not-silent? -- status )
\ push a few zeroes just in case a bad selftest consumes
\ the stack (we will throw anyway but this ensures that
\ the caller's stack remains unharmed)
>r 2>r 0 0 0 0 0 2r> r> ( 0 0 0 0 0 $dev not-silent? )
depth 2- >r \ Expected result depth
\ XXX Test for no-selftest is unnecessary. See BugId 4788803
['] ($call-selftest) catch ?dup if ( 0 0 0 0 0 ?? catch? )
dup has-no-selftest = if ( ?? no-selftest-throw-code )
count (save-string) ( ?? )
" selftest terminated abnormally" ( ?? catch? str,len )
(save-string) ( ?? catch? )
dup -2 = if ( ?? catch? )
drop " , reason: " (save-string) ( ?? )
abort-message (save-string) ( ?? )
dup in-dictionary? if ( ?? catch? )
" , reason: " (save-string) ( ?? catch? )
count (save-string) ( ?? )
" , throw code = " (save-string) ( ?? catch? )
abort-selftest-msg ( ?? )
depth r> - ?dup if ( ?? delta )
" selftest resulted in net stack depth change of "
(save-string) save-signed ( ?? )
then ( 0 0 0 0 0 status )
nip nip nip nip nip ( status )
\ sets or modifies "status" property for the tested device
\ based on results of testing: if selftest passes, and there
\ is no "status" property, declare "status" property and
\ set it to "okay"; if there is already "status" property,
\ do nothing; Note that if the "status" property is set
\ to "fail", subsequent passes will not change "status"
\ if selftest fails and there is no "status" property, create
\ "status"="fail"; if "status" property exists but doesn't
\ start with "fail" change "status"="fail".
: "status" ( -- $adr,len ) " status" ;
: "fail" ( -- $adr,len ) " fail" ;
: set-fail-property ( -- ) "fail" "status" string-property ;
: set-okay-property ( -- ) " okay" "status" string-property ;
: set-status-property ( status -- )
my-self current-device 2>r ( R: ih ph)
0 to my-self tested-device to current-device ( R: ih ph)
"status" tested-device get-package-property if ( R: ih ph)
set-fail-property \ create status="fail" ( R: ih ph)
decode-string drop nip nip "fail" comp if ( R: ih ph)
set-fail-property \ change status="fail" ( R: ih ph)
"status" tested-device get-package-property if ( R: ih ph)
set-okay-property ( R: ih ph)
2r> push-device to my-self ( R: )
\ If not-silent? is true then we print the error-message here,
\ if not then we propogate the catch code assuming our caller
: $call-selftest ( not-silent? dev$ -- status )
rot >r ( dev$ ) ( R: not-silent? )
r@ ['] stacked-$call-selftest catch -2 = if ( ?? )
3drop abort-message .error-message ( ?? )
else ( ?? status ) ( R: not-silent? )
dup dup set-status-property if ( status )
" selftest failed, return code = " ( status $adr,len )
dup save-signed ( status )
error-buffer count .error-message ( status )
else ( status ) ( R: not-silent? )
r> drop ( status ) ( R: )
: (test-dev) ( not-silent? name,len -- status )
0 error-buffer c! ( not-silent? dev$ )
2dup locate-device if ( not-silent? dev$ )
" Device " (save-string) (save-string) ( not-silent? )
" not found" (save-string) ( not-silent? )
error-buffer count .error-message ( )
then ( not-silent? dev$ phandle )
to tested-device ( not-silent? dev$ )
2dup (save-string) ( not-silent? dev$ )
tested-device load-selftest-dropin drop ( not-silent? dev$ )
$call-selftest ( status )
projects / OpenSPARC-T2-SAM / blob