Initial commit of OpenSPARC T2 architecture model.

[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / tagvoc.fth

\ ========== 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 
\    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: @(#)tagvoc.fth 3.9 04/03/19 17:00:34
purpose: 
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

headers

\ 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? )
   find-name				( anf )

   \ 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.
      bounds ?do			( anf true )
	 i c@ bl 1+ h# 7e between  0=
	 if  0= leave  then
      loop				( anf good-name? )
   then
;

\ 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  ;

nuser last

headerless

: $make-header  ( adr len voc-acf -- )
   -rot 					( voc-acf adr,len )
   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 )
   over + c!					( voc-acf )
   here 1- last !				( voc-acf )
   >threads					( threads-adr )
   /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!
;

headers
: >first  ( voc-acf -- first-alf )  >threads  ;

[ifndef] XREF
: $find-word  ( adr len voc-acf -- adr len [ false | xt,+-1 ] )
   >first  $find-next  find-fixup
;
[else]
\
\ 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 )
      2swap				      ( xt,+-1 adr len )
      r> ['] lose <>			      ( xt,+-1 adr len xref? )
      if  xref-find-hook  then		      ( xt,+-1 adr len )
      2drop				      ( xt,-+1 )
   else					      ( adr len adr,len,0 )
      r> drop  >r 2swap 2drop r>	      ( adr,len,0 )
   then					      ( adr len [ false | xt,+-1 ] )
;
[then]

headerless
: >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 -- )
   >ptr              ( new-alf alf )
   swap link> swap   ( new-acf alf )
   2dup link@        ( new-acf alf  new-acf next-acf )
   swap >link link! link!
;

headers
\
\ 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 )
   begin                                      ( acf prev-link )
      >link
      2dup link@ =  if                        ( acf prev-link )
         swap >link link@ swap link!  exit    (  )
      then                                    ( acf prev-link )
      another-link? 0=                  ( acf [ next-link ] end? )
   until
   drop
;

\ 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:
\   user#  link
\ 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.
\   /user# -  body>
;

: >voc-link ( voc-acf -- voc-link-adr )  >body /user# +  ;

: (wordlist)  ( -- )
   create-cf
   /link user#,  !null-link   ( )
   voc-link,
   0 ,				\ Space for additional information
   does> body> context token!
; resolves <vocabulary>
headers