\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: tagvoc.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: @(#)tagvoc.fth 3.9 04/03/19 17:00:34
copyright: Copyright 1994-2002 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
\ Copyright 1985-1994 Bradley Forthware
\ Implementation of vocabularies. Vocabularies are lists of word names.
\ The following operations may be performed on vocabularies:
\ find-word - Search for a given word
\ "header - Create a new word in the "current" vocabulary
\ trim - Remove all words in a vocabulary created after an address
\ another? - Enumerate all the the words
\ Each word name in a vocabulary has a byte with the following attributes:
\ name flag bit (7) - Identifies the byte as, indeed, belonging to a name
\ immediate flag bit (6) - Controls compilation of that word
\ alias flag bit (5) - Identifies the word as an alias
\ name-length bits (0-4) - Length of the name
\ Find a potential name field address
: find-name ( acf -- anf ) >link l>name ;
\ The test for a valid header searches backward to the position that
\ is expected to contain a name length byte. That byte is first checked
\ for the presence of the 'name-tag' (80) bit. Then the length is checked
\ to confirm that it is non-zero. Finally, the characters in the name
\ are checked to make sure that they are all non-blank and printable.
: >name? ( acf -- anf good-name? )
\ Check for the name-flag bit
dup c@ h# 80 and dup if drop ( anf )
\ Check for zero-length name.
true over name>string ( anf true adr len )
?dup 0= if 2drop false exit then
\ Check for bogus (blank or non-printable) characters.
i c@ bl 1+ h# 7e between 0=
\ Address conversion operators
: n>link ( anf -- alf ) 1+ ;
: l>name ( alf -- anf ) 1- ;
: n>flags ( anf -- aff ) ;
: name> ( anf -- acf ) n>link link> ;
: link> ( alf -- acf ) /link + ;
: >link ( acf -- alf ) /link - ;
: >flags ( acf -- aff ) >name n>flags ;
: name>string ( anf -- adr len ) dup c@ h# 1f and tuck - swap ;
: l>beginning ( alf -- adr ) l>name name>string drop ;
: >threads ( acf -- ath ) >body >user ;
: $make-header ( adr len voc-acf -- )
dup 1+ /link + ( voc-acf adr,len hdr-len )
here + ( voc-acf adr,len addr' )
dup acf-aligned swap - allot ( voc-acf adr,len )
tuck here over 1+ note-string allot ( voc-acf len adr,len anf )
place-cstr ( voc-acf len anf )
here 1- last ! ( voc-acf )
/link allot here ( threads-adr acf )
swap 2dup link@ ( acf threads-adr acf succ-acf )
swap >link link! link! ( )
last @ c@ h# 80 or last @ c!
: >first ( voc-acf -- first-alf ) >threads ;
: $find-word ( adr len voc-acf -- adr len [ false | xt,+-1 ] )
>first $find-next find-fixup
\ Watchout the lose is patched with the acf of keys-forth later!!
: $find-word ( adr len voc-acf -- adr len [ false | xt,+-1 ] )
>r 2dup r@ >first $find-next find-fixup ( adr len [ adr,len,0 | xt,+-1 ] )
dup if ( adr len xt,+-1 )
r> ['] lose <> ( xt,+-1 adr len xref? )
if xref-find-hook then ( xt,+-1 adr len )
else ( adr len adr,len,0 )
r> drop >r 2swap 2drop r> ( adr,len,0 )
then ( adr len [ false | xt,+-1 ] )
: >ptr ( alf voc-acf -- ptr )
over if drop else nip >threads then
: next-word ( alf voc-acf -- false | alf' true )
>ptr another-link? if >link true else false then
: insert-word ( new-alf old-alf voc-ptr -- )
swap link> swap ( new-acf alf )
2dup link@ ( new-acf alf new-acf next-acf )
\ WARNING, the '>threads' in remove-word is patched by fm/kernel/hashcach.fth
: remove-word ( new-alf voc-acf -- )
>threads ( new-alf prev-link )
swap link> swap link> ( new-acf prev-link )
2dup link@ = if ( acf prev-link )
swap >link link@ swap link! exit ( )
another-link? 0= ( acf [ next-link ] end? )
\ Makes a sealed vocabulary with the top-of-voc pointer in user area
\ parameter field of vocabularies contains:
\ user-#-of-voc-pointer , voc-link ,
\ For navigating inside a vocabulary's data structure.
\ A vocabulary's parameter field contains:
\ The threads are stored in the user area.
\ The link-field points to the preceding vocabulary.
\ Historically, the pointer was the address of the link-field;
\ but in our current implementation, the pointer is the ACF.
: voc> ( voc-link-adr -- acf )
\ \ Comment-out the code to go from link-field to ACF,
\ \ in case we ever resurrect the old way.
: >voc-link ( voc-acf -- voc-link-adr ) >body /user# + ;
/link user#, !null-link ( )
0 , \ Space for additional information
does> body> context token!
projects / OpenSPARC-T2-SAM / blob