[OpenSPARC-T2-SAM] / obp / obp / os / bootprom / testdevt.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: testdevt.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: @(#)testdevt.fth 2.43 05/02/03
purpose:
copyright: Copyright 2005 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

headerless

also hidden
: chdump ( addr len -- )  push-hex ['] c@ to dc@ d.2 pop-base ;
previous

: char?  ( byte -- flag )
   dup bl h# 7e between           ( byte printable?)
   over carret = rot linefeed =   ( printable? cr? nl?)
   or or			  ( printable?)
;

\ Algorithm:
\
\ This is a reasonable heuristic to test composite encoded strings.
\
\ A printable string is a sequence of bytes that contains all 
\ printable chars; a composite string is a sequence of non-empty 
\ printable strings separated by a null byte. Legalistically, 
\ a null byte is the terminator of a printable string,
\ but in existing practice, some string properties (e.g., in the
\ /options node) are encoded without a null byte at the end.
\ To maintain compatibility, we will consider the last string
\ valid either way - with or without a terminating null byte.
\ While two null bytes in a row might be interpreted as an empty
\ string, we will not consider that valid in a composite string.
\
\ Any sequence of printable bytes will be decoded as string(s) 
\ and printed even if it was originally encoded as an integer byte 
\ stream. There is no foolproof decode solution available until we 
\ change the implementation of properties in OBP to encode a
\ property type as well as the property data. 
\
\ Implementation:
\
\ Initial setting of "previous byte non-null?" flag will affect 
\ how a leading null-byte is treated. We want a leading null-byte 
\ to become non-valid; it will be, if we initialize this flag to 
\ false, by virtue of running afoul of the "two consecutive nulls" 
\ rule. However, we want to make a special case of a property that
\ consists of only a single null-byte: we want to allow that as an 
\ empty string, and that can be achieved by initializing this flag 
\ to true if the length is 1 (a single-byte non-null will be 
\ subjected to the char? test). Initial setting of composite? flag 
\ will only be applicable to an empty string, which we want to fail. 
\ Otherwise, the initial composite? flag  will be discarded upon
\ entering the ?do loop.

: text?  ( adr len -- composite? )
   dup 1 = false		        ( adr len prev-non-null? false ) 
   2swap bounds  ?do 			( prev-non-null? composite? )
      drop i c@ dup  if	 		( prev-non-null? byte|null )
	 char?				( prev-non-null? printable? )
	 \  Update prev-non-null? It should be true,
	 \  but if byte is not printable, it doesn't matter.
	 nip dup			( prev-non-null? composite? )
      else
 	 \  Null-byte seen.		( prev-non-null? false )
	 \  Update prev-non-null? It is now false.
	 \  If existing prev-non-null? was also false,
	 \  then this is not a valid composite.
	 swap				( false prev-non-null? )
      then				( non-null? composite? )
      dup 0= ?leave			( non-null? composite? )
   loop  nip			        ( composite? )
;
  
: .node-name ( -- ) "temp 0 (append-name+unit) type ;

: .nodeid  ( -- )  current-device .h  .node-name  cr  ;

: 8.x  ( n -- )
   push-hex
   <#  u# u# u# u#  u# u# u# u#  u#>  type space
   pop-base 
;

: to-display-column  ( -- )  d# 25 to-column  ; 

\ Displays the property value "adr,len" as a list of integer values,
\ showing '#ints/line' on each line.

: .ints  ( adr len #ints/line  -- exited? )
   >r begin  dup 0>  while	( adr len )
      exit?  if  r> 3drop true  exit  then 	
      to-display-column		( adr len )
      r@  0  do			( adr len  )  
         decode-int 8.x		( adr'len' ) 
         dup 0=  ?leave		( adr'len' ) 
      loop cr			( adr'len' )
   repeat			( adr'len' )
   r> 3drop false		( exited? )
;

\ Display the property value "adr,len" as a list of strings,
\ showing one string on each line; "adr,len" must pass the 
\ printability test first (use text?).

: show-strings  ( adr len -- exited? )
   begin  dup  while  
      exit?  if  2drop true exit  then
      decode-string  to-display-column type cr  
   repeat  2drop false 
;

: my-#size-cells  ( -- #size-cells )
   " #size-cells" get-property  if  1  else  get-encoded-int  then
;

: parent-#size-cells  ( -- #size-cells )
   \ Root node has no parent, therefore the size of its parent's address
   \ space is meaningless
   root-device?  if  0  exit  then
   current-device >r pop-device my-#size-cells r> push-device
;

: size+  ( #cells -- #cells+#size-cells )  parent-#size-cells +  ;

headers
vocabulary known-int-properties
also known-int-properties definitions

: available        ( -- n )  '#adr-cells @ size+  ;
: reg              ( -- n )  '#adr-cells @ size+  ;
: existing         ( -- n )  '#adr-cells @ size+  ;
: ranges           ( -- n )  '#adr-cells @  #adr-cells + my-#size-cells +  ;

alias address    1 ( -- n )    
alias interrupts 1 ( -- n )   
alias intr       2 ( -- n )  
alias clock-frequency 1 ( -- n )    

previous definitions

headerless
: display  ( anf prop-addr,len -- exited? )
   rot  name>string			     ( adr,len  name,len )

   ['] known-int-properties (search-wordlist)  if
       execute .ints  exit
   then                                      ( adr,len )

   \ Test for unprintable characters; allow composite strings.
   2dup text?  if  show-strings exit  then   ( adr,len )

   dup /l =  if  1 .ints exit  then          ( adr,len )

   dup -rot				     ( len adr,len ) 
   to-display-column  h# 10 min chdump       ( len )	      
   h# 10 >  if ." ..."  then                 ( )
   false				     ( exited? )  
;

: .not-devtree ( -- )
   ." Not at a device tree node. Use 'dev <device-pathname>'."
;
: (.property)  ( anf xt -- exited? )  dup .name >r r@ get r> decode display  ;
headers
: .properties  ( -- )
   device-context?  if
      0  current-properties                         ( alf voc-acf )
      begin                                         ( alf voc-acf )
         ??cr exit?  if  2drop exit  then           ( )
         another-word?  while                       ( alf' voc-acf anf )
         dup name> (.property) if  2drop exit  then ( )
      repeat                                        ( alf' voc-acf )
   else                                             ( )
      .not-devtree                                  ( )
   then                                             ( )
;
: ls  ( -- )
   device-context?  if
      'child token@                   ( first-node )
      begin  non-null?  while         ( node )
	 push-device                  ( )
	 .nodeid                      ( )
	 'peer token@                 ( node' )
	 pop-device
      repeat                          ( )
   else
      .not-devtree
   then
;

: pwd  ( -- )
   device-context?  if
      pwd$ type
   else
      .not-devtree
   then
   cr
;
headerless
: shownode  ( -- false )  exit?  if  true  else  pwd false  then  ;
: optional-arg-or-/$ ( -- adr len )
   parse-word dup 0=  if  2drop " /"  then  ( adr len )
;
headers
: $show-devs ( path$ -- )
   also
   find-device
   ['] shownode  ['] (search-preorder) catch 2drop
   previous definitions
;
: show-devs  ( ["path"] -- )  optional-arg-or-/$ $show-devs  ;

: dev  ( -- )
   optional-arg-or-/$            ( adr,len )
   ?expand-alias                 ( adr,len )
   2dup " .." $=  if             ( adr,len )
      2drop device-context?  if  (  )
	 pop-device              (  )
      else                       (  )
	 .not-devtree            (  )
      then                       (  )
   else                          ( adr,len )
      find-device                (  )
   then                          (  )
;

: show-props  ( -- )
   also
   optional-arg-or-/$           ( adr len )
   find-device  .properties  device-end
   previous definitions
;
headerless
: show-aliases  ( -- )
   also  " /aliases" find-device  .properties  (  )
   previous definitions                        (  )
;
: show-alias  ( adr len -- )
   2dup " name" $= 0=  if     ( adr,len )
      ['] aliases $vfind  if  ( xt )
	 dup >name swap  (.property) drop exit
      then                    ( adr,len )
   then                       ( adr,len )
   type ."  : no such alias"  (  )
;
headers
: devalias  \ name string  ( -- )
   parse-word  parse-word
   dup  if                        ( name$ path$ )
      $devalias  (  )
   else                           ( name$ path$ )
      2drop dup  if               ( name$ )
	 show-alias               (  )
      else                        ( name$ )
	 2drop show-aliases       (  )
      then                        (  )
   then                           (  )
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: testdevt.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	id: @(#)testdevt.fth 2.43 05/02/03
	43	purpose:
	44	copyright: Copyright 2005 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	headerless
	48
	49	also hidden
	50	: chdump ( addr len -- ) push-hex ['] c@ to dc@ d.2 pop-base ;
	51	previous
	52
	53	: char? ( byte -- flag )
	54	dup bl h# 7e between ( byte printable?)
	55	over carret = rot linefeed = ( printable? cr? nl?)
	56	or or ( printable?)
	57	;
	58
	59	\ Algorithm:
	60	\
	61	\ This is a reasonable heuristic to test composite encoded strings.
	62	\
	63	\ A printable string is a sequence of bytes that contains all
	64	\ printable chars; a composite string is a sequence of non-empty
65	\ printable strings separated by a null byte. Legalistically,
66	\ a null byte is the terminator of a printable string,
67	\ but in existing practice, some string properties (e.g., in the
68	\ /options node) are encoded without a null byte at the end.
69	\ To maintain compatibility, we will consider the last string
70	\ valid either way - with or without a terminating null byte.
71	\ While two null bytes in a row might be interpreted as an empty
72	\ string, we will not consider that valid in a composite string.
73	\
74	\ Any sequence of printable bytes will be decoded as string(s)
75	\ and printed even if it was originally encoded as an integer byte
76	\ stream. There is no foolproof decode solution available until we
77	\ change the implementation of properties in OBP to encode a
78	\ property type as well as the property data.
79	\
80	\ Implementation:
81	\
82	\ Initial setting of "previous byte non-null?" flag will affect
83	\ how a leading null-byte is treated. We want a leading null-byte
84	\ to become non-valid; it will be, if we initialize this flag to
85	\ false, by virtue of running afoul of the "two consecutive nulls"
86	\ rule. However, we want to make a special case of a property that
87	\ consists of only a single null-byte: we want to allow that as an
88	\ empty string, and that can be achieved by initializing this flag
89	\ to true if the length is 1 (a single-byte non-null will be
90	\ subjected to the char? test). Initial setting of composite? flag
91	\ will only be applicable to an empty string, which we want to fail.
92	\ Otherwise, the initial composite? flag will be discarded upon
93	\ entering the ?do loop.
94
95	: text? ( adr len -- composite? )
96	dup 1 = false ( adr len prev-non-null? false )
97	2swap bounds ?do ( prev-non-null? composite? )
98	drop i c@ dup if ( prev-non-null? byte\|null )
99	char? ( prev-non-null? printable? )
100	\ Update prev-non-null? It should be true,
101	\ but if byte is not printable, it doesn't matter.
102	nip dup ( prev-non-null? composite? )
103	else
104	\ Null-byte seen. ( prev-non-null? false )
105	\ Update prev-non-null? It is now false.
106	\ If existing prev-non-null? was also false,
107	\ then this is not a valid composite.
108	swap ( false prev-non-null? )
109	then ( non-null? composite? )
110	dup 0= ?leave ( non-null? composite? )
111	loop nip ( composite? )
112	;
113
114	: .node-name ( -- ) "temp 0 (append-name+unit) type ;
115
116	: .nodeid ( -- ) current-device .h .node-name cr ;
117
118	: 8.x ( n -- )
119	push-hex
120	<# u# u# u# u# u# u# u# u# u#> type space
121	pop-base
122	;
123
124	: to-display-column ( -- ) d# 25 to-column ;
125
126	\ Displays the property value "adr,len" as a list of integer values,
127	\ showing '#ints/line' on each line.
128
129	: .ints ( adr len #ints/line -- exited? )
130	>r begin dup 0> while ( adr len )
131	exit? if r> 3drop true exit then
132	to-display-column ( adr len )
133	r@ 0 do ( adr len )
134	decode-int 8.x ( adr'len' )
135	dup 0= ?leave ( adr'len' )
136	loop cr ( adr'len' )
137	repeat ( adr'len' )
138	r> 3drop false ( exited? )
139	;
140
141	\ Display the property value "adr,len" as a list of strings,
142	\ showing one string on each line; "adr,len" must pass the
143	\ printability test first (use text?).
144
145	: show-strings ( adr len -- exited? )
146	begin dup while
147	exit? if 2drop true exit then
148	decode-string to-display-column type cr
149	repeat 2drop false
150	;
151
152	: my-#size-cells ( -- #size-cells )
153	" #size-cells" get-property if 1 else get-encoded-int then
154	;
155
156	: parent-#size-cells ( -- #size-cells )
157	\ Root node has no parent, therefore the size of its parent's address
158	\ space is meaningless
159	root-device? if 0 exit then
160	current-device >r pop-device my-#size-cells r> push-device
161	;
162
163	: size+ ( #cells -- #cells+#size-cells ) parent-#size-cells + ;
164
165	headers
166	vocabulary known-int-properties
167	also known-int-properties definitions
168
169	: available ( -- n ) '#adr-cells @ size+ ;
170	: reg ( -- n ) '#adr-cells @ size+ ;
171	: existing ( -- n ) '#adr-cells @ size+ ;
172	: ranges ( -- n ) '#adr-cells @ #adr-cells + my-#size-cells + ;
173
174	alias address 1 ( -- n )
175	alias interrupts 1 ( -- n )
176	alias intr 2 ( -- n )
177	alias clock-frequency 1 ( -- n )
178
179	previous definitions
180
181	headerless
182	: display ( anf prop-addr,len -- exited? )
183	rot name>string ( adr,len name,len )
184
185	['] known-int-properties (search-wordlist) if
186	execute .ints exit
187	then ( adr,len )
188
189	\ Test for unprintable characters; allow composite strings.
190	2dup text? if show-strings exit then ( adr,len )
191
192	dup /l = if 1 .ints exit then ( adr,len )
193
194	dup -rot ( len adr,len )
195	to-display-column h# 10 min chdump ( len )
196	h# 10 > if ." ..." then ( )
197	false ( exited? )
198	;
199
200	: .not-devtree ( -- )
201	." Not at a device tree node. Use 'dev <device-pathname>'."
202	;
203	: (.property) ( anf xt -- exited? ) dup .name >r r@ get r> decode display ;
204	headers
205	: .properties ( -- )
206	device-context? if
207	0 current-properties ( alf voc-acf )
208	begin ( alf voc-acf )
209	??cr exit? if 2drop exit then ( )
210	another-word? while ( alf' voc-acf anf )
211	dup name> (.property) if 2drop exit then ( )
212	repeat ( alf' voc-acf )
213	else ( )
214	.not-devtree ( )
215	then ( )
216	;
217	: ls ( -- )
218	device-context? if
219	'child token@ ( first-node )
220	begin non-null? while ( node )
221	push-device ( )
222	.nodeid ( )
223	'peer token@ ( node' )
224	pop-device
225	repeat ( )
226	else
227	.not-devtree
228	then
229	;
230
231	: pwd ( -- )
232	device-context? if
233	pwd$ type
234	else
235	.not-devtree
236	then
237	cr
238	;
239	headerless
240	: shownode ( -- false ) exit? if true else pwd false then ;
241	: optional-arg-or-/$ ( -- adr len )
242	parse-word dup 0= if 2drop " /" then ( adr len )
243	;
244	headers
245	: $show-devs ( path$ -- )
246	also
247	find-device
248	['] shownode ['] (search-preorder) catch 2drop
249	previous definitions
250	;
251	: show-devs ( ["path"] -- ) optional-arg-or-/$ $show-devs ;
252
253	: dev ( -- )
254	optional-arg-or-/$ ( adr,len )
255	?expand-alias ( adr,len )
256	2dup " .." $= if ( adr,len )
257	2drop device-context? if ( )
258	pop-device ( )
259	else ( )
260	.not-devtree ( )
261	then ( )
262	else ( adr,len )
263	find-device ( )
264	then ( )
265	;
266
267	: show-props ( -- )
268	also
269	optional-arg-or-/$ ( adr len )
270	find-device .properties device-end
271	previous definitions
272	;
273	headerless
274	: show-aliases ( -- )
275	also " /aliases" find-device .properties ( )
276	previous definitions ( )
277	;
278	: show-alias ( adr len -- )
279	2dup " name" $= 0= if ( adr,len )
280	['] aliases $vfind if ( xt )
281	dup >name swap (.property) drop exit
282	then ( adr,len )
283	then ( adr,len )
284	type ." : no such alias" ( )
285	;
286	headers
287	: devalias \ name string ( -- )
288	parse-word parse-word
289	dup if ( name$ path$ )
290	$devalias ( )
291	else ( name$ path$ )
292	2drop dup if ( name$ )
293	show-alias ( )
294	else ( name$ )
295	2drop show-aliases ( )
296	then ( )
297	then ( )
298	;