--- qemu/roms/SLOF/slof/fs/instance.fs 2018/04/24 18:59:09 1.1 +++ qemu/roms/SLOF/slof/fs/instance.fs 2018/04/24 19:45:49 1.1.1.3 @@ -1,5 +1,5 @@ \ ***************************************************************************** -\ * Copyright (c) 2004, 2008 IBM Corporation +\ * 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 @@ -10,19 +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>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 ) @@ -30,17 +47,39 @@ ; : 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> @ >instance ; -: VALUE create-instance-var DOES> @ >instance @ ; -: DEFER 0 create-instance-var DOES> @ >instance @ execute ; -\ No support for BUFFER: yet. +: 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 +CONSTANT +CONSTANT +CONSTANT + \ 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 @@ -59,6 +98,7 @@ PREVIOUS DEFINITIONS r> cell+ dup >r @ cell+ cell+ @ >instance ! ; +' (doito) CONSTANT <(doito)> : to ( value wordname<> -- ) ' (instance?) @@ -74,26 +114,25 @@ PREVIOUS DEFINITIONS 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 @@ -101,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 @@ -111,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 ) @@ -125,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 +;