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

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: instance.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: @(#)instance.fth 2.60 07/01/22
purpose: Create, destroy, and call package instances
copyright: Copyright 2007 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ Creation and destruction of device instances.  Also package interface words.

defer fm-hook  ( adr len phandle -- adr len phandle )
' noop is fm-hook
: find-method  ( adr len phandle -- false | acf true )
   fm-hook  (search-wordlist)
;

: "open"  " open"  ;
: $call-self  ( adr len -- )
   my-voc  setup-method$  fm-hook  $vexecute?  if  no-proc throw  then
;

[ifndef] package(
transient
: )package-macro ( -- )  r> is my-self ;
: package(-macro ( ihandle -- ) my-self >r is my-self ;
resident
macro: package( package(-macro
macro: )package )package-macro
[then]

: call-package  ( ??? acf ihandle -- ??? )      package( execute    )package  ;
: $call-method  ( ??? adr len ihandle -- ??? )  package( $call-self )package  ;
: $call-parent  ( adr len -- ) my-parent package( $call-self )package ;
: (skip-interposed) ( -- )
   begin interposed? while my-parent is my-self repeat
;

: ihandle>phandle  ( ihandle -- phandle )
   package(  (skip-interposed) my-voc )package
;

: $call-static-method  ( ??? adr len phandle -- ??? )
   setup-method$ find-method  0=  if  no-proc throw  then  execute
;

\ set-args is executed only during probing, at which time the active package
\ corresponds to the current instance, thus '#adr-cells can be executed
\ directly.

: set-args  ( arg-str reg-str -- )
   current-device >r pop-device (decode-unit) r> push-device
   '#adr-cells @  ( arg-str phys .. #cells )
   dup  if  swap  to my-space  1-   then       ( arg-str phys .. #cells' )
   addr my-adr0  swap /n* bounds  ?do  i !  /n +loop   ( arg-str )
   copy-args
;

: get-package-property  ( adr len phandle -- true | adr' len' false )
   also execute  get-property  previous
;

\ Used when executing from an open package instance.  Finds a property
\ associated with the current package.
: get-my-property  ( adr len -- true | adr' len' false )
   my-voc get-package-property
;

headerless
0 value interposer	\ phandle of interposing package, if any
0 value ip-arg-adr	\ arguments for interposing package
0 value ip-arg-len

\ Internal factor of get-inherited-property.  This factoring is necessary
\ because we use "exit" to make the control flow easier.
: (get-any)   ( adr len -- true | adr' len' false )
   begin  my-self   while            ( adr len )  \ Search up parent chain
      my-voc  current token!         ( adr len )
      2dup get-my-property  0=  if   ( adr len adr' len' )
         2swap 2drop false exit      ( adr' len' false )   \ Found
      then                           ( adr len )
      my-parent is my-self           ( adr len )
   repeat                            ( adr len )
   2drop true                        ( true )              \ Not found
;

headers
\ Finds a property associated with the current package or with one of
\ its parents.
: get-inherited-property  ( adr len -- true | adr' len' false )
   current token@ >r   my-self >r
   (get-any)
   r> is my-self  r> current token!
;

headerless
: try-close  ( -- )  " close"  ['] $call-self  catch  if  2drop  then  ;
headers
: close-package  ( ihandle -- )
   package( try-close destroy-instance )package
;
headerless
: close-parents  ( -- )
   begin  my-self  while  try-close destroy-instance  repeat
;
: close-chain  ( -- )  destroy-instance  close-parents  ;
headers
: close-dev  ( ihandle -- )  package(  close-parents  )package  ;

\ Extract the next (leftmost) component from the path name, updating the
\ path variable to reflect the remainder of the path after the extracted
\ component.
: parse-component  ( path$ -- path$ args$ devname$ )
   ascii / left-parse-string      ( path$' component$ )
   ascii : left-parse-string      ( path$ args$ devname$ )
   dup 0=  if  2drop  " /"  then  ( path$ args$ devname$' )
;

: apply-method  ( adr len -- no-such-method? )
   my-voc setup-method$
   fm-hook  ['] $vexecute?  catch  ?dup  if	( x x x errno )
      \ executing method caused an error
      nip nip nip				( errno )
   then						( ??? false | true | errno )
;

headerless

d# 64 buffer: package-name-buf

headers

: my-unit-bounds  ( -- end-adr start-adr )
   addr my-unit-low  '#adr-cells @ /n*  bounds
;
: set-my-unit  ( phys.hi .. phys.lo -- )
   my-unit-bounds  ?do  i !  /n +loop
;

: set-default-unit  ( -- )
   get-unit  0=  if  unit-str>phys- set-my-unit  then
;
\ Set the my-unit fields in the instance record:
\ If an address was given in path component, use it
\ If not, use address in "reg" property of package
\ Otherwise, use 0,0
: set-instance-address  ( -- )
   unit#-valid?  if
      unit-bounds  ?do  i @  /n +loop  set-my-unit
   else
      set-default-unit
   then
;

headerless
: (apply-method)  ( adr len -- ??? )
   apply-method  if  close-chain no-proc throw  then    ( )
;
: (open-node)  ( -- )
   "open"  (apply-method)  0=  if          ( okay? )
      close-chain  p" open failed" throw   ( )
   then
;

: encode-bytes+  ( adr1 len1  adr2 len2  --  adr1 len1+len2 )
   encode-bytes encode+
;

: encode-number+  ( u adr,len -- adr,len' )
   base @ >r hex
   rot  (u.)  encode-bytes+
   r> base !
;

: make-node-alias  ( nodeid name-str -- )
   current-device >r				( nodeid name-str )
   rot push-device				( name-str )
   pwd$						( name-str expansion-str )
   r> push-device				( name-str expansion-str )
   $devalias					(  )
;

: (append-args) ( arg$ base$ -- base$' )
   2 pick if					( arg$ base$ )
      " :" 2swap $add				( arg$ base$' )
   then						( arg$ base$ )
   $add						( base$ )
;

: (ihandle>path) ( no-interpose? str,len -- allow-interpose? str,len' )
   recursive
   2 pick if (skip-interposed) then			( flag str,len )
   my-parent  if					( flag str,len )
      my-parent	package( (ihandle>path)	)package	( flag str,len )
      my-voc push-device				( flag str,len )
      interposed? if " %"  else  " /"  then		( flag str,len' sep$ )
      2swap $add					( flag str,len' )
      (append-name)					( flag str,len' )
      support-node? @ if exit then			( flag str,len )
      2>r my-unit 2r> (append-unit)			( flag str,len' )
      my-args 2swap (append-args)			( flag str,len' )
   then							( flag str,len )
;

overload: (ihandle>path) ( ihandle flag -- str,len )
   current-device my-self 2>r			( ihandle flag )
   swap is my-self				( flag )
   "temp 0 (ihandle>path)			( flag str,len )
   2r> is my-self push-device rot drop		( str,len )
;

headers
\ ihandle>devname returns the device tree nodes for this ihandle
: ihandle>devname ( ihandle -- adr,len )	1 (ihandle>path) ;

\ ihandle>devpath returns the full instance path, including interposed packages
: ihandle>devpath ( ihandle -- adr,len )	0 (ihandle>path) ;

: phandle>devname ( phandle -- adr,len )
   current-device >r				( phandle )  ( r: phandle' )
   push-device  pwd$				( adr,len )  ( r: phandle' )
   r> push-device				( adr,len )
;

: open-node  ( -- ) recursive
   (open-node)
   interposer  if
      interposer  0 to interposer  push-package
      ip-arg-adr ip-arg-len new-instance true is interposed? open-node
      pop-package
   then
;

: interpose  ( args$ phandle -- )
   to interposer  to ip-arg-len  to ip-arg-adr
;

headerless

: (no-proc) ( -- )
   " Unimplemented procedure '" "temp pack >r		( )
   saved-method$ 2@ r@ $cat				( )
   saved-method-package @ dup if			( )
      " ' in " r@ $cat  phandle>devname			( str,len )
   else							( )
      drop " '"						( str,len )
   then r@ $cat						( )
   r> count						( str,len )
   set-abort-message -2					( -2 )
; 
\ Resolve the forward references to no-proc
' (no-proc) is no-proc

: open-parents  ( parent-phandle end-phandle -- )   recursive
   \ Exit at null "parent" of root node
   2dup =  if  2drop exit  then

   over >parent swap  open-parents  ( phandle )

   push-device                      (  )
   " "  new-instance                (  )
   set-default-unit                 (  )
   open-node                        (  )
;

\ Open packages between, but not including, "phandle" and the active package
: select-node  ( path$ -- path$' )
   current-device >r
   parse-component                          ( path$ args$ devname$ )
   noa-find-device                          ( path$ args$ )
   current-device dup  >parent  r> open-parents  ( path$ args$ my-phandle )
   push-device                              ( path$ args$ )
   new-instance                             ( path$ )
   set-instance-address                     ( path$ )
;

\ Open pathname components until the last one, and then apply the indicated
\ method to the last component.
: open-path  ( path$ -- )
   ?dup  if                                              ( path$ )
      \ Establish the initial parent
      null to current-device                             ( path$ )
      0 to interposer
      ?expand-alias  select-node                         ( path$ )
      begin  dup  while  open-node select-node  repeat   ( path$' )
      2drop                                              (  )
   else                                                  ( adr )
      not-found throw                                    (  )
   then                                                  (  )
;

headers
: open-package  ( args$ phandle -- ihandle )
   push-package                              ( args$ )
   new-instance                              ( )
   "open" apply-method  if  false  then  if  (  )
      my-self  my-parent is my-self          ( ihandle )
   else                                      (  )
      destroy-instance  0                    ( 0 )
   then                                      ( ihandle )
   pop-package                               ( ihandle )
;

: find-package  ( name$ -- false  |  phandle true )
   dup 0=  if  true  else  over c@  ascii / <>  then  ( name$ relative? )
   if                                                 ( name$ )
      " /packages/" package-name-buf pack  $cat       ( )
      package-name-buf count                          ( name$' )
   then                                               ( name$' )
   locate-device  0=                                  ( false | phandle true )
;

: $open-package  ( arg$ name$ -- ihandle )
   find-package  if  open-package  else  2drop 0  then
;

headers

: begin-open-dev  ( path$ -- ihandle )
   0 package(  current-device >r

      \ Since "catch/throw" saves and restores my-self,
      \ my-self will be 0 if a throw occurred.

      ['] open-path catch  if  2drop  then
      my-self                                   ( ihandle )

   r> push-device  )package                     ( ihandle )
;

headerless

: (open-dev)  ( path$ -- )  open-path  open-node  ;

headers

: open-dev  ( adr len -- ihandle | 0 )
   0 package(  current-device >r

      \ Since "catch/throw" saves and restores my-self,
      \ my-self will be 0 if a throw occurred.

      ['] (open-dev) catch  if  2drop  then
      my-self                                   ( ihandle )

   r> push-device  )package                     ( ihandle )
;

headerless

: (execute-method)  ( path$ method$ -- false | ??? true )
   2swap  open-path  (apply-method)
;

\ Same as (execute-method), but use (open-dev) instead of open-path
: (execute-method-opened)  ( path$ method$ -- false | ??? true )
   2swap  (open-dev)  (apply-method)
;

headers

: execute-device-method  ( path$ method$ -- false | ??? true )
   0 package(  current-device >r       ( path$ method$ )
      ['] (execute-method)  catch  if  ( x x x x )
         2drop 2drop  false            ( false )
      else                             ( ??? )
         close-chain  true             ( ??? true )
      then                             ( false | ??? true )
      device-end                       ( false | ??? true )
   r> push-device  )package            ( false | ??? true )
;

\ Same as execute-device-method, but open device before calling method
: execute-method-opened  ( path$ method$ -- false | ??? true )
   0 package(  current-device >r       ( path$ method$ )
      ['] (execute-method-opened)  catch  if  ( x x x x )
         2drop 2drop  false            ( false )
      else                             ( ??? )
         close-parents  true           ( ??? true )
      then                             ( false | ??? true )
      device-end                       ( false | ??? true )
   r> push-device  )package            ( false | ??? true )
;

\ Easier to use version of execute-device-method
\
\ ex:  apply  selftest  net
\
: apply ( -- ??? ) \ method { devpath | alias }
   safe-parse-word  safe-parse-word  ( method$ devpath$ )
   2swap  execute-device-method      ( ??? success? )
   0= abort" apply failed."          ( ??? )
;


h# 10 circular-stack: istack

\ select-dev opens a package, sets my-self to that ihandle, pushes the
\ old my-self on the instance stack, and pushes that package's vocabulary
\ on the search order.  unselect-dev undoes select-dev .

: iselect  ( ihandle -- )
   dup 0= abort" Can't open device"  ( ihandle )
   my-self istack push  is my-self
   also my-voc  push-device
;
: select-dev  ( adr,len -- )  open-dev  iselect  ;
: begin-select-dev  ( adr,len -- )   begin-open-dev  iselect  ;
: end-select-dev  ( -- )
   previous definitions
   my-parent  istack pop is my-self  close-dev
;

: select  ( "name" -- )  safe-parse-word select-dev  ;
: begin-select  ( "name" -- )  safe-parse-word begin-select-dev  ;

: unselect-dev  ( -- )
   previous definitions
   my-self  istack pop is my-self  close-dev
;

: begin-package  ( arg-str reg-str parent-str -- )
   select-dev  new-device  set-args
;

: end-package  ( -- )  finish-device  unselect-dev  ;

: (execute-phandle-method)  ( method-adr,len phandle -- ??? )
   0 to unit#-valid?              ( method-adr,len phandle )
   dup >parent null open-parents  ( method-adr,len phandle )
   push-device                    ( method-adr,len )
   " "  new-instance              ( method-adr,len )
   set-default-unit               ( method-adr,len )
   (apply-method)                 ( ???? )
;

headers
: open-phandle  ( phandle -- ihandle | 0 )
   0 package(                   ( phandle )
      current-device >r         ( phandle )
      0 to unit#-valid?         ( phandle )
      null ['] open-parents catch  if  ( x x error-code )
         3drop  0               ( 0 )
      else                      (   )
         my-self                ( ihandle )
      then                      ( ihandle | 0 )
      r> push-device            ( ihandle | 0 )
   )package                     ( ihandle | 0 )
;

: execute-phandle-method  ( method-adr,len phandle -- false | ??? true )
   0 package(                                  ( method-adr,len phandle )
      current-device >r                        ( method-adr,len phandle )
      ['] (execute-phandle-method)  catch  if  ( method-adr,len phandle err-code )
         3drop false                           ( false )
      else                                     ( ??? )
         close-chain true                      ( ??? true )
      then                                     ( false | ??? true )
      r> push-device                           ( false | ??? true )
   )package                                    ( false | ??? true )
;

: create-dev-instance (  arg$ phandle -- ihandle )
   my-self >r                            			( arg$ phandle ) 
   dup >parent open-phandle to my-self   			( )
   push-package new-instance set-instance-address pop-package	( )
   my-self r> to my-self                 			( ihandle ) 
;

: destroy-dev-instance ( ihandle -- )
   my-self >r to my-self		( )
   destroy-instance my-self close-dev	( )
   r> to my-self			( )
;

: .path  ( ihandle -- ) dup if ihandle>devname type cr else drop then ;

headerless
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: instance.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: @(#)instance.fth 2.60 07/01/22
	43	purpose: Create, destroy, and call package instances
	44	copyright: Copyright 2007 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ Creation and destruction of device instances. Also package interface words.
	48
	49	defer fm-hook ( adr len phandle -- adr len phandle )
	50	' noop is fm-hook
	51	: find-method ( adr len phandle -- false \| acf true )
	52	fm-hook (search-wordlist)
	53	;
	54
	55	: "open" " open" ;
	56	: $call-self ( adr len -- )
	57	my-voc setup-method$ fm-hook $vexecute? if no-proc throw then
	58	;
	59
	60	[ifndef] package(
	61	transient
	62	: )package-macro ( -- ) r> is my-self ;
	63	: package(-macro ( ihandle -- ) my-self >r is my-self ;
	64	resident
65	macro: package( package(-macro
66	macro: )package )package-macro
67	[then]
68
69	: call-package ( ??? acf ihandle -- ??? ) package( execute )package ;
70	: $call-method ( ??? adr len ihandle -- ??? ) package( $call-self )package ;
71	: $call-parent ( adr len -- ) my-parent package( $call-self )package ;
72	: (skip-interposed) ( -- )
73	begin interposed? while my-parent is my-self repeat
74	;
75
76	: ihandle>phandle ( ihandle -- phandle )
77	package( (skip-interposed) my-voc )package
78	;
79
80	: $call-static-method ( ??? adr len phandle -- ??? )
81	setup-method$ find-method 0= if no-proc throw then execute
82	;
83
84	\ set-args is executed only during probing, at which time the active package
85	\ corresponds to the current instance, thus '#adr-cells can be executed
86	\ directly.
87
88	: set-args ( arg-str reg-str -- )
89	current-device >r pop-device (decode-unit) r> push-device
90	'#adr-cells @ ( arg-str phys .. #cells )
91	dup if swap to my-space 1- then ( arg-str phys .. #cells' )
92	addr my-adr0 swap /n* bounds ?do i ! /n +loop ( arg-str )
93	copy-args
94	;
95
96	: get-package-property ( adr len phandle -- true \| adr' len' false )
97	also execute get-property previous
98	;
99
100	\ Used when executing from an open package instance. Finds a property
101	\ associated with the current package.
102	: get-my-property ( adr len -- true \| adr' len' false )
103	my-voc get-package-property
104	;
105
106	headerless
107	0 value interposer \ phandle of interposing package, if any
108	0 value ip-arg-adr \ arguments for interposing package
109	0 value ip-arg-len
110
111	\ Internal factor of get-inherited-property. This factoring is necessary
112	\ because we use "exit" to make the control flow easier.
113	: (get-any) ( adr len -- true \| adr' len' false )
114	begin my-self while ( adr len ) \ Search up parent chain
115	my-voc current token! ( adr len )
116	2dup get-my-property 0= if ( adr len adr' len' )
117	2swap 2drop false exit ( adr' len' false ) \ Found
118	then ( adr len )
119	my-parent is my-self ( adr len )
120	repeat ( adr len )
121	2drop true ( true ) \ Not found
122	;
123
124	headers
125	\ Finds a property associated with the current package or with one of
126	\ its parents.
127	: get-inherited-property ( adr len -- true \| adr' len' false )
128	current token@ >r my-self >r
129	(get-any)
130	r> is my-self r> current token!
131	;
132
133	headerless
134	: try-close ( -- ) " close" ['] $call-self catch if 2drop then ;
135	headers
136	: close-package ( ihandle -- )
137	package( try-close destroy-instance )package
138	;
139	headerless
140	: close-parents ( -- )
141	begin my-self while try-close destroy-instance repeat
142	;
143	: close-chain ( -- ) destroy-instance close-parents ;
144	headers
145	: close-dev ( ihandle -- ) package( close-parents )package ;
146
147	\ Extract the next (leftmost) component from the path name, updating the
148	\ path variable to reflect the remainder of the path after the extracted
149	\ component.
150	: parse-component ( path$ -- path$ args$ devname$ )
151	ascii / left-parse-string ( path$' component$ )
152	ascii : left-parse-string ( path$ args$ devname$ )
153	dup 0= if 2drop " /" then ( path$ args$ devname$' )
154	;
155
156	: apply-method ( adr len -- no-such-method? )
157	my-voc setup-method$
158	fm-hook ['] $vexecute? catch ?dup if ( x x x errno )
159	\ executing method caused an error
160	nip nip nip ( errno )
161	then ( ??? false \| true \| errno )
162	;
163
164	headerless
165
166	d# 64 buffer: package-name-buf
167
168	headers
169
170	: my-unit-bounds ( -- end-adr start-adr )
171	addr my-unit-low '#adr-cells @ /n* bounds
172	;
173	: set-my-unit ( phys.hi .. phys.lo -- )
174	my-unit-bounds ?do i ! /n +loop
175	;
176
177	: set-default-unit ( -- )
178	get-unit 0= if unit-str>phys- set-my-unit then
179	;
180	\ Set the my-unit fields in the instance record:
181	\ If an address was given in path component, use it
182	\ If not, use address in "reg" property of package
183	\ Otherwise, use 0,0
184	: set-instance-address ( -- )
185	unit#-valid? if
186	unit-bounds ?do i @ /n +loop set-my-unit
187	else
188	set-default-unit
189	then
190	;
191
192	headerless
193	: (apply-method) ( adr len -- ??? )
194	apply-method if close-chain no-proc throw then ( )
195	;
196	: (open-node) ( -- )
197	"open" (apply-method) 0= if ( okay? )
198	close-chain p" open failed" throw ( )
199	then
200	;
201
202	: encode-bytes+ ( adr1 len1 adr2 len2 -- adr1 len1+len2 )
203	encode-bytes encode+
204	;
205
206	: encode-number+ ( u adr,len -- adr,len' )
207	base @ >r hex
208	rot (u.) encode-bytes+
209	r> base !
210	;
211
212	: make-node-alias ( nodeid name-str -- )
213	current-device >r ( nodeid name-str )
214	rot push-device ( name-str )
215	pwd$ ( name-str expansion-str )
216	r> push-device ( name-str expansion-str )
217	$devalias ( )
218	;
219
220	: (append-args) ( arg$ base$ -- base$' )
221	2 pick if ( arg$ base$ )
222	" :" 2swap $add ( arg$ base$' )
223	then ( arg$ base$ )
224	$add ( base$ )
225	;
226
227	: (ihandle>path) ( no-interpose? str,len -- allow-interpose? str,len' )
228	recursive
229	2 pick if (skip-interposed) then ( flag str,len )
230	my-parent if ( flag str,len )
231	my-parent package( (ihandle>path) )package ( flag str,len )
232	my-voc push-device ( flag str,len )
233	interposed? if " %" else " /" then ( flag str,len' sep$ )
234	2swap $add ( flag str,len' )
235	(append-name) ( flag str,len' )
236	support-node? @ if exit then ( flag str,len )
237	2>r my-unit 2r> (append-unit) ( flag str,len' )
238	my-args 2swap (append-args) ( flag str,len' )
239	then ( flag str,len )
240	;
241
242	overload: (ihandle>path) ( ihandle flag -- str,len )
243	current-device my-self 2>r ( ihandle flag )
244	swap is my-self ( flag )
245	"temp 0 (ihandle>path) ( flag str,len )
246	2r> is my-self push-device rot drop ( str,len )
247	;
248
249	headers
250	\ ihandle>devname returns the device tree nodes for this ihandle
251	: ihandle>devname ( ihandle -- adr,len ) 1 (ihandle>path) ;
252
253	\ ihandle>devpath returns the full instance path, including interposed packages
254	: ihandle>devpath ( ihandle -- adr,len ) 0 (ihandle>path) ;
255
256	: phandle>devname ( phandle -- adr,len )
257	current-device >r ( phandle ) ( r: phandle' )
258	push-device pwd$ ( adr,len ) ( r: phandle' )
259	r> push-device ( adr,len )
260	;
261
262	: open-node ( -- ) recursive
263	(open-node)
264	interposer if
265	interposer 0 to interposer push-package
266	ip-arg-adr ip-arg-len new-instance true is interposed? open-node
267	pop-package
268	then
269	;
270
271	: interpose ( args$ phandle -- )
272	to interposer to ip-arg-len to ip-arg-adr
273	;
274
275	headerless
276
277	: (no-proc) ( -- )
278	" Unimplemented procedure '" "temp pack >r ( )
279	saved-method$ 2@ r@ $cat ( )
280	saved-method-package @ dup if ( )
281	" ' in " r@ $cat phandle>devname ( str,len )
282	else ( )
283	drop " '" ( str,len )
284	then r@ $cat ( )
285	r> count ( str,len )
286	set-abort-message -2 ( -2 )
287	;
288	\ Resolve the forward references to no-proc
289	' (no-proc) is no-proc
290
291	: open-parents ( parent-phandle end-phandle -- ) recursive
292	\ Exit at null "parent" of root node
293	2dup = if 2drop exit then
294
295	over >parent swap open-parents ( phandle )
296
297	push-device ( )
298	" " new-instance ( )
299	set-default-unit ( )
300	open-node ( )
301	;
302
303	\ Open packages between, but not including, "phandle" and the active package
304	: select-node ( path$ -- path$' )
305	current-device >r
306	parse-component ( path$ args$ devname$ )
307	noa-find-device ( path$ args$ )
308	current-device dup >parent r> open-parents ( path$ args$ my-phandle )
309	push-device ( path$ args$ )
310	new-instance ( path$ )
311	set-instance-address ( path$ )
312	;
313
314	\ Open pathname components until the last one, and then apply the indicated
315	\ method to the last component.
316	: open-path ( path$ -- )
317	?dup if ( path$ )
318	\ Establish the initial parent
319	null to current-device ( path$ )
320	0 to interposer
321	?expand-alias select-node ( path$ )
322	begin dup while open-node select-node repeat ( path$' )
323	2drop ( )
324	else ( adr )
325	not-found throw ( )
326	then ( )
327	;
328
329	headers
330	: open-package ( args$ phandle -- ihandle )
331	push-package ( args$ )
332	new-instance ( )
333	"open" apply-method if false then if ( )
334	my-self my-parent is my-self ( ihandle )
335	else ( )
336	destroy-instance 0 ( 0 )
337	then ( ihandle )
338	pop-package ( ihandle )
339	;
340
341	: find-package ( name$ -- false \| phandle true )
342	dup 0= if true else over c@ ascii / <> then ( name$ relative? )
343	if ( name$ )
344	" /packages/" package-name-buf pack $cat ( )
345	package-name-buf count ( name$' )
346	then ( name$' )
347	locate-device 0= ( false \| phandle true )
348	;
349
350	: $open-package ( arg$ name$ -- ihandle )
351	find-package if open-package else 2drop 0 then
352	;
353
354	headers
355
356	: begin-open-dev ( path$ -- ihandle )
357	0 package( current-device >r
358
359	\ Since "catch/throw" saves and restores my-self,
360	\ my-self will be 0 if a throw occurred.
361
362	['] open-path catch if 2drop then
363	my-self ( ihandle )
364
365	r> push-device )package ( ihandle )
366	;
367
368	headerless
369
370	: (open-dev) ( path$ -- ) open-path open-node ;
371
372	headers
373
374	: open-dev ( adr len -- ihandle \| 0 )
375	0 package( current-device >r
376
377	\ Since "catch/throw" saves and restores my-self,
378	\ my-self will be 0 if a throw occurred.
379
380	['] (open-dev) catch if 2drop then
381	my-self ( ihandle )
382
383	r> push-device )package ( ihandle )
384	;
385
386	headerless
387
388	: (execute-method) ( path$ method$ -- false \| ??? true )
389	2swap open-path (apply-method)
390	;
391
392	\ Same as (execute-method), but use (open-dev) instead of open-path
393	: (execute-method-opened) ( path$ method$ -- false \| ??? true )
394	2swap (open-dev) (apply-method)
395	;
396
397	headers
398
399	: execute-device-method ( path$ method$ -- false \| ??? true )
400	0 package( current-device >r ( path$ method$ )
401	['] (execute-method) catch if ( x x x x )
402	2drop 2drop false ( false )
403	else ( ??? )
404	close-chain true ( ??? true )
405	then ( false \| ??? true )
406	device-end ( false \| ??? true )
407	r> push-device )package ( false \| ??? true )
408	;
409
410	\ Same as execute-device-method, but open device before calling method
411	: execute-method-opened ( path$ method$ -- false \| ??? true )
412	0 package( current-device >r ( path$ method$ )
413	['] (execute-method-opened) catch if ( x x x x )
414	2drop 2drop false ( false )
415	else ( ??? )
416	close-parents true ( ??? true )
417	then ( false \| ??? true )
418	device-end ( false \| ??? true )
419	r> push-device )package ( false \| ??? true )
420	;
421
422	\ Easier to use version of execute-device-method
423	\
424	\ ex: apply selftest net
425	\
426	: apply ( -- ??? ) \ method { devpath \| alias }
427	safe-parse-word safe-parse-word ( method$ devpath$ )
428	2swap execute-device-method ( ??? success? )
429	0= abort" apply failed." ( ??? )
430	;
431
432
433	h# 10 circular-stack: istack
434
435	\ select-dev opens a package, sets my-self to that ihandle, pushes the
436	\ old my-self on the instance stack, and pushes that package's vocabulary
437	\ on the search order. unselect-dev undoes select-dev .
438
439	: iselect ( ihandle -- )
440	dup 0= abort" Can't open device" ( ihandle )
441	my-self istack push is my-self
442	also my-voc push-device
443	;
444	: select-dev ( adr,len -- ) open-dev iselect ;
445	: begin-select-dev ( adr,len -- ) begin-open-dev iselect ;
446	: end-select-dev ( -- )
447	previous definitions
448	my-parent istack pop is my-self close-dev
449	;
450
451	: select ( "name" -- ) safe-parse-word select-dev ;
452	: begin-select ( "name" -- ) safe-parse-word begin-select-dev ;
453
454	: unselect-dev ( -- )
455	previous definitions
456	my-self istack pop is my-self close-dev
457	;
458
459	: begin-package ( arg-str reg-str parent-str -- )
460	select-dev new-device set-args
461	;
462
463	: end-package ( -- ) finish-device unselect-dev ;
464
465	: (execute-phandle-method) ( method-adr,len phandle -- ??? )
466	0 to unit#-valid? ( method-adr,len phandle )
467	dup >parent null open-parents ( method-adr,len phandle )
468	push-device ( method-adr,len )
469	" " new-instance ( method-adr,len )
470	set-default-unit ( method-adr,len )
471	(apply-method) ( ???? )
472	;
473
474	headers
475	: open-phandle ( phandle -- ihandle \| 0 )
476	0 package( ( phandle )
477	current-device >r ( phandle )
478	0 to unit#-valid? ( phandle )
479	null ['] open-parents catch if ( x x error-code )
480	3drop 0 ( 0 )
481	else ( )
482	my-self ( ihandle )
483	then ( ihandle \| 0 )
484	r> push-device ( ihandle \| 0 )
485	)package ( ihandle \| 0 )
486	;
487
488	: execute-phandle-method ( method-adr,len phandle -- false \| ??? true )
489	0 package( ( method-adr,len phandle )
490	current-device >r ( method-adr,len phandle )
491	['] (execute-phandle-method) catch if ( method-adr,len phandle err-code )
492	3drop false ( false )
493	else ( ??? )
494	close-chain true ( ??? true )
495	then ( false \| ??? true )
496	r> push-device ( false \| ??? true )
497	)package ( false \| ??? true )
498	;
499
500	: create-dev-instance ( arg$ phandle -- ihandle )
501	my-self >r ( arg$ phandle )
502	dup >parent open-phandle to my-self ( )
503	push-package new-instance set-instance-address pop-package ( )
504	my-self r> to my-self ( ihandle )
505	;
506
507	: destroy-dev-instance ( ihandle -- )
508	my-self >r to my-self ( )
509	destroy-instance my-self close-dev ( )
510	r> to my-self ( )
511	;
512
513	: .path ( ihandle -- ) dup if ihandle>devname type cr else drop then ;
514
515	headerless