\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: vocab-util.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: @(#)vocab-util.fth 1.4 02/05/24
copyright: Copyright 2000-2002 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
\ byte-keyword is treated as a byte value, therefore one and only one
\ byte-keyword can be accepted by SETENV.
\ bit-keyword is treated as a bit value, therefore multiple bit-keywords
\ can be accepted by SETENV, as long as *different* bits are set in
\ the stream of keywords accepted by SETENV.
\ Both bit-keywords and byte-keywords may be defined in a
\ single keyword vocabulary.
action: c@ ; \ return value
action: 2drop ; \ should not be used
action: ; \ should not be used
action: /c + c@ ; \ return mask
: byte-keyword create c, h# ff c, use-actions ;
: bit-keyword create dup c, c, use-actions ;
d# 20 buffer: invalid-value
: save-value ( str len -- ) invalid-value $cat ;
: ?invalid-value ( flag -- str len )
0 invalid-value c! (.d) save-value " (invalid value)" save-value
alias value> get ( acf -- value ) ( 0 perform-action )
: mask> ( acf -- mask ) 3 perform-action ;
: next-keyword ( str len -- rem len str len' true | false )
bl left-parse-string ( rem len str len')
dup 0<> if ( rem len str len')
true exit ( rem len str len' true)
dup 0= until ( rem len str len')
2drop false ( rem len str len' true | false)
: wrong-keyword ( voc -- )
cr ." Options:" also execute words previous cr cr abort
\ Accepts both byte-keywords and bit-keywords; For byte-keywords checks
\ the validity of the keywords and returns the associated value n;
\ For bit-keywords checks the validity and applicability of every
\ bit-keyword in the stream; Multiple bit-keywords are not allowed,
\ setenv post-trigger none none
: voc-string>value ( adr,len voc -- n )
over 0= if wrong-keyword then \ Empty string can't contain a valid keyword
>r 0 0 2>r ( adr len) ( R: voc c-n c-mask)
begin next-keyword while ( rem,len adr len) ( R: voc c-n c-mask)
2r> r@ -rot 2>r search-wordlist if ( rem,len acf) ( R: voc c-n c-mask)
dup mask> ( rem,len acf mask) ( R: voc c-n c-mask)
r@ and if ( rem,len acf) ( R: voc c-n c-mask)
2r> r> wrong-keyword \ Keyword not permitted ( ??? ) ( R:)
else ( rem,len acf) ( R: voc c-n c-mask)
r> over mask> or swap ( rem,len mask acf) ( R: voc c-n)
value> r> or >r >r ( rem,len) ( R: voc c-n c-mask)
then ( rem,len) ( R: voc c-n c-mask)
else ( rem,len) ( R: voc c-n c-mask)
2r> r> wrong-keyword \ No such keyword ( ???) ( R:)
then ( rem,len) ( R: voc c-n c-mask)
repeat ( rem,len) ( R: voc c-n c-mask)
: add-keyword ( addr len -- ) keywords $cat " " keywords $cat ;
\ Works with both byte-keywords and bit-keywords. For byte-keywords
\ simply tries to match the value n to the associated byte-keyword.
\ For bit-keywords tries to match all bits set in n to the associated
\ bit-keywords and returns the list of all "matching" bit-keywords.
: voc-value>string ( n voc -- adr,len false | n true )
swap >r 0 swap ( alf voc) ( R: n)
begin another-word? while ( alf voc anf) ( R: n)
dup name> ( alf voc anf acf) ( R: n)
dup mask> h# ff = if ( byte kwrd) ( alf voc anf acf) ( R: n)
value> r@ = keywords c@ 0= and if ( alf voc anf) ( R: n)
-rot r> 3drop name>string ( adr,len)
false exit ( adr,len false)
then ( alf voc anf) ( R: n)
else ( bit keyword) ( alf voc anf addr) ( R: n)
value> r@ over and = if ( alf voc anf) ( R: n)
dup name>string add-keyword ( alf voc anf) ( R: n)
then ( alf voc anf) ( R: n)
then ( alf voc anf) ( R: n)
keywords count dup if r> drop false exit then ( adr,len )
projects / OpenSPARC-T2-SAM / blob