diff options
Diffstat (limited to 'qemu/roms/SLOF/slof/fs/instance.fs')
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/instance.fs | 193 |
1 files changed, 193 insertions, 0 deletions
diff --git a/qemu/roms/SLOF/slof/fs/instance.fs b/qemu/roms/SLOF/slof/fs/instance.fs new file mode 100644 index 000000000..9e5c9215e --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/instance.fs @@ -0,0 +1,193 @@ +\ ***************************************************************************** +\ * 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 +; |