kmx git

\ ========== 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 
\    conditions are met: 
\ 
\  - 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
\ any nuclear facility. 
\ 
\ ========== 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.
\
hex
headers

headerless

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
;

[ifnexist] "selftest"
: "selftest" ( -- $adr,len ) " selftest" ;
[then]

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  ;

: save-signed ( n -- )
   l->n push-decimal (.) pop-base
   (save-string)
;

: .error-message ( str,len -- )
   ??cr ." Error: " type cr
;

\ 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'
\ messages.

\  XXX  The  silent?  param is ambiguous and confusing.  See BugId 4788803

: ($call-selftest) ( path$ silent? -- status )
   -rot 					( silent? path$ )
   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? )
   else						( silent? )

      \  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 )
      else					( silent? acf )
         swap 0= if                             ( acf )
            error-buffer count .testing 2drop
         then                                   ( acf )
         catch				      ( ?? throw-code | status throw=0 )
         mark-as-no-boot
      then					( status throw-code? )
      close-chain
      device-end
   then						( status throw-code? )
   r> push-device  )package
   throw					( status )
;

\ 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)	 		( ?? ) 
      else					( ?? catch? )
         "  selftest terminated abnormally"	( ?? catch? str,len )
         (save-string)				( ?? catch? )
         dup -2 = if				( ?? catch? )
            drop " , reason: " (save-string)	( ?? )
            abort-message (save-string)		( ?? )
         else					( ?? catch? ) 
            dup in-dictionary?  if		( ?? catch? )
               " , reason: " (save-string)	( ?? catch? )
               count (save-string) 		( ?? ) 
            else				( ?? catch? )
               " , throw code = " (save-string)	( ?? catch? )
               save-signed 			( ?? )  
            then				( ?? ) 
         then					( ?? )
      then					( ?? )
      abort-selftest-msg			( ?? )
   then						( ?? )
   depth r> - ?dup if				( ?? delta )
      "  selftest resulted in net stack depth change of "
      (save-string)  save-signed			( ?? )
      abort-selftest-msg			( )
   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"
\ to "okay".
\ 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)
   ?dup  if                                             ( R: ih ph)
      do-diag-hook                                      ( R: ih ph)
      "status" tested-device get-package-property  if   ( R: ih ph)
         set-fail-property      \ create status="fail"  ( R: ih ph)
      else                                              ( R: ih ph)
         decode-string drop nip nip "fail" comp  if     ( R: ih ph)
            set-fail-property   \ change status="fail"  ( R: ih ph)
         then                                           ( R: ih ph)
      then                                              ( R: ih ph)
   else                                                 ( R: ih ph)
      "status" tested-device get-package-property  if   ( R: ih ph)
         set-okay-property                              ( R: ih ph)
      else                                              ( R: ih ph)
         2drop                                          ( R: ih ph)
      then                                              ( R: ih ph)
   then                                                 ( 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
\ is catching.

: $call-selftest ( not-silent? dev$ -- status )
   rot >r                                       ( dev$ )      ( R: not-silent? )
   r@ ['] stacked-$call-selftest catch -2 = if  ( ?? )
      r> if                                     ( ?? )        ( R:  )
         3drop abort-message .error-message     ( ?? )
      else                                      ( ?? )
         -2 throw                               ( ?? )      
      then                                      ( ?? )
      true                                      ( fail )
   else                                         ( ?? status ) ( R: not-silent? )
      dup dup set-status-property  if           ( status )
         "  selftest failed, return code = "    ( status $adr,len )
	 (save-string)                          ( status )
         dup save-signed                        ( status )
         r> if                                  ( status )    ( R:  )
            error-buffer count .error-message   ( status ) 
         else                                   ( status )
            abort-selftest-msg                  ( ) 
         then                                   ( status )
      else                                      ( status )    ( R: not-silent? )
         r> drop                                ( status )    ( R:  )
      then                                      ( status )
   then                                         ( status )
;

: (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? )
      if                                        ( )
         error-buffer count .error-message      ( )
         true exit                              ( status )
      else                                      ( )
         abort-selftest-msg                     ( )
      then                                      ( )
   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 )
;

headerless
openbios/openboot/obp/pkg/selftest/test.fth

Commit

obp/pkg/selftest/test.fth
