[openfirmware] [commit] r2610 - ofw/core
repository service
svn at openfirmware.info
Sun Oct 16 00:23:26 CEST 2011
Author: wmb
Date: Sun Oct 16 00:23:26 2011
New Revision: 2610
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2610
Log:
Core - added voc>phandle and phandle>voc defer words, defaulting to noop, to decouple the representation of a phandle from the implementation choice of the address of a Forth wordlist. There is no current need for that decoupling, but the implementation is cleaner with the change. The change should have no functional impact.
Modified:
ofw/core/ofwcore.fth
Modified: ofw/core/ofwcore.fth
==============================================================================
--- ofw/core/ofwcore.fth Sat Oct 15 23:56:30 2011 (r2609)
+++ ofw/core/ofwcore.fth Sun Oct 16 00:23:26 2011 (r2610)
@@ -673,6 +673,9 @@
headers
+defer voc>phandle ' noop to voc>phandle
+defer phandle>voc ' noop to phandle>voc
+
\ TODO
\ Don't use the system search order; use a private stack
\ $find searches through the private stack
@@ -680,14 +683,14 @@
\ Either implement a true breadth-first search or don't specify it.
2 actions
-action: drop context token@ ;
-action: drop context token! definitions ;
+action: drop context token@ voc>phandle ;
+action: drop phandle>voc context token! definitions ;
create current-device use-actions
headerless
: ufield \ name ( offset size -- offset' )
create over , +
- does> @ current-device >body >user +
+ does> @ current-device phandle>voc >body >user +
;
\ Notes for a more abstract searching mechanism:
@@ -715,14 +718,17 @@
constant /devnode-extra
headers
-: >parent ( node -- parent-node ) >voc-link link@ ;
+: >parent ( node -- parent-node ) >voc-link link@ voc>phandle ;
: parent-device ( -- parent-node ) current-device >parent ;
+: (select-package) ( phandle -- ) phandle>voc execute ;
+: (push-package) ( phandle -- ) also (select-package) ;
+: (pop-package) ( phandle -- ) previous ;
: push-package ( phandle -- )
dup 0= if ." Attempting to push null package!!!" abort then
- also execute definitions
+ (push-package) definitions
;
-: pop-package ( -- ) previous definitions ;
+: pop-package ( -- ) (pop-package) definitions ;
: push-device ( acf -- ) to current-device ;
: pop-device ( -- )
@@ -945,7 +951,7 @@
: >initial-value ( pfa -- adr )
@
my-self if \ Use current instance's package if there is a current instance
- my-voc also execute initial-values previous
+ my-voc (push-package) initial-values (pop-package)
else \ Otherwise use the active package
initial-values
then
@@ -1045,9 +1051,9 @@
\ to a non-existent instance.
: destroy-instance ( -- )
- also my-voc execute ( )
+ my-voc (push-package) ( )
'#values @ '#buffers @ negate ( value-size variable-size )
- previous ( value-size variable-size )
+ (pop-package) ( value-size variable-size )
deallocate-instance
;
@@ -1150,6 +1156,9 @@
: $vexecute? ( adr len voc-acf -- true | ??? false)
(search-wordlist) if execute false else true then
;
+: $package-execute? ( adr len phandle -- true | ??? false)
+ phandle>voc (search-wordlist) if execute false else true then
+;
: $vexecute ( adr len voc-acf -- ?? ) $vexecute? drop ;
headers
@@ -1227,7 +1236,7 @@
: my-#adr-cells ( -- n )
my-self if \ Use current instance's package if there is a current instance
- my-voc also execute '#adr-cells @ previous
+ my-voc (push-package) '#adr-cells @ (pop-package)
else \ Otherwise use the active package
'#adr-cells @
then
@@ -1359,7 +1368,7 @@
: property ( value-adr,len name-adr,len -- )
my-self if
- context token@ >r my-voc execute
+ context token@ >r my-voc (select-package)
(property)
r> context token!
else
@@ -1515,7 +1524,7 @@
headers
: package-execute ( ?? adr len -- ?? )
- current-device $vexecute? abort" Package method not found"
+ current-device $package-execute? abort" Package method not found"
;
headerless
@@ -1788,8 +1797,8 @@
get-unit 0= if ( unit-str )
." @"
unit-str>phys ( phys.lo .. phys.hi )
- " encode-unit" parent-device ( phys.lo .. phys.hi adr,len ph )
- $vexecute? if ( phys.lo .. phys.hi )
+ " encode-unit" parent-device ( phys.lo .. phys.hi adr,len phandle )
+ $package-execute? if ( phys.lo .. phys.hi )
'#adr-cells @ if .nh then ( phys.lo .. phys.next )
'#adr-cells @ 1- 0 max 0 ?do ." ," .nh loop ( )
else
@@ -2132,7 +2141,7 @@
;
: get-package-property ( adr len phandle -- true | adr' len' false )
- also execute get-property previous
+ (push-package) get-property (pop-package)
;
\ Used when executing from an open package instance. Finds a property
@@ -2273,7 +2282,7 @@
;
: apply-method ( adr len -- no-such-method? )
- my-voc fm-hook ['] $vexecute? catch ?dup if ( x x x errno )
+ my-voc fm-hook ['] $package-execute? catch ?dup if ( x x x errno )
\ executing method caused an error
nip nip nip ( errno )
then ( ??? false | true | errno )
@@ -2771,7 +2780,7 @@
" @" encode-bytes+ 2>r ( phys .. ) ( R: $ )
" encode-unit" parent-device ( phys .. adr,len phandle ) ( R: $ )
- $vexecute? if ( phys .. ) ( R: $ )
+ $package-execute? if ( phys .. ) ( R: $ )
2r> ( phys .. adr,len ) ( R: )
'#adr-cells @ if encode-number+ then ( phys . adr,len' )
@@ -3164,9 +3173,9 @@
headerless
: (trace) ( adr len phandle -- adr len phandle )
>r >r >r .s r> r> ( adr len ) ( r: phandle )
- also r@ execute ( adr len ) ( r: phandle )
+ r@ (push-package) ( adr len ) ( r: phandle )
" name" get-property ( adr len value-str false ) ( r: phandle )
- previous ( adr len value-str false ) ( r: phandle )
+ (pop-package) ( adr len value-str false ) ( r: phandle )
drop get-encoded-string type ( adr len ) ( r: phandle )
." : " 2dup type space cr ( adr len ) ( r: phandle )
r> ( adr len phandle )
@@ -4051,7 +4060,7 @@
;
: setnode ( nodeid | 0 -- )
- dup 0= if drop ['] root-node then also execute
+ dup 0= if drop ['] root-node then (push-package)
;
\ : copyout ( buf adr len -- len ) >r swap r@ cmove r> ;
@@ -4124,7 +4133,7 @@
false ( false )
then
then ( cstr )
- previous
+ (pop-package)
;
: .cstr ( cstr -- ) begin dup c@ ?dup while emit 1+ repeat drop ;
@@ -4150,10 +4159,10 @@
setnode ( )
0 'child ( last-nodeid &next-nodeid )
begin get-token? while ( last-nodeid next-nodeid )
- nip dup execute ( next-nodeid )
+ nip dup (select-package) ( next-nodeid )
'peer ( last-nodeid' &next-nodeid )
repeat ( last-nodeid' )
- previous ( nodeid )
+ (pop-package) ( nodeid )
;
: peer ( phandle -- phandle' )
@@ -4166,8 +4175,8 @@
then ( nodeid )
\ Select the first child of our parent
- dup >parent also execute ( nodeid )
- 'child token@ execute ( nodeid )
+ dup >parent (push-package) ( nodeid )
+ 'child token@ (select-package) ( nodeid )
dup current-device = if ( nodeid )
\ Argument node is first child of parent; return "no more nodes"
@@ -4181,7 +4190,7 @@
repeat ( nodeid )
2drop current-device ( nodeid' )
then ( nodeid | 0 )
- previous ( nodeid | 0 )
+ (pop-package) ( nodeid | 0 )
;
: parent ( phandle -- phandle' )
@@ -4203,7 +4212,7 @@
2drop -1 ( -1 )
then ( len | -1 )
then ( len | -1 )
- previous ( len | -1 )
+ (pop-package) ( len | -1 )
;
: instance-to-package ( ihandle -- phandle ) ihandle>phandle ;
@@ -4228,7 +4237,7 @@
2drop 2drop -1 ( -1 )
then ( len|-1 )
then ( len|-1 )
- previous ( len|-1 )
+ (pop-package) ( len|-1 )
;
: nextprop ( buf prev phandle -- 1|0|-1 )
@@ -4259,7 +4268,7 @@
2drop 2drop -1 ( -1 )
then ( len|-1 )
then ( len|-1 )
- previous
+ (pop-package)
;
: finddevice ( cstr -- phandle ) cscount locate-device ?dup drop ;
@@ -4325,8 +4334,8 @@
: append-my-unit ( phys.. -- )
" @" canon+
- " encode-unit" parent-device ( phys.. adr,len ph )
- $vexecute? if ( phys.. )
+ " encode-unit" parent-device ( phys.. adr,len phandle )
+ $package-execute? if ( phys.. )
'#adr-cells @ if (nh.) canon+ then ( phys.lo .. phys.next )
'#adr-cells @ 1- 0 max 0 ?do ( phys.lo .. phys.next )
" ," canon+ (nh.) canon+ ( phys.lo .. phys.next' )
@@ -4424,13 +4433,13 @@
headerless
: ?delete-address ( adr len -- adr len )
my-self if ( adr len )
- also my-voc execute ( adr len )
+ my-voc (push-package) ( adr len )
" address" get-property 0= if ( adr len value-adr,len )
get-encoded-int 2 pick = if ( adr len )
" address" delete-property ( adr len )
then ( adr len )
then ( adr len )
- previous ( adr len )
+ (pop-package) ( adr len )
then ( adr len )
;
headers
More information about the openfirmware
mailing list