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

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


headers

vocabulary aliases

headerless
4 /n* buffer: unit#
0 value unit#-valid?
: unit-bounds  ( -- end-adr start-adr )  unit#  '#adr-cells @ /n*  bounds  ;

: "name" ( -- adr,len )  " name"  ;  \ Space savings

\ True if "name$" matches the node's name
: name-match?  ( name$ -- name$ flag )
   "name" get-property  if                  ( name$ )
      false                                 ( name$ false )
   else                                     ( name$ adr' len' )
      1-    \ Omit null byte 		    ( name$ adr' len' )
      2over 2over  $=  if                   ( name$ adr' len' )
         2drop true                         ( name$ true )
      else                                  ( name$ adr' len' )
         \ Omit the manufacturer name and test again
         ascii , left-parse-string  2drop  2over  $=
      then
   then                                     ( name$ flag )
;

\ True if "unit-adr,space" matches the node's unit number
: unit-match?  ( -- flag )
   get-unit  if                 (  )
      false  	                ( flag )  \ No "reg" property
   else                         ( phys.lo .. phys.hi )
      true                      ( unit-adr,len )
      unit-bounds  ?do          ( unit-adr,len  flag )
         -rot  decode-int       ( flag  unit-adr,len' n )
	 i @ =  3 roll and      ( unit-adr,len' flag' )
      /n +loop                  ( unit-adr,len' flag )
      nip nip                   ( flag )
   then                         ( flag )
;

\ True if the node has no unit number and "name$" matches the node's name
: wildcard-match?  ( name$ acf -- name$ acf flag )
   >r
   dup  if
      name-match?  0=  if  r> false  exit  then
   then                                                   ( name$ )

   get-unit  0=  if   nip nip  r> false  exit  then       ( name$ )

   dup 0=  unit#-valid? 0=  and  if  r> false  exit  then

   r> true
;

: exact-match?  ( name$ acf -- name$ acf flag )
   >r
   dup  if                              ( name$ )       \ Name present
      name-match?  0=  if  r> false  exit  then
   then                                 ( name$ )
   unit#-valid?  if                     ( name$ )       \ Unit present
      unit-match?  0=  if  r> false  exit  then
   then
   r> true
;

: (package-execute) ( str,len package -- ?? )
   setup-method$ (search-wordlist) if
      execute
   else
      no-proc throw
   then
;

headers

\ 1) Search direct children for an exact match
\ 2) Search direct children for a wildcard match
\ 3) Select each child node in turn and (recursively) repeat steps
\    (1), (2), and (3)

