--- qemu/roms/SLOF/slof/fs/instance.fs 2018/04/24 19:26:04 1.1.1.2 +++ qemu/roms/SLOF/slof/fs/instance.fs 2018/04/24 19:45:49 1.1.1.3 @@ -10,21 +10,36 @@ \ * IBM Corporation - initial implementation \ ****************************************************************************/ - \ Support for device node instances. 0 VALUE my-self -: >instance +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 0= ABORT" Instance word outside device context!" - dup node>extending? @ 0= - my-self 0<> AND ABORT" INSTANCE word can not be used while node is opened!" - dup node>instance @ ( iv phandle tmp-ihandle ) + 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 ) @@ -32,18 +47,35 @@ ; : create-instance-var ( "name" initial-value -- ) - CREATE (create-instance-var) PREVIOUS ; + 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 ; -\ No support for BUFFER: yet. +: BUFFER: create-instance-buf DOES> [ here ] @ >instance ; PREVIOUS DEFINITIONS \ Save XTs of the above instance-words (put on the stack with "[ here ]") +CONSTANT CONSTANT CONSTANT CONSTANT @@ -66,6 +98,7 @@ CONSTANT r> cell+ dup >r @ cell+ cell+ @ >instance ! ; +' (doito) CONSTANT <(doito)> : to ( value wordname<> -- ) ' (instance?) @@ -81,26 +114,25 @@ CONSTANT THEN ; IMMEDIATE -: INSTANCE ALSO instance-words ; - +: behavior ( defer-xt -- contents-xt ) + dup cell+ @ = IF \ Is defer-xt an INSTANCE DEFER ? + 2 cells + @ >instance @ + ELSE + behavior + THEN +; -STRUCT -/n FIELD instance>node -/n FIELD instance>parent -/n FIELD instance>args -/n FIELD instance>args-len -CONSTANT /instance-header +: INSTANCE ALSO instance-words ; : my-parent my-self instance>parent @ ; -: my-args my-self instance>args 2@ ; +: 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 ) - swap 2dup \ | write the new address ( old-addr new-addr len new-addr len ) - my-self instance>args 2! \ | into the instance table ( old-addr new-addr len ) - move \ | and copy the args ( -- ) + 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 @@ -108,8 +140,12 @@ CONSTANT /instance-header \ Current node has already been set, when this is called. : create-instance-data ( -- instance ) - get-node dup node>instance @ swap node>instance-size @ ( instance instance-size ) - dup alloc-mem dup >r swap move r> + 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 @@ -118,7 +154,10 @@ CONSTANT /instance-header ; : destroy-instance ( instance -- ) - dup @ node>instance-size @ free-mem + dup instance>args @ ?dup IF \ Free instance args? + over instance>args-len @ free-mem + THEN + dup instance>size @ free-mem ; : ihandle>phandle ( ihandle -- phandle ) @@ -132,6 +171,23 @@ CONSTANT /instance-header \ 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 push-my-self $call-my-method pop-my-self ; -: $call-parent my-parent $call-method ; + +: $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 +;