[OpenSPARC-T2-SAM] / obp / obp / fm / lib / sift.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: sift.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 ============================================
\ sift.fth 2.11 99/05/04
\ Copyright 1985-1990 Bradley Forthware

also hidden
only forth also hidden also definitions
decimal
headerless

variable sift-vocabulary

\ Leave a "hook" for showing the name of the vocabulary
\ only once, the first time a matching name is found.
\ Showing the name of a device can be plugged in here also...
defer .voc     ['] noop is .voc

: .in  ( -- )  ??cr tabstops @ spaces  ." In "  ;
: .vocab  ( -- )
   .in ['] vocabulary .name space
   sift-vocabulary @ .name cr
   ['] noop is .voc
;

\ Show the "sifted" name, preceded by its  cfa  in parentheses.
\ Show the name of the vocabulary only the first time.
\ Control the display with  exit?
: .sift?  ( nfa -- exit? )
   .voc
   exit? tuck  if  drop exit  then  		( exit? nfa )
   dup  name>				 	( exit? nfa cfa )
   over n>flags c@  h# 20 and  if  token@  then	  \ Handle aliases
   fake-name			 		( nfa fstr )
   over name>string nip
   over name>string nip + 3 + .tab
  .id .id 2 spaces
;

\ Sift through the given vocabulary, using the sift-string given.
\ Control the display with  exit?
: vsift?  ( adr,len voc-acf -- exit? )
   dup sift-vocabulary !
   -rot 2>r 0 swap                      ( alf voc-acf )      ( r: adr,len )
   begin  another-word?  while	        ( alf' voc-acf nfa ) ( r: adr,len )
      dup 2r@  rot  name>string sindex	( alf' voc-acf nfa indx|-1 ) ( r: adr,len )
      1+  if  .sift?  if                ( alf' voc-acf ) ( r: adr,len )
	 2drop  2r>  2drop true  exit
	 then                           ( alf' voc-acf ) ( r: adr,len )
      else                              ( alf' voc-acf nfa ) ( r: adr,len )
	 drop                           ( alf' voc-acf ) ( r: adr,len )
      then                              ( alf' voc-acf ) ( r: adr,len )
   repeat  2r>  2drop  false            ( false )
;

headers
forth definitions

\ Sift through all the vocabularies for the string given
\ on the stack as  addr,len
: $sift ( adr,len -- )
   voc-link  begin  another-link?  while	( adr,len v-link )
      ['] .vocab is .voc                        ( adr,len v-link )
      voc> >r                                   ( adr,len ) ( r: voc-acf )
      2dup r@ vsift?  if  r> 3drop  exit  then  ( adr,len ) ( r: voc-acf )
      r> >voc-link                              ( adr,len v-link' )
   repeat  2drop                                (  )
;

\  Same thing, only the string is given on the stack in packed format
: sift  ( str -- )  count $sift  ;

\  Same thing, only the string is given in the input stream.
: sifting  \ name  ( -- )
   safe-parse-word $sift
;

only forth also definitions
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: sift.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	\ sift.fth 2.11 99/05/04
	43	\ Copyright 1985-1990 Bradley Forthware
	44
	45	also hidden
	46	only forth also hidden also definitions
	47	decimal
	48	headerless
	49
	50	variable sift-vocabulary
	51
	52	\ Leave a "hook" for showing the name of the vocabulary
	53	\ only once, the first time a matching name is found.
	54	\ Showing the name of a device can be plugged in here also...
	55	defer .voc ['] noop is .voc
	56
	57	: .in ( -- ) ??cr tabstops @ spaces ." In " ;
	58	: .vocab ( -- )
	59	.in ['] vocabulary .name space
	60	sift-vocabulary @ .name cr
	61	['] noop is .voc
	62	;
	63
	64	\ Show the "sifted" name, preceded by its cfa in parentheses.
65	\ Show the name of the vocabulary only the first time.
66	\ Control the display with exit?
67	: .sift? ( nfa -- exit? )
68	.voc
69	exit? tuck if drop exit then ( exit? nfa )
70	dup name> ( exit? nfa cfa )
71	over n>flags c@ h# 20 and if token@ then \ Handle aliases
72	fake-name ( nfa fstr )
73	over name>string nip
74	over name>string nip + 3 + .tab
75	.id .id 2 spaces
76	;
77
78	\ Sift through the given vocabulary, using the sift-string given.
79	\ Control the display with exit?
80	: vsift? ( adr,len voc-acf -- exit? )
81	dup sift-vocabulary !
82	-rot 2>r 0 swap ( alf voc-acf ) ( r: adr,len )
83	begin another-word? while ( alf' voc-acf nfa ) ( r: adr,len )
84	dup 2r@ rot name>string sindex ( alf' voc-acf nfa indx\|-1 ) ( r: adr,len )
85	1+ if .sift? if ( alf' voc-acf ) ( r: adr,len )
86	2drop 2r> 2drop true exit
87	then ( alf' voc-acf ) ( r: adr,len )
88	else ( alf' voc-acf nfa ) ( r: adr,len )
89	drop ( alf' voc-acf ) ( r: adr,len )
90	then ( alf' voc-acf ) ( r: adr,len )
91	repeat 2r> 2drop false ( false )
92	;
93
94	headers
95	forth definitions
96
97	\ Sift through all the vocabularies for the string given
98	\ on the stack as addr,len
99	: $sift ( adr,len -- )
100	voc-link begin another-link? while ( adr,len v-link )
101	['] .vocab is .voc ( adr,len v-link )
102	voc> >r ( adr,len ) ( r: voc-acf )
103	2dup r@ vsift? if r> 3drop exit then ( adr,len ) ( r: voc-acf )
104	r> >voc-link ( adr,len v-link' )
105	repeat 2drop ( )
106	;
107
108	\ Same thing, only the string is given on the stack in packed format
109	: sift ( str -- ) count $sift ;
110
111	\ Same thing, only the string is given in the input stream.
112	: sifting \ name ( -- )
113	safe-parse-word $sift
114	;
115
116	only forth also definitions