| \ ***************************************************************************** |
| \ * 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 |
| ; |