forth/device/device.fs

   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 ;