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