--- /dev/null
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Support for device node instances.
+
+0 VALUE my-self
+
+400 CONSTANT max-instance-size
+
+STRUCT
+ /n FIELD instance>node
+ /n FIELD instance>parent
+ /n FIELD instance>args
+ /n FIELD instance>args-len
+ /n FIELD instance>size
+ /n FIELD instance>#units
+ /n FIELD instance>unit1 \ For instance-specific "my-unit"
+ /n FIELD instance>unit2
+ /n FIELD instance>unit3
+ /n FIELD instance>unit4
+CONSTANT /instance-header
+
+: >instance ( offset -- myself+offset )
+ my-self 0= ABORT" No instance!"
+ dup my-self instance>size @ >= ABORT" Instance access out of bounds!"
+ my-self +
+;
+
+: (create-instance-var) ( initial-value -- )
+ get-node
+ dup node>instance-size @ cell+ max-instance-size
+ >= ABORT" Instance is bigger than max-instance-size!"
+ dup node>instance-template @ ( iv phandle tmp-ih )
+ swap node>instance-size dup @ ( iv tmp-ih *instance-size instance-size )
+ dup , \ compile current instance ptr
+ swap 1 cells swap +! ( iv tmp-ih instance-size )
+ + !
+;
+
+: create-instance-var ( "name" initial-value -- )
+ CREATE (create-instance-var) PREVIOUS
+;
+
+: (create-instance-buf) ( buffersize -- )
+ aligned \ align size to multiples of cells
+ dup get-node node>instance-size @ + ( buffersize' newinstancesize )
+ max-instance-size > ABORT" Instance is bigger than max-instance-size!"
+ get-node node>instance-template @ get-node node>instance-size @ +
+ over erase \ clear according to IEEE 1275
+ get-node node>instance-size @ ( buffersize' old-instance-size )
+ dup , \ compile current instance ptr
+ + get-node node>instance-size ! \ store new size
+;
+
+: create-instance-buf ( "name" buffersize -- )
+ CREATE (create-instance-buf) PREVIOUS
+;
+
+VOCABULARY instance-words ALSO instance-words DEFINITIONS
+
+: VARIABLE 0 create-instance-var DOES> [ here ] @ >instance ;
+: VALUE create-instance-var DOES> [ here ] @ >instance @ ;
+: DEFER 0 create-instance-var DOES> [ here ] @ >instance @ execute ;
+: BUFFER: create-instance-buf DOES> [ here ] @ >instance ;
+
+PREVIOUS DEFINITIONS
+
+\ Save XTs of the above instance-words (put on the stack with "[ here ]")
+CONSTANT <instancebuffer>
+CONSTANT <instancedefer>
+CONSTANT <instancevalue>
+CONSTANT <instancevariable>
+
+\ check whether a value or a defer word is an
+\ instance word: It must be a CREATE word and
+\ the DOES> part must do >instance as first thing
+
+: (instance?) ( xt -- xt true|false )
+ dup @ <create> = IF
+ dup cell+ @ cell+ @ ['] >instance =
+ ELSE
+ false
+ THEN
+;
+
+\ This word does instance values in compile mode.
+\ It corresponds to DOTO from engine.in
+: (doito) ( value R:*CFA -- )
+ r> cell+ dup >r
+ @ cell+ cell+ @ >instance !
+;
+' (doito) CONSTANT <(doito)>
+
+: to ( value wordname<> -- )
+ ' (instance?)
+ state @ IF
+ \ compile mode handling normal or instance value
+ IF ['] (doito) ELSE ['] DOTO THEN
+ , , EXIT
+ THEN
+ IF
+ cell+ cell+ @ >instance ! \ interp mode instance value
+ ELSE
+ cell+ ! \ interp mode normal value
+ THEN
+; IMMEDIATE
+
+: behavior ( defer-xt -- contents-xt )
+ dup cell+ @ <instancedefer> = IF \ Is defer-xt an INSTANCE DEFER ?
+ 2 cells + @ >instance @
+ ELSE
+ behavior
+ THEN
+;
+
+: INSTANCE ALSO instance-words ;
+
+: my-parent my-self instance>parent @ ;
+: my-args my-self instance>args 2@ swap ;
+
+\ copy args from original instance to new created
+: set-my-args ( old-addr len -- )
+ dup IF \ IF len > 0 ( old-addr len )
+ dup alloc-mem \ | allocate space for new args ( old-addr len new-addr )
+ 2dup my-self instance>args 2! \ | write into instance struct ( old-addr len new-addr )
+ swap move \ | and copy the args ( )
+ ELSE \ ELSE ( old-addr len )
+ my-self instance>args 2! \ | set new args to zero, too ( )
+ THEN \ FI
+;
+
+\ Current node has already been set, when this is called.
+: create-instance-data ( -- instance )
+ get-node dup node>instance-template @ ( phandle instance-template )
+ swap node>instance-size @ ( instance-template instance-size )
+ dup >r
+ dup alloc-mem dup >r swap move r> ( instance )
+ dup instance>size r> swap ! \ Store size for destroy-instance
+ dup instance>#units 0 swap ! \ Use node unit by default
+;
+: create-instance ( -- )
+ my-self create-instance-data
+ dup to my-self instance>parent !
+ get-node my-self instance>node !
+;
+
+: destroy-instance ( instance -- )
+ dup instance>args @ ?dup IF \ Free instance args?
+ over instance>args-len @ free-mem
+ THEN
+ dup instance>size @ free-mem
+;
+
+: ihandle>phandle ( ihandle -- phandle )
+ dup 0= ABORT" no current instance" instance>node @
+;
+
+: push-my-self ( ihandle -- ) r> my-self >r >r to my-self ;
+: pop-my-self ( -- ) r> r> to my-self >r ;
+: call-package push-my-self execute pop-my-self ;
+: $call-static ( ... str len node -- ??? )
+\ cr ." call for " 3dup -rot type ." on node " .
+ find-method IF execute ELSE -1 throw THEN
+;
+
+: $call-my-method ( str len -- )
+ my-self ihandle>phandle $call-static
+;
+
+: $call-method ( str len ihandle -- )
+ push-my-self
+ ['] $call-my-method CATCH ?dup IF
+ pop-my-self THROW
+ THEN
+ pop-my-self
+;
+
+0 VALUE calling-child
+
+: $call-parent
+ my-self ihandle>phandle TO calling-child
+ my-parent $call-method
+ 0 TO calling-child
+;
Code Review / kvmfornfv.git / blobdiff