← Back to branch summary

~pmdj/ubuntu/trusty/qemu/2.9+applesmc+fadtv3

« back to all changes in this revision

Viewing changes to roms/SLOF/slof/fs/node.fs

  • Committer: Phil Dennis-Jordan
  • Date: 2017-07-21 08:03:43 UTC
  • mfrom: (1.1.1)
  • Revision ID: phil@philjordan.eu-20170721080343-2yr2vdj7713czahv
New upstream release 2.9.0.

Show diffs side-by-side

added added

removed removed

Lines of Context:
roms/SLOF/slof/fs/node.fs
 
1
\ *****************************************************************************
 
2
\ * Copyright (c) 2004, 2008 IBM Corporation
 
3
\ * All rights reserved.
 
4
\ * This program and the accompanying materials
 
5
\ * are made available under the terms of the BSD License
 
6
\ * which accompanies this distribution, and is available at
 
7
\ * http://www.opensource.org/licenses/bsd-license.php
 
8
\ *
 
9
\ * Contributors:
 
10
\ *     IBM Corporation - initial implementation
 
11
\ ****************************************************************************/
 
12
 
 
13
 
 
14
\ Device nodes.
 
15
 
 
16
false VALUE debug-find-component?
 
17
 
 
18
VARIABLE device-tree
 
19
VARIABLE current-node
 
20
: get-node  current-node @ dup 0= ABORT" No active device tree node" ;
 
21
 
 
22
STRUCT
 
23
  cell FIELD node>peer
 
24
  cell FIELD node>parent
 
25
  cell FIELD node>child
 
26
  cell FIELD node>properties
 
27
  cell FIELD node>words
 
28
  cell FIELD node>instance-template
 
29
  cell FIELD node>instance-size
 
30
  cell FIELD node>space?
 
31
  cell FIELD node>space
 
32
  cell FIELD node>addr1
 
33
  cell FIELD node>addr2
 
34
  cell FIELD node>addr3
 
35
END-STRUCT
 
36
 
 
37
: find-method ( str len phandle -- false | xt true )
 
38
  node>words @ voc-find dup IF link> true THEN ;
 
39
 
 
40
\ Instances.
 
41
#include "instance.fs"
 
42
 
 
43
: create-node ( parent -- new )
 
44
   max-instance-size alloc-mem        ( parent instance-mem )
 
45
   dup max-instance-size erase >r     ( parent  R: instance-mem )
 
46
   align wordlist >r wordlist >r      ( parent  R: instance-mem wl wl )
 
47
   here                               ( parent new  R: instance-mem wl wl )
 
48
   0 , swap , 0 ,                     \ Set node>peer, node>parent & node>child
 
49
   r> , r> ,                          \ Set node>properties & node>words to wl
 
50
   r> , /instance-header ,            \ Set instance-template & instance-size
 
51
   FALSE , 0 ,                        \ Set node>space? and node>space
 
52
   0 , 0 , 0 ,                        \ Set node>addr*
 
53
;
 
54
 
 
55
: peer    node>peer   @ ;
 
56
: parent  node>parent @ ;
 
57
: child   node>child  @ ;
 
58
: peer  dup IF peer ELSE drop device-tree @ THEN ;
 
59
 
 
60
 
 
61
: link ( new head -- ) \ link a new node at the end of a linked list
 
62
  BEGIN dup @ WHILE @ REPEAT ! ;
 
63
: link-node ( parent child -- )
 
64
  swap dup IF node>child link ELSE drop device-tree ! THEN ;
 
65
 
 
66
\ Set a node as active node.
 
67
: set-node ( phandle -- )
 
68
  current-node @ IF previous THEN
 
69
  dup current-node !
 
70
  ?dup IF node>words @ also context ! THEN
 
71
  definitions ;
 
72
: get-parent  get-node parent ;
 
73
 
 
74
 
 
75
: new-node ( -- phandle ) \ active node becomes new node's parent;
 
76
                          \ new node becomes active node
 
77
\ XXX: change to get-node, handle root node creation specially
 
