obp/obp/fm/kernel/voccom.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: voccom.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 ============================================
\ voccom.fth 3.15 02/05/02
\ Copyright 1985-1990 Bradley Forthware
\ Copyright: Copyright 1999-2002 Sun Microsystems, Inc.  All Rights Reserved
\ Copyright: Use is subject to license terms.

\ Common routines for vocabularies, independent of name field
\ implementation details

headers
: wordlist  ( -- wid )  (wordlist) lastacf  ;
: vocabulary  ( "name" -- )  header (wordlist)  ;

defer $find-next
' ($find-next) is $find-next

\  : insert-after  ( new-node old-node -- )
\     dup link@        ( new-node old-node next-node )
\     2 pick link!     ( new-node old-node )
\     link!
\  ;
tuser hidden-voc   origin-t is hidden-voc

: not-hidden  ( -- )  hidden-voc !null-token  ;

\ WARNING: current-voc is patched later by fm/lib/hashcach.fth
: hide   (s -- )
   current-voc hidden-voc token!
   last @
   [ifexist] xref-hide-hook  dup name>string xref-hide-hook 2drop [then]
   n>link current-voc remove-word
;

\ WARNING: hidden-voc is patched later  by fm/lib/hashcach.fth
: reveal  (s -- )
   hidden-voc get-token?  if                    ( xt )
      last @                                    ( xt )
      [ifexist] xref-reveal-hook dup name>string xref-reveal-hook  2drop [then]
      n>link 0  rot  insert-word                ( )
      not-hidden
   then
;

#threads-t constant #threads

auser voc-link     \ points to newest vocabulary

headerless

: voc-link,  (s -- )  \ links this vocabulary to the chain
   lastacf  voc-link link@  link,   voc-link link!
;

hex
0 value fake-name-buf

headers
: fake-name  ( xt -- anf )
   base @ >r hex
   <#  0 hold ascii ) hold  u#s  ascii ( hold  u#>   ( adr len )
   fake-name-buf $save       ( adr len )
   tuck + 1- tuck            ( anf len adr+len )
   swap 1- h# 80 or swap c!  ( adr )
   r> base !
;

\ Returns the name field address, or if the word is headerless, the
\ address of a numeric string representing the xt in parentheses.
: >name  ( xt -- anf )
   dup >name?  if  nip  else  drop fake-name  then
;

: immediate  (s -- )  last @  n>flags  dup c@  40 or  swap c!  ;
: immediate?  (s xt -- flag )  >flags c@  40 and  0<>  ;
: flagalias  (s -- )  last @  n>flags  dup c@  20 or  swap c!  ;
: .last  (s -- )  last @ .id  ;

: current-voc  ( -- voc-xt )  current token@  ;
: context-voc  ( -- voc-xt )  context token@  ;

0 value canonical-word
headerless

: duplicate-notification ( adr len voc -- adr len voc )
   where (compile-time-warning)
   >r 2dup type r> ."  isn't unique " cr
;

chain: init  ( -- )
   d# 20 alloc-mem  is fake-name-buf
   d# 32 alloc-mem  is canonical-word
;

headers
: $canonical  ( adr len -- adr' len' )
   caps @  if  d# 31 min  canonical-word $save  2dup lower  then
;

: $create-word  ( adr len voc-xt -- )
   >r $canonical
[ifexist] xref-header-hook
   xref-header-hook
[then]
  r> warning @  if
      3dup  $find-word  if   ( adr len voc-xt  xt )
         drop  duplicate-notification
      else                   ( adr len voc-xt  adr len )
         2drop
      then
   then                      ( adr len voc-xt )
   $make-header
;

: ($header)  (s adr len -- )  current-voc $create-word  ;

' ($header) is $header

: (search-wordlist)  ( adr len vocabulary -- false | xt +-1 )
   $find-word  dup  0=  if  nip nip  then
;
: search-wordlist  ( adr len vocabulary -- false | xt +-1 )
   >r $canonical r> (search-wordlist)
;
: $vfind  ( adr len vocabulary -- adr len false | xt +-1 )
   >r $canonical r> $find-word
;

: find-fixup  ( adr len alf true  |  adr len false -- xt +-1  |  adr len 0 )
   dup  if                                        ( adr len alf true )
      drop nip nip                                ( alf )
      dup link> swap l>name n>flags c@            ( xt flags )
      dup  h# 20 and  if  swap token@ swap  then  ( xt' flags )  \ alias?
      h# 40 and  if  1  else  -1  then                           \ immediate?
   then
;

headerless
2 /n-t * ualloc-t user tbuf
headers
: follow  ( voc-acf -- )  tbuf token!  0 tbuf na1+ !  ;

: another?  ( -- false  |  anf true )
   tbuf na1+ @  tbuf token@  next-word  ( 0 | alf true )
   if  dup tbuf na1+ !  l>name  true  else  false  then
;

: another-word? ( alf|0  voc-acf -- alf' voc-acf anf true  |  false )
   tuck next-word  if    ( voc-acf alf' )
      tuck l>name  true  ( alf' voc-acf anf true )
   else                  ( voc-acf )
      drop  false        ( false )
   then
;

\ Forget

headerless
: trim   (s alf voc-acf -- )
   >r 0                                       ( adr 0 )
   begin  r@ next-word   while                ( adr alf )
      2dup <=  if  dup r@ remove-word  then   ( adr alf )
   repeat                                     ( adr )
   r> 2drop
;

headers

auser fence        \ barrier for forgetting

: (forget)   (s adr -- )        \ reclaim dictionary space above "adr"

   dup fence a@ u< ( -15 ) abort" below fence"  ( adr )

   \ Forget any entire vocabularies defined after "adr"

   voc-link                          ( adr first-voc )
   begin                             ( adr voc )
      \ XXX this may not work with a mixed RAM/ROM system where
      \ RAM is at a lower address than ROM
      link@ 2dup  u<                 ( adr voc' more? )
   while                             ( adr voc )
      dup voc> current-voc =         ( adr voc error? )
      ( -15 ) abort" I can't forget the current vocabulary."
      \ Remove the voc from the search order
      dup voc> (except               ( adr voc )
      >voc-link                      ( adr voc-link )
   repeat                            ( adr voc )
   dup voc-link link!                ( adr voc )

   \ For all remaining vocabularies, unlink words defined after "adr"

   \ We assume that we haven't forgotten all the vocabularies;
   \ otherwise this will fail.  Forgetting all the vocabularies would
   \ crash the system anyway, so we don't worry about it.
   begin                             ( adr voc )
      2dup voc> trim                 ( adr voc )
      >voc-link                      ( adr voc-link-adr )
      another-link? 0=               ( adr voc' )
   until                             ( adr )
   l>beginning  here - allot     \ Reclaim dictionary space
;

: forget   (s -- )
   safe-parse-word   current-voc $vfind  $?missing  drop
   >link  (forget)
;

: marker  ( "name" -- )
   create  #user @ ,
   does> dup @  #user !  body> >link  (forget)
;

chain: init ( -- ) ['] ($find-next) is $find-next  ;