: (find-node)  ( unit$ name$ -- unit$ name$ )

   \ If the node has no children, then there is no point in searching it,
   \ and it doesn't matter if it has no decode-unit method
   first-child  0= if  exit  then

   \ Omit unit match test if no unit string or this is a support node
   support-node? @ 0=  pop-device  unit#-valid? and  if
      2over ['] (decode-unit) catch  if
         not-found throw
      then				( unit$ name$ phys.lo .. phys.hi )
      \ We can't use unit-bounds here
      unit# #adr-cells /n*  bounds  ?do  i !  /n +loop   ( unit$ name$ )
   then

   \ (search-level) will throw "found" to (find-device) if it succeeds
   ['] exact-match?     (search-level)  drop             ( unit$ name$ )
   ['] wildcard-match?  (search-level)  drop             ( unit$ name$ )
;

: (find-child-node)  ( unit$ name$ -- unit$ name$ ) recursive
   first-child  begin while   (find-node) (find-child-node)  next-child repeat
;

: (find-device)  ( str -- )

   0 to unit#-valid?

   \ If a search path is present, find the indicated subdirectory
   begin  dup  while                       ( str )

      \ Split the remaining string at the first backslash, if there is one
      ascii / left-parse-string            ( str component-str )

      \ Separate out arguments
      ascii : left-parse-string            ( str args-str name.unit$ )

      \ Arguments only apply to "open", so discard them when searching
      2swap 2drop                          ( rem$  name.unit$ )

      \ Split name and unit
      ascii @  left-parse-string           ( rem$  unit$  name$ )

      2 pick is unit#-valid?               ( rem$  unit$  name$ )

      ['] (find-node)  catch  0=  if            ( rem$ unit$ name$ )
         ['] (find-child-node)  invert-signal   ( rem$ unit$ name$ )
      then                                      ( rem$ unit$ name$ )
      2drop 2drop
   repeat                                  ( rem$ )

   2drop
;

: not-alias?  ( str -- expansion$ false | true )
   \ Search the alias list.
   ['] aliases (search-wordlist)  if  execute false  else  true  then
;

d# 132 buffer: alias-buf

\ Expands devaliases optionally overwriting the default argument
\ to the rightmost component of the expanded pathname
: expand-alias  ( devspec$ -- pathname$ flag )

   \ Extract the part of the pathname that can be an alias

   2dup  ascii /  split-before  ( devspec$ tail$ head$ )
   ascii :  split-before        ( devspec$ tail$ arg$ name$ )

   \ If the device-specifier is not an alias, return it unmodified.

   not-alias?  if               ( devspec$ tail$ arg$ )
      2drop 2drop false  exit   ( devspec$ )
   then                         ( devspec$ tail$ arg$ expansion$ )

   \ The device-specifier is an alias.

   \ If the aliased component of the device-specifier had explicit
   \ arguments, use them to override any arguments that were included
   \ in the alias expansion.

   2 pick  if                   ( devspec$ tail$ arg$ expansion$ )
      \ alias name has args
      ascii / split-after       ( devspec$ tail$ arg$ alias-tail$ alias-head$ )
      alias-buf place           ( devspec$ tail$ arg$ alias-tail$ )
      ascii : split-before      ( devspec$ tail$ arg$ $deadargs $alias-tail$' )
      alias-buf $cat            ( devspec$ tail$ arg$ $deadargs )
      2drop  alias-buf $cat     ( devspec$ tail$ )
   else                         ( devspec$ tail$ arg$ expansion$ )
      \ alias name does not have args
      alias-buf place           ( devspec$ tail$ arg$ )
      2drop                     ( devspec$ tail$ )
   then                         ( devspec$ tail$ )

   \ Append the tail of the device specifier to the expanded alias

   alias-buf $cat               ( devspec$ )
   2drop                        ( devspec$ )
   alias-buf count  true        ( pathname$ true )
;
: aliased?  ( name-str -- name-str false | alias-expansion-str true )
   \ The empty string is not an alias
   dup 0=  if  false exit  then               ( str )

   \ A pathname beginning with a slash is not an alias
   over c@  ascii / =  if  false exit  then   ( str )

   expand-alias
;
: ?expand-alias  ( name-str -- name-str | alias-expansion-str )
   aliased? drop
;

: context-voc? ( voc acf -- voc acf false | ??) over context-voc = throw false ;

: device-context? ( -- device-node? )
   context-voc ['] root-node =  if  true exit  then
   current-voc >r also context-voc root-node            ( voc )
   ['] context-voc? ['] (search-preorder) catch nip nip ( device-node?)
   r> set-current previous				( device-node?) 
;
\ rather than move a whole load of code around it is easier to patch
\ the device-end routine in devtree.fth
patch device-context? false device-end

: ?not-found  ( flag -- )  if  not-found throw  then  ;
: noalias-find-device  ( str -- )
   \ Throw if null string
   ?dup 0=  ?not-found                 ( str$ )

   \ The path starts at the root directory if the first character is "/";
   \ otherwise it starts at the current directory
   dup 1 >=  if                        ( str$ )
      over c@  ascii /  =  if  1 /string  ['] root-node push-device  then
   then                                ( str$ )

   current-device null =  ?not-found
   device-context?  0= ?not-found
   (find-device)
;
: aliased-find-device  ( str -- )  ?expand-alias noalias-find-device  ;
headers
5 actions
action: count  ;
action: 3drop  ;        \ No "store" method
action:        ;        \ Just return the address
action: drop   ;        \ Decode method is null because string is already right
action: drop   ;        \ Encode method is null too
: $devalias  ( name-str expansion-str -- )
   also aliases definitions
   strip-blanks  2swap strip-blanks
   \ Create the alias w/o not unique warning.
   warning @ >r warning off $create r> warning !
   previous definitions
   ",
   use-actions
;
headerless
\ Do
: locate-device  ( adr len -- true  |  phandle false )
   also
   ['] aliased-find-device catch  if
      2drop true
   else
      current-device false
   then
   previous definitions
;
: noa-find-device  ( adr len -- )
   current-device >r
   ['] noalias-find-device  catch  case
      0          of  r> drop                          endof
      not-found  of  r> push-device  not-found throw  endof
      ( default )    r> push-device  throw
   endcase
;
headers
: find-device  ( adr len -- )  ?expand-alias noa-find-device  ;

: $parent-execute  ( adr len -- )
   current-device >r  pop-device  r@ >parent (package-execute)  r> push-device
;

: delete-device ( phandle -- deleted? )
   \ Save the current device
   current-device >r

   dup >parent   push-device     ( phandle )
   'child  begin                 ( phandle &phandle' )
      2dup link@ =  if           ( phandle &phandle' )
         true true               ( phandle &phandle' true true )
      else                       ( phandle &phandle' )
         link@ dup null =  if    ( phandle null )
            drop false true      ( phandle false true )
         else                    ( phandle phandle' )
            push-device 'peer    ( phandle &phandle" )
            false                ( phandle &phandle" done? )
         then                    ( phandle &phandle" false )
      then                       ( phandle &phandle' true true )
      \ OR                       ( phandle false true )
      \ OR 			 ( phandle &phandle" false )
   until  if                     ( phandle &prev-phandle )
      swap push-device 'peer     ( &prev-phandle &next-phandle )
      link@ swap link!  true     ( ok )
   else                          ( phandle )
      drop false                 ( failed )
   then                          ( ok? )
   \ Restore the current device
   r> push-device                ( ok? )
;

: $delete-device ( path$ -- deleted? )
   locate-device  if  false  exit  then  delete-device  ( deleted? )
;
headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: finddev.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: @(#)finddev.fth 2.43 06/02/16
	43	purpose:
	44	copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47
	48	headers
	49
	50	vocabulary aliases
	51
	52	headerless
	53	4 /n* buffer: unit#
	54	0 value unit#-valid?
	55	: unit-bounds ( -- end-adr start-adr ) unit# '#adr-cells @ /n* bounds ;
	56
	57	: "name" ( -- adr,len ) " name" ; \ Space savings
	58
	59	\ True if "name$" matches the node's name
	60	: name-match? ( name$ -- name$ flag )
	61	"name" get-property if ( name$ )
	62	false ( name$ false )
	63	else ( name$ adr' len' )
	64	1- \ Omit null byte ( name$ adr' len' )
65	2over 2over $= if ( name$ adr' len' )
66	2drop true ( name$ true )
67	else ( name$ adr' len' )
68	\ Omit the manufacturer name and test again
69	ascii , left-parse-string 2drop 2over $=
70	then
71	then ( name$ flag )
72	;
73
74	\ True if "unit-adr,space" matches the node's unit number
75	: unit-match? ( -- flag )
76	get-unit if ( )
77	false ( flag ) \ No "reg" property
78	else ( phys.lo .. phys.hi )
79	true ( unit-adr,len )
80	unit-bounds ?do ( unit-adr,len flag )
81	-rot decode-int ( flag unit-adr,len' n )
82	i @ = 3 roll and ( unit-adr,len' flag' )
83	/n +loop ( unit-adr,len' flag )
84	nip nip ( flag )
85	then ( flag )
86	;
87
88	\ True if the node has no unit number and "name$" matches the node's name
89	: wildcard-match? ( name$ acf -- name$ acf flag )
90	>r
91	dup if
92	name-match? 0= if r> false exit then
93	then ( name$ )
94
95	get-unit 0= if nip nip r> false exit then ( name$ )
96
97	dup 0= unit#-valid? 0= and if r> false exit then
98
99	r> true
100	;
101
102	: exact-match? ( name$ acf -- name$ acf flag )
103	>r
104	dup if ( name$ ) \ Name present
105	name-match? 0= if r> false exit then
106	then ( name$ )
107	unit#-valid? if ( name$ ) \ Unit present
108	unit-match? 0= if r> false exit then
109	then
110	r> true
111	;
112
113	: (package-execute) ( str,len package -- ?? )
114	setup-method$ (search-wordlist) if
115	execute
116	else
117	no-proc throw
118	then
119	;
120
121	headers
122
123	\ 1) Search direct children for an exact match
124	\ 2) Search direct children for a wildcard match
125	\ 3) Select each child node in turn and (recursively) repeat steps
126	\ (1), (2), and (3)
127
128	: (find-node) ( unit$ name$ -- unit$ name$ )
129
130	\ If the node has no children, then there is no point in searching it,
131	\ and it doesn't matter if it has no decode-unit method
132	first-child 0= if exit then
133
134	\ Omit unit match test if no unit string or this is a support node
135	support-node? @ 0= pop-device unit#-valid? and if
136	2over ['] (decode-unit) catch if
137	not-found throw
138	then ( unit$ name$ phys.lo .. phys.hi )
139	\ We can't use unit-bounds here
140	unit# #adr-cells /n* bounds ?do i ! /n +loop ( unit$ name$ )
141	then
142
143	\ (search-level) will throw "found" to (find-device) if it succeeds
144	['] exact-match? (search-level) drop ( unit$ name$ )
145	['] wildcard-match? (search-level) drop ( unit$ name$ )
146	;
147
148	: (find-child-node) ( unit$ name$ -- unit$ name$ ) recursive
149	first-child begin while (find-node) (find-child-node) next-child repeat
150	;
151
152	: (find-device) ( str -- )
153
154	0 to unit#-valid?
155
156	\ If a search path is present, find the indicated subdirectory
157	begin dup while ( str )
158
159	\ Split the remaining string at the first backslash, if there is one
160	ascii / left-parse-string ( str component-str )
161
162	\ Separate out arguments
163	ascii : left-parse-string ( str args-str name.unit$ )
164
165	\ Arguments only apply to "open", so discard them when searching
166	2swap 2drop ( rem$ name.unit$ )
167
168	\ Split name and unit
169	ascii @ left-parse-string ( rem$ unit$ name$ )
170
171	2 pick is unit#-valid? ( rem$ unit$ name$ )
172
173	['] (find-node) catch 0= if ( rem$ unit$ name$ )
174	['] (find-child-node) invert-signal ( rem$ unit$ name$ )
175	then ( rem$ unit$ name$ )
176	2drop 2drop
177	repeat ( rem$ )
178
179	2drop
180	;
181
182	: not-alias? ( str -- expansion$ false \| true )
183	\ Search the alias list.
184	['] aliases (search-wordlist) if execute false else true then
185	;
186
187	d# 132 buffer: alias-buf
188
189	\ Expands devaliases optionally overwriting the default argument
190	\ to the rightmost component of the expanded pathname
191	: expand-alias ( devspec$ -- pathname$ flag )
192
193	\ Extract the part of the pathname that can be an alias
194
195	2dup ascii / split-before ( devspec$ tail$ head$ )
196	ascii : split-before ( devspec$ tail$ arg$ name$ )
197
198	\ If the device-specifier is not an alias, return it unmodified.
199
200	not-alias? if ( devspec$ tail$ arg$ )
201	2drop 2drop false exit ( devspec$ )
202	then ( devspec$ tail$ arg$ expansion$ )
203
204	\ The device-specifier is an alias.
205
206	\ If the aliased component of the device-specifier had explicit
207	\ arguments, use them to override any arguments that were included
208	\ in the alias expansion.
209
210	2 pick if ( devspec$ tail$ arg$ expansion$ )
211	\ alias name has args
212	ascii / split-after ( devspec$ tail$ arg$ alias-tail$ alias-head$ )
213	alias-buf place ( devspec$ tail$ arg$ alias-tail$ )
214	ascii : split-before ( devspec$ tail$ arg$ $deadargs $alias-tail$' )
215	alias-buf $cat ( devspec$ tail$ arg$ $deadargs )
216	2drop alias-buf $cat ( devspec$ tail$ )
217	else ( devspec$ tail$ arg$ expansion$ )
218	\ alias name does not have args
219	alias-buf place ( devspec$ tail$ arg$ )
220	2drop ( devspec$ tail$ )
221	then ( devspec$ tail$ )
222
223	\ Append the tail of the device specifier to the expanded alias
224
225	alias-buf $cat ( devspec$ )
226	2drop ( devspec$ )
227	alias-buf count true ( pathname$ true )
228	;
229	: aliased? ( name-str -- name-str false \| alias-expansion-str true )
230	\ The empty string is not an alias
231	dup 0= if false exit then ( str )
232
233	\ A pathname beginning with a slash is not an alias
234	over c@ ascii / = if false exit then ( str )
235
236	expand-alias
237	;
238	: ?expand-alias ( name-str -- name-str \| alias-expansion-str )
239	aliased? drop
240	;
241
242	: context-voc? ( voc acf -- voc acf false \| ??) over context-voc = throw false ;
243
244	: device-context? ( -- device-node? )
245	context-voc ['] root-node = if true exit then
246	current-voc >r also context-voc root-node ( voc )
247	['] context-voc? ['] (search-preorder) catch nip nip ( device-node?)
248	r> set-current previous ( device-node?)
249	;
250	\ rather than move a whole load of code around it is easier to patch
251	\ the device-end routine in devtree.fth
252	patch device-context? false device-end
253
254	: ?not-found ( flag -- ) if not-found throw then ;
255	: noalias-find-device ( str -- )
256	\ Throw if null string
257	?dup 0= ?not-found ( str$ )
258
259	\ The path starts at the root directory if the first character is "/";
260	\ otherwise it starts at the current directory
261	dup 1 >= if ( str$ )
262	over c@ ascii / = if 1 /string ['] root-node push-device then
263	then ( str$ )
264
265	current-device null = ?not-found
266	device-context? 0= ?not-found
267	(find-device)
268	;
269	: aliased-find-device ( str -- ) ?expand-alias noalias-find-device ;
270	headers
271	5 actions
272	action: count ;
273	action: 3drop ; \ No "store" method
274	action: ; \ Just return the address
275	action: drop ; \ Decode method is null because string is already right
276	action: drop ; \ Encode method is null too
277	: $devalias ( name-str expansion-str -- )
278	also aliases definitions
279	strip-blanks 2swap strip-blanks
280	\ Create the alias w/o not unique warning.
281	warning @ >r warning off $create r> warning !
282	previous definitions
283	",
284	use-actions
285	;
286	headerless
287	\ Do
288	: locate-device ( adr len -- true \| phandle false )
289	also
290	['] aliased-find-device catch if
291	2drop true
292	else
293	current-device false
294	then
295	previous definitions
296	;
297	: noa-find-device ( adr len -- )
298	current-device >r
299	['] noalias-find-device catch case
300	0 of r> drop endof
301	not-found of r> push-device not-found throw endof
302	( default ) r> push-device throw
303	endcase
304	;
305	headers
306	: find-device ( adr len -- ) ?expand-alias noa-find-device ;
307
308	: $parent-execute ( adr len -- )
309	current-device >r pop-device r@ >parent (package-execute) r> push-device
310	;
311
312	: delete-device ( phandle -- deleted? )
313	\ Save the current device
314	current-device >r
315
316	dup >parent push-device ( phandle )
317	'child begin ( phandle &phandle' )
318	2dup link@ = if ( phandle &phandle' )
319	true true ( phandle &phandle' true true )
320	else ( phandle &phandle' )
321	link@ dup null = if ( phandle null )
322	drop false true ( phandle false true )
323	else ( phandle phandle' )
324	push-device 'peer ( phandle &phandle" )
325	false ( phandle &phandle" done? )
326	then ( phandle &phandle" false )
327	then ( phandle &phandle' true true )
328	\ OR ( phandle false true )
329	\ OR ( phandle &phandle" false )
330	until if ( phandle &prev-phandle )
331	swap push-device 'peer ( &prev-phandle &next-phandle )
332	link@ swap link! true ( ok )
333	else ( phandle )
334	drop false ( failed )
335	then ( ok? )
336	\ Restore the current device
337	r> push-device ( ok? )
338	;
339
340	: $delete-device ( path$ -- deleted? )
341	locate-device if false exit then delete-device ( deleted? )
342	;
343	headers