78
  current-node @ dup create-node
 
79
  tuck link-node dup set-node ;
 
80
 
 
81
: finish-node ( -- )
 
82
   \ TODO: maybe resize the instance template buffer here (or in finish-device)?
 
83
   get-node parent set-node
 
84
;
 
85
 
 
86
: device-end ( -- )  0 set-node ;
 
87
 
 
88
\ Properties.
 
89
CREATE $indent 100 allot  VARIABLE indent 0 indent !
 
90
#include "property.fs"
 
91
 
 
92
\ Unit address.
 
93
: #address-cells  s" #address-cells" rot parent get-property
 
94
   ABORT" parent doesn't have a #address-cells property!"
 
95
   decode-int nip nip
 
96
;
 
97
 
 
98
\ my-#address-cells returns the #address-cells property of the parent node.
 
99
\ child-#address-cells returns the #address-cells property of the current node.
 
100
 
 
101
\ This is confusing in several ways: Remember that a node's address is always
 
102
\ described in the parent's address space, thus the parent's property is taken
 
103
\ into regard, rather than the own.
 
104
 
 
105
\ Also, an address-cell here is always a 32bit cell, no matter whether the
 
106
\ "real" cell size is 32bit or 64bit.
 
107
 
 
108
: my-#address-cells  ( -- #address-cells )
 
109
   get-node #address-cells
 
110
;
 
111
 
 
112
: child-#address-cells  ( -- #address-cells )
 
113
   s" #address-cells" get-node get-property
 
114
   ABORT" node doesn't have a #address-cells property!"
 
115
   decode-int nip nip
 
116
;
 
117
 
 
118
: child-#size-cells  ( -- #address-cells )
 
119
   s" #size-cells" get-node get-property
 
120
   ABORT" node doesn't have a #size-cells property!"
 
121
   decode-int nip nip
 
122
;
 
123
 
 
124
: encode-phys  ( phys.hi ... phys.low -- prop len )
 
125
   encode-first?  IF  encode-start  ELSE  here 0  THEN
 
126
   my-#address-cells 0 ?DO rot encode-int+ LOOP
 
127
;
 
128
 
 
129
: encode-child-phys  ( phys.hi ... phys.low -- prop len )
 
130
   encode-first?  IF  encode-start  ELSE  here 0  THEN
 
131
   child-#address-cells 0 ?DO rot encode-int+ LOOP
 
132
;
 
133
 
 
134
: encode-child-size  ( size.hi ... size.low -- prop len )
 
135
   encode-first? IF  encode-start  ELSE  here 0  THEN
 
136
   child-#size-cells 0 ?DO rot encode-int+ LOOP
 
137
;
 
138
 
 
139
: decode-phys
 
140
  my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop
 
141
  my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
 
142
: decode-phys-and-drop
 
143
  my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop
 
144
  my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
 
145
: reg  >r encode-phys r> encode-int+ s" reg" property ;
 
146
 
 
147
 
 
148
: >space    node>space @ ;
 
149
: >space?   node>space? @ ;
 
150
: >address  dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN
 
151
                                  dup 2 > IF r@ node>addr2 @ swap THEN
 
152
                                      1 > IF r@ node>addr1 @ THEN r> drop ;
 
153
: >unit     dup >r >address r> >space ;
 
154
 
 
155
: (my-phandle)  ( -- phandle )
 
156
   my-self ?dup IF
 
157
      ihandle>phandle
 
158
   ELSE
 
159
      get-node dup 0= ABORT" no active node"
 
160
   THEN
 
161
;
 
162
 
 
163
: my-space ( -- phys.hi )
 
164
   (my-phandle) >space
 
165
;
 
166
: my-address  (my-phandle) >address ;
 
167
 
 
168
\ my-unit returns the unit address of the current _instance_ - that means
 
169
\ it returns the same values as my-space and my-address together _or_ it
 
170
\ returns a unit address that has been set manually while opening the node.
 
171
: my-unit
 
172
   my-self instance>#units @ IF
 
