![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to device.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device|
Return to device.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 root 1: \ tag: Package creation and deletion
2: \
3: \ this code implements IEEE 1275-1994
4: \
5: \ Copyright (C) 2003, 2004 Samuel Rydh
6: \
7: \ See the file "COPYING" for further information about
8: \ the copyright and warranty status of this work.
9: \
10:
11: variable device-tree
12:
13: \ make defined words globally visible
14: \
15: : external ( -- )
16: active-package ?dup if
17: >dn.methods @ set-current
18: then
19: ;
20:
21: \ make the private wordlist active (not an OF word)
22: \
23: : private ( -- )
24: active-package ?dup if
25: >r
26: forth-wordlist r@ >dn.methods @ r@ >dn.priv-methods @ 3 set-order
27: r> >dn.priv-methods @ set-current
28: then
29: ;
30:
31: \ set activate package and make the world visible package wordlist
32: \ the current one.
33: \
34: : active-package! ( phandle -- )
35: dup to active-package
36: \ locally defined words are not available
37: ?dup if
38: forth-wordlist over >dn.methods @ 2 set-order
39: >dn.methods @ set-current
40: else
41: forth-wordlist dup 1 set-order set-current
42: then
43: ;
44:
45:
46: \ new-device ( -- )
47: \
48: \ Start new package, as child of active package.
49: \ Create a new device node as a child of the active package and make the
50: \ new node the active package. Create a new instance and make it the current
51: \ instance; the instance that invoked new-device becomes the parent instance
52: \ of the new instance.
53: \ Subsequently, newly defined Forth words become the methods of the new node
54: \ and newly defined data items (such as types variable, value, buffer:, and
55: \ defer) are allocated and stored within the new instance.
56:
57: : new-device ( -- )
58: align-tree dev-node.size alloc-tree >r
59: active-package
60: dup r@ >dn.parent !
61:
62: \ ( parent ) hook up at the end of the peer list
63: ?dup if
64: >dn.child
65: begin dup @ while @ >dn.peer repeat
66: r@ swap !
67: else
68: \ we are the root node!
69: r@ to device-tree
70: then
71:
72: \ ( -- ) fill in device node stuff
73: inst-node.size r@ >dn.isize !
74:
75: \ create two wordlists
76: wordlist r@ >dn.methods !
77: wordlist r@ >dn.priv-methods !
78:
79: \ initialize template data
80: r@ >dn.itemplate
81: r@ over >in.device-node !
82: my-self over >in.my-parent !
83:
84: \ make it the active package and current instance
85: to my-self
86: r@ active-package!
87:
88: \ swtich to public wordlist
89: external
90: r> drop
91: ;
92:
93: \ helpers for finish-device (OF does not actually define words
94: \ for device node deletion)
95:
96: : (delete-device) \ ( phandle )
97: >r
98: r@ >dn.parent @
99: ?dup if
100: >dn.child \ ( &first-child )
101: begin dup @ r@ <> while @ >dn.peer repeat
102: r@ >dn.peer @ swap !
103: else
104: \ root node
105: 0 to device-tree
106: then
107:
108: \ XXX: free any memory related to this node.
109: \ we could have a list with free device-node headers...
110: r> drop
111: ;
112:
113: : delete-device \ ( phandle )
114: >r
115: \ first, get rid of any children
116: begin r@ >dn.child @ dup while
117: (delete-device)
118: repeat
119: drop
120:
121: \ then free this node
122: r> (delete-device)
123: ;
124:
125: \ finish-device ( -- )
126: \
127: \ Finish this package, set active package to parent.
128: \ Complete a device node that was created by new-device, as follows: If the
129: \ device node has no "name" property, remove the device node from the device
130: \ tree. Otherwise, save the current values of the current instance's
131: \ initialized data items within the active package for later use in
132: \ initializing the data items of instances created from that node. In any
133: \ case, destroy the current instance, make its parent instance the current
134: \ instance, and select the parent node of the device node just completed,
135: \ making the parent node the active package again.
136:
137: : finish-device \ ( -- )
138: my-self
139: dup >in.device-node @ >r
140: >in.my-parent @ to my-self
141:
142: ( -- )
143: r@ >dn.parent @ active-package!
144: s" name" r@ get-package-property if
145: \ delete the node (and any children)
146: r@ delete-device
147: else
148: 2drop
149: \ node OK
150: then
151: r> drop
152: ;
153:
154:
155: \ helper function which creates and initializes an instance.
156: \ open is not called. The current instance is not changed.
157: \
158: : create-instance ( phandle -- ihandle|0 )
159: dup >dn.isize @ ['] alloc-mem catch if 2drop 0 exit then
160: >r
161: \ we need to save the size in order to be able to release it properly
162: dup >dn.isize @ r@ >in.alloced-size !
163:
164: \ clear memory (we only need to clear the head; all other data is copied)
165: r@ inst-node.size 0 fill
166:
167: ( phandle R: ihandle )
168:
169: \ instantiate data
170: dup >dn.methods @ r@ instance-init
171: dup >dn.priv-methods @ r@ instance-init
172:
173: \ instantiate
174: dup >dn.itemplate r@ inst-node.size move
175: r@ r@ >in.instance-data !
176: my-self r@ >in.my-parent !
177: drop
178:
179: r>
180: ;
181:
182: \ helper function which tears down and frees an instance
183: : destroy-instance ( ihandle )
184: ?dup if
185: \ free arguments
186: dup >in.arguments 2@ free-mem
187: \ and the instance block
188: dup >in.alloced-size @
189: free-mem
190: then
191: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.