173
      0 my-self instance>#units @ 1- DO
 
174
         my-self instance>unit1 i cells + @
 
175
      -1 +LOOP
 
176
   ELSE
 
177
      my-self ihandle>phandle >unit
 
178
   THEN
 
179
;
 
180
 
 
181
\ Return lower 64 bit of address
 
182
: my-unit-64 ( -- phys.lo+1|phys.lo )
 
183
   my-unit                                ( phys.lo ... phys.hi )
 
184
   (my-phandle) #address-cells            ( phys.lo ... phys.hi #ad-cells )
 
185
   CASE
 
186
      1   OF EXIT ENDOF
 
187
      2   OF lxjoin EXIT ENDOF
 
188
      3   OF drop lxjoin EXIT ENDOF
 
189
      dup OF 2drop lxjoin EXIT ENDOF
 
190
   ENDCASE
 
191
;
 
192
 
 
193
: set-space    get-node dup >r node>space ! true r> node>space? ! ;
 
194
: set-address  my-#address-cells 1 ?DO
 
195
               get-node node>space i cells + ! LOOP ;
 
196
: set-unit     set-space set-address ;
 
197
: set-unit-64 ( phys.lo|phys.hi -- )
 
198
   my-#address-cells 2 <> IF
 
199
      ." set-unit-64: #address-cells <> 2 " abort
 
200
   THEN
 
201
   xlsplit set-unit
 
202
;
 
203
 
 
204
\ Never ever use this in actual code, only when debugging interactively.
 
205
\ Thank you.
 
206
: set-args ( arg-str len unit-str len -- )
 
207
   s" decode-unit" get-parent $call-static set-unit set-my-args
 
208
;
 
209
 
 
210
: $cat-unit
 
211
   dup parent 0= IF drop EXIT THEN
 
212
   dup >space? not IF drop EXIT THEN
 
213
   dup >r >unit s" encode-unit" r> parent $call-static
 
214
   dup IF
 
215
      dup >r here swap move s" @" $cat here r> $cat
 
216
   ELSE
 
217
      2drop
 
218
   THEN
 
219
;
 
220
 
 
221
: $cat-instance-unit
 
222
   dup parent 0= IF drop EXIT THEN
 
223
   \ No instance unit, use node unit
 
224
   dup instance>#units @ 0= IF
 
225
      ihandle>phandle $cat-unit
 
226
      EXIT
 
227
   THEN
 
228
   dup >r push-my-self
 
229
   ['] my-unit CATCH IF pop-my-self r> drop EXIT THEN
 
230
   pop-my-self
 
231
   s" encode-unit"
 
232
   r> ihandle>phandle parent
 
233
   $call-static
 
234
   dup IF
 
235
      dup >r here swap move s" @" $cat here r> $cat
 
236
   ELSE
 
237
      2drop
 
238
   THEN
 
239
;
 
240
 
 
241
\ Getting basic info about a node.
 
242
: node>name  dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ;
 
243
: node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ;
 
244
: node>path
 
245
   here 0 rot
 
246
   BEGIN dup WHILE dup parent REPEAT
 
247
   2drop
 
248
   dup 0= IF [char] / c, THEN
 
249
   BEGIN
 
250
      dup
 
251
   WHILE
 
252
      [char] / c, node>qname here over allot swap move
 
253
   REPEAT
 
254
   drop here 2dup - allot over -
 
255
;
 
256
 
 
257
: interposed? ( ihandle -- flag )
 
258
  \ We cannot actually detect if an instance is interposed; instead, we look
 
259
  \ if an instance is part of the "normal" chain that would be opened by
 
260
  \ open-dev and friends, if there were no interposition.
 
261
  dup instance>parent @ dup 0= IF 2drop false EXIT THEN
 
262
  ihandle>phandle swap ihandle>phandle parent <> ;
 
263
 
 
264
: instance>qname
 
265
  dup >r interposed? IF s" %" ELSE 0 0 THEN
 
266
  r@ dup ihandle>phandle node>name
 
267
  rot ['] $cat-instance-unit CATCH IF drop THEN
 
268
  $cat r> instance>args 2@ swap
 
269
  dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN
 
270
;
 
271
 
 
272
: instance>qpath \ With interposed nodes.
 
273
  here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop
 
274
  dup 0= IF [char] / c, THEN
 
275
  BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
 
276
  REPEAT drop here 2dup - allot over - ;
 
277
: instance>path \ Without interposed nodes.
 
278
  here 0 rot BEGIN dup WHILE
 
279
  dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop
 
280
  dup 0= IF [char] / c, THEN
 
281
  BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
 
282
  REPEAT drop here 2dup - allot over - ;
 
283
 
 
284
: .node  node>path type ;
 
285
: pwd  get-node .node ;
 
286
 
 
287
: .instance instance>qpath type ;
 
288
: .chain    dup instance>parent @ ?dup IF recurse THEN
 
289
            cr dup . instance>qname type ;
 
290
 
 
291
 
 
292
\ Alias helper
 
293
defer find-node
 
294
: set-alias ( alias-name len device-name len -- )
 
295
    encode-string
 
296
    2swap s" /aliases" find-node ?dup IF
 
297
       set-property
 
298
    ELSE
 
299
       4drop
 
300
    THEN
 
301
;
 
302
 
 
303
: find-alias ( alias-name len -- false | dev-path len )
 
304
   s" /aliases" find-node dup IF
 
305
      get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN
 
306
   THEN
 
307
;
 
308
 
 
309
: .alias ( alias-name len -- )
 
310
    find-alias dup IF type ELSE ." no alias available" THEN ;
 
311
 
 
312
: (.print-alias) ( lfa -- )
 
313
    link> dup >name name>string
 
314
    \ Don't print name property
 
315
    2dup s" name" string=ci IF 2drop drop
 
316
    ELSE cr type space ." : " execute type
 
317
    THEN ;
 
318
 
 
319
: (.list-alias) ( phandle -- )
 
320
    node>properties @ cell+ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ;
 
321
 
 
322
: list-alias ( -- )
 
323
    s" /aliases" find-node dup IF (.list-alias) THEN ;
 
324
 
 
325
\ return next available name for aliasing or
 
326
\ false if more than MAX-ALIAS aliases found
 
327
8 CONSTANT MAX-ALIAS
 
328
1 VALUE alias-ind
 
329
: get-next-alias ( $alias-name -- $next-alias-name|FALSE )
 
330
    2dup find-alias IF
 
331
        drop
 
332
        1 TO alias-ind
 
333
        BEGIN
 
334
            2dup alias-ind $cathex 2dup find-alias
 
335
        WHILE
 
336
            drop 2drop
 
337
            alias-ind 1 + TO alias-ind
 
338
            alias-ind MAX-ALIAS = IF
 
339
                2drop FALSE EXIT
 
340
            THEN
 
341
        REPEAT
 
342
        strdup 2swap 2drop
 
343
    THEN
 
344
;
 
345
 
 
346
: devalias ( "{alias-name}<>{device-specifier}<cr>" -- )
 
347
    parse-word parse-word dup IF set-alias
 
348
    ELSE 2drop dup IF .alias
 
349
    ELSE 2drop list-alias THEN THEN ;
 
350
 
 
351
\ sub-alias does a single iteration of an alias at the beginning od dev path
 
352
\ expression. de-alias will repeat this until all indirect alising is resolved
 
353
: sub-alias ( arg-str arg-len -- arg' len' | false )
 
354
   2dup
 
355
   2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN
 
356
   ( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r
 
357
   ( a l l p -- R:p | a l -- R:0 )
 
358
   find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 )
 
359
      r@ IF
 
360
         2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- )
 
361
      ELSE
 
362
         ( a' l' -- R:0 ) r> drop ( a' l' -- )
 
363
      THEN
 
364
   ELSE
 
365
      ( a l -- R:p | -- R:0 ) r> IF 2drop THEN
 
366
      false ( 0 -- )
 
367
   THEN
 
368
;
 
369
 
 
370
: de-alias ( arg-str arg-len -- arg' len' )
 
371
   BEGIN
 
372
      over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN
 
373
   WHILE
 
374
      2swap 2drop
 
375
   REPEAT
 
376
;
 
377
 
 
378
 
 
379
\ Display the device tree.
 
380
: +indent ( not-last? -- )
 
381
  IF s" |   " ELSE s"     " THEN $indent indent @ + swap move 4 indent +! ;
 
382
: -indent ( -- )  -4 indent +! ;
 
383
 
 
384
: ls-phandle ( node -- )  . ." :  " ;
 
385
 
 
386
: ls-node ( node -- )
 
387
   cr dup ls-phandle
 
388
   $indent indent @ type
 
389
   dup peer IF ." |-- " ELSE ." +-- " THEN
 
390
   node>qname type
 
391
;
 
392
 
 
393
: (ls) ( node -- )
 
394
  child BEGIN dup WHILE dup ls-node dup child IF
 
395
  dup peer +indent dup recurse -indent THEN peer REPEAT drop ;
 
396
 
 
397
: ls ( -- )
 
398
   get-node cr
 
399
   dup ls-phandle
 
400
   dup node>path type
 
401
   (ls)
 
402
   0 indent !
 
403
;
 
404
 
 
405
: show-devs ( {device-specifier}<eol> -- )
 
406
   skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN   ( str len )
 
407
   find-node dup 0= ABORT" No such device path" (ls)
 
408
;
 
409
 
 
410
 
 
411
VARIABLE interpose-node
 
412
2VARIABLE interpose-args
 
413
: interpose ( arg len phandle -- )  interpose-node ! interpose-args 2! ;
 
414
 
 
415
 
 
416
0 VALUE user-instance-#units
 
417
CREATE user-instance-units 4 cells allot
 
418
 
 
419
\ Copy the unit information (specified by the user) that we've found during
 
420
\ "find-component" into the current instance data structure
 
421
: copy-instance-unit  ( -- )
 
422
   user-instance-#units IF
 
423
      user-instance-#units my-self instance>#units !
 
424
      user-instance-units my-self instance>unit1 user-instance-#units cells move
 
425
      0 to user-instance-#units
 
426
   THEN
 
427
;
 
428
 
 
429
 
 
430
: open-node ( arg len phandle -- ihandle|0 )
 
431
   current-node @ >r  my-self >r            \ Save current node and instance
 
432
   set-node create-instance set-my-args
 
433
   copy-instance-unit
 
434
   \ Execute "open" method if available, and assume default of
 
435
   \ success (=TRUE) for nodes without open method:
 
436
   s" open" get-node find-method IF execute ELSE TRUE THEN
 
437
   0= IF
 
438
      my-self destroy-instance 0 to my-self
 
439
   THEN
 
440
   my-self                                  ( ihandle|0 )
 
441
   r> to my-self  r> set-node               \ Restore current node and instance
 
442
   \ Handle interposition:
 
443
   interpose-node @ IF
 
444
      my-self >r to my-self
 
445
      interpose-args 2@ interpose-node @
 
446
      interpose-node off recurse
 
447
      r> to my-self
 
448
   THEN
 
449
;
 
450
 
 
451
: close-node ( ihandle -- )
 
452
  my-self >r to my-self
 
453
  s" close" ['] $call-my-method CATCH IF 2drop THEN
 
454
  my-self destroy-instance r> to my-self ;
 
455
 
 
456
: close-dev ( ihandle -- )
 
457
  my-self >r to my-self
 
458
  BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT
 
459
  r> to my-self ;
 
460
 
 
461
: new-device ( -- )
 
462
   my-self new-node                     ( parent-ihandle phandle )
 
463
   node>instance-template @             ( parent-ihandle ihandle )
 
464
   dup to my-self                       ( parent-ihanlde ihandle )
 
465
   instance>parent !
 
466
   get-node my-self instance>node !
 
467
   max-instance-size my-self instance>size !
 
468
;
 
469
 
 
470
: finish-device ( -- )
 
471
   \ Set unit address to first entry of reg property if it has not been set yet
 
472
   get-node >space? 0= IF
 
473
      s" reg" get-node get-property 0= IF
 
474
         decode-int set-space 2drop
 
475
      THEN
 
476
   THEN
 
477
   finish-node my-parent to my-self
 
478
;
 
479
 
 
480
\ Set the instance template as current instance for extending it
 
481
\ (i.e. to be able to declare new INSTANCE VARIABLEs etc. there)
 
482
: extend-device  ( phandle -- )
 
483
   my-self >r
 
484
   dup set-node
 
485
   node>instance-template @
 
486
   dup to my-self
 
487
   r> swap instance>parent !
 
488
;
 
489
 
 
490
: split ( str len char -- left len right len )
 
491
  >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
 
492
: generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
 
493
  dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
 
494
  $number IF 0 THEN r> swap >r >r REPEAT r> 3drop
 
495
  BEGIN dup WHILE 1- r> swap REPEAT drop ;
 
496
: generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
 
497
  0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
 
498
: hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
 
499
  base @ >r hex generic-decode-unit r> base ! ;
 
500
: hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
 
501
  base @ >r hex generic-encode-unit r> base ! ;
 
502
 
 
503
: hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi )
 
504
  dup 2 <> IF
 
505
     hex-decode-unit
 
506
  ELSE
 
507
     drop
 
508
     base @ >r hex
 
509
     $number IF 0 0 ELSE xlsplit THEN
 
510
     r> base !
 
511
  THEN
 
512
;
 
513
 
 
514
: hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len )
 
515
  dup 2 <> IF
 
516
     hex-encode-unit
 
517
  ELSE
 
518
     drop
 
519
     base @ >r hex
 
520
     lxjoin (u.)
 
521
     r> base !
 
522
  THEN
 
523
;
 
524
 
 
525
: handle-leading-/ ( path len -- path' len' )
 
526
  dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ;
 
527
: match-name ( name len node -- match? )
 
528
  over 0= IF 3drop true EXIT THEN
 
529
  s" name" rot get-property IF 2drop false EXIT THEN
 
530
  1- string=ci ; \ XXX should use decode-string
 
531
 
 
532
0 VALUE #search-unit
 
533
CREATE search-unit 4 cells allot
 
534
 
 
535
: match-unit ( node -- match? )
 
536
  \ A node with no space is a wildcard and will always match
 
537
  dup >space? IF
 
538
      node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF
 
539
      2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true
 
540
  ELSE drop true THEN
 
541
;
 
542
: match-node ( name len node -- match? )
 
543
  dup >r match-name r> match-unit and ; \ XXX e3d
 
544
: find-kid ( name len -- node|0 )
 
545
  dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives
 
546
    2drop get-node
 
547
  ELSE
 
548
    get-node child >r BEGIN r@ WHILE 2dup r@ match-node
 
549
    IF 2drop r> EXIT THEN r> peer >r REPEAT
 
550
    r> 3drop false
 
551
  THEN ;
 
552
 
 
553
: set-search-unit ( unit len -- )
 
554
   0 to #search-unit
 
555
   0 to user-instance-#units
 
556
   dup 0= IF 2drop EXIT THEN
 
557
   s" #address-cells" get-node get-property THROW
 
558
   decode-int to #search-unit 2drop
 
559
   s" decode-unit" get-node $call-static
 
560
   #search-unit 0 ?DO search-unit i cells + ! LOOP
 
561
;
 
562
 
 
563
: resolve-relatives ( path len -- path' len' )
 
564
  \ handle ..
 
565
  2dup 2 = swap s" .." comp 0= and IF
 
566
    get-node parent ?dup IF
 
567
      set-node drop -1
 
568
    ELSE
 
569
      s" Already in root node." type
 
570
    THEN
 
571
  THEN
 
572
  \ handle .
 
573
  2dup 1 = swap c@ [CHAR] . = and IF
 
574
    drop -1
 
575
  THEN
 
576
;
 
577
 
 
578
\ XXX This is an old hack that allows wildcard nodes to work
 
579
\     by not having a #address-cells in the parent and no
 
580
\     decode unit. This should be removed.
 
581
\     (It appears to be still used on js2x)
 
582
: set-instance-unit  ( unitaddr len -- )
 
583
   dup 0= IF 2drop  0 to user-instance-#units  EXIT THEN
 
584
   2dup 0 -rot bounds ?DO
 
585
      i c@ [char] , = IF 1+ THEN      \ Count the commas
 
586
   LOOP
 
587
   1+ dup to user-instance-#units
 
588
   hex-decode-unit
 
589
   user-instance-#units 0 ?DO
 
590
      user-instance-units i cells + !
 
591
   LOOP
 
592
;
 
593
 
 
594
: split-component  ( path. -- path'. args. name. unit. )
 
595
   [char] / split 2swap     ( path'. component. )
 
596
   [char] : split 2swap     ( path'. args. name@unit. )
 
597
   [char] @ split           ( path'. args. name. unit. )
 
598
;
 
599
 
 
600
: find-component  ( path len -- path' len' args len node|0 )
 
601
   debug-find-component? IF
 
602
      ." find-component for " 2dup type cr
 
603
   THEN
 
604
   split-component           ( path'. args. name. unit. )
 
605
   debug-find-component? IF
 
606
      ." -> unit  =" 2dup type cr
 
607
      ." -> stack =" .s cr
 
608
   THEN
 
609
   ['] set-search-unit CATCH IF
 
610
      \ XXX: See comment in set-instance-unit
 
611
      ." WARNING: Obsolete old wildcard hack " .s cr
 
612
      set-instance-unit
 
613
   THEN
 
614
   resolve-relatives find-kid        ( path' len' args len node|0 )
 
615
 
 
616
   \ If resolve returned a wildcard node, and we haven't hit
 
617
   \ the above gross hack then copy the unit
 
618
   dup IF dup >space? not #search-unit 0 > AND user-instance-#units 0= AND IF
 
619
     #search-unit dup to user-instance-#units 0 ?DO
 
620
        search-unit i cells + @ user-instance-units i cells + !
 
621
     LOOP
 
622
   THEN THEN
 
623
 
 
624
   \ XXX This can go away with the old wildcard hack
 
625
   dup IF dup >space? user-instance-#units 0 > AND IF
 
626
      \ User supplied a unit value, but node also has different physical unit
 
627
      cr ." find-component with unit mismatch!" .s cr
 
628
      drop 0
 
629
   THEN THEN
 
630
;
 
631
 
 
632
: .find-node ( path len -- phandle|0 )
 
633
  current-node @ >r
 
634
  handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
 
635
  BEGIN dup WHILE \ handle one component:
 
636
  find-component ( path len args len node ) dup 0= IF
 
637
  3drop 2drop r> set-node 0 EXIT THEN
 
638
  set-node 2drop REPEAT 2drop
 
639
  get-node r> set-node ;
 
640
' .find-node to find-node
 
641
: find-node ( path len -- phandle|0 ) de-alias find-node ;
 
642
 
 
643
: delete-node ( phandle -- )
 
644
   dup node>instance-template @ max-instance-size free-mem
 
645
   dup node>parent @ node>child @ ( phandle 1st peer )
 
646
   2dup = IF
 
647
     node>peer @ swap node>parent @ node>child !
 
648
     EXIT
 
649
   THEN
 
650
   dup node>peer @
 
651
   BEGIN
 
652
      2 pick 2dup <>
 
653
   WHILE
 
654
      drop
 
655
      nip dup node>peer @
 
656
      dup 0= IF 2drop drop unloop EXIT THEN
 
657
   REPEAT
 
658
   drop
 
659
   node>peer @  swap node>peer !
 
660
   drop
 
661
;
 
662
 
 
663
: open-dev ( path len -- ihandle|0 )
 
664
   0 to user-instance-#units
 
665
   de-alias current-node @ >r
 
666
   handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
 
667
   my-self >r
 
668
   0 to my-self
 
669
   0 0 >r >r
 
670
   BEGIN
 
671
      dup
 
672
   WHILE \ handle one component:
 
673
     ( arg len ) r> r> get-node open-node to my-self
 
674
     find-component ( path len args len node ) dup 0= IF
 
675
        3drop 2drop my-self close-dev
 
676
        r> to my-self
 
677
        r> set-node
 
678
        0 EXIT
 
679
     THEN
 
680
     set-node
 
681
     >r >r
 
682
  REPEAT
 
683
  2drop
 
684
  \ open final node
 
685
  r> r> get-node open-node to my-self
 
686
  my-self r> to my-self r> set-node
 
687
;
 
688
 
 
689
: select-dev  open-dev dup to my-self ihandle>phandle set-node ;
 
690
: unselect-dev  my-self close-dev  0 to my-self  device-end ;
 
691
 
 
692
: find-device ( str len -- ) \ set as active node
 
693
  find-node dup 0= ABORT" No such device path" set-node ;
 
694
: dev  parse-word find-device ;
 
695
 
 
696
: (lsprop) ( node --)
 
697
   dup cr $indent indent @ type ."     node: " node>qname type
 
698
   false +indent (.properties) cr -indent
 
699
;
 
700
: (show-children) ( node -- )
 
701
   child BEGIN
 
702
      dup
 
703
   WHILE
 
704
      dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer
 
705
   REPEAT
 
706
   drop
 
707
;
 
708
: lsprop ( {device-specifier}<eol> -- )
 
709
   skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN
 
710
   find-device get-node dup dup
 
711
   cr ." node: " node>path type (.properties) cr (show-children)
 
712
   0 indent !
 
713
;
 
714
 
 
715
 
 
716
\ node>path does not allot the memory, since it is internally only used
 
717
\ for typing.
 
718
\ The external variant needs to allot memory !
 
719
 
 
720
: (node>path) node>path ;
 
721
 
 
722
: node>path ( phandle -- str len )
 
723
   node>path dup allot
 
724
;
 
725
 
 
726
\ Support for support packages.
 
727
 
 
728
\ The /packages node.
 
729
0 VALUE packages
 
730
 
 
731
\ Find a support package (or arbitrary nodes when name is absolute)
 
732
: find-package  ( name len -- false | phandle true )
 
733
   dup 0 <= IF
 
734
      2drop FALSE EXIT
 
735
   THEN
 
736
   \ According to IEEE 1275 Proposal 215 (Extensible Client Services Package),
 
737
   \ the find-package method can be used to get the phandle of arbitrary nodes
 
738
   \ (i.e. not only support packages) when the name starts with a slash.
 
739
   \ Some FCODE programs depend on this behavior so let's support this, too!
 
740
   over c@ [char] / = IF
 
741
      find-node dup IF TRUE THEN EXIT
 
742
   THEN
 
743
   \ Ok, let's look for support packages instead. We can't use the standard
 
744
   \ find-node stuff, as we are required to find the newest (i.e., last in our
 
745
   \ tree) matching package, not just any.
 
746
    0 >r packages child
 
747
    BEGIN
 
748
       dup
 
749
    WHILE
 
750
       dup >r node>name 2over string=ci r> swap IF
 
751
          r> drop dup >r
 
752
       THEN
 
753
       peer
 
754
    REPEAT
 
755
    3drop
 
756
    r> dup IF true THEN
 
757
;
 
758
 
 
759
: open-package ( arg len phandle -- ihandle | 0 )  open-node ;
 
760
: close-package ( ihandle -- )  close-node ;
 
761
: $open-package ( arg len name len -- ihandle | 0 )
 
762
  find-package IF open-package ELSE 2drop false THEN ;
 
763
 
 
764
 
 
765
\ device tree translate-address
 
766
#include <translate.fs>