qemu/roms/SLOF/slof/fs/instance.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2011 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13 \ Support for device node instances.
  14
  15 0 VALUE my-self
  16
  17 400 CONSTANT max-instance-size
  18
  19 STRUCT
  20    /n FIELD instance>node
  21    /n FIELD instance>parent
  22    /n FIELD instance>args
  23    /n FIELD instance>args-len
  24    /n FIELD instance>size
  25    /n FIELD instance>#units
  26    /n FIELD instance>unit1          \ For instance-specific "my-unit"
  27    /n FIELD instance>unit2
  28    /n FIELD instance>unit3
  29    /n FIELD instance>unit4
  30 CONSTANT /instance-header
  31
  32 : >instance  ( offset -- myself+offset )
  33    my-self 0= ABORT" No instance!"
  34    dup my-self instance>size @ >= ABORT" Instance access out of bounds!"
  35    my-self +
  36 ;
  37
  38 : (create-instance-var) ( initial-value -- )
  39    get-node
  40    dup node>instance-size @ cell+ max-instance-size
  41    >= ABORT" Instance is bigger than max-instance-size!"
  42    dup node>instance-template @      ( iv phandle tmp-ih )
  43    swap node>instance-size dup @     ( iv tmp-ih *instance-size instance-size )
  44    dup ,                             \ compile current instance ptr
  45    swap 1 cells swap +!              ( iv tmp-ih instance-size )
  46    + !
  47 ;
  48
  49 : create-instance-var ( "name" initial-value -- )
  50    CREATE (create-instance-var) PREVIOUS
  51 ;
  52
  53 : (create-instance-buf) ( buffersize -- )
  54    aligned                               \ align size to multiples of cells
  55    dup get-node node>instance-size @ +   ( buffersize' newinstancesize )
  56    max-instance-size > ABORT" Instance is bigger than max-instance-size!"
  57    get-node node>instance-template @  get-node node>instance-size @ +
  58    over erase                            \ clear according to IEEE 1275
  59    get-node node>instance-size @         ( buffersize' old-instance-size )
  60    dup ,                                 \ compile current instance ptr
  61    + get-node node>instance-size !       \ store new size
  62 ;
  63
  64 : create-instance-buf ( "name" buffersize -- )
  65    CREATE (create-instance-buf) PREVIOUS
  66 ;
  67
  68 VOCABULARY instance-words  ALSO instance-words DEFINITIONS
  69
  70 : VARIABLE  0 create-instance-var DOES> [ here ] @ >instance ;
  71 : VALUE       create-instance-var DOES> [ here ] @ >instance @ ;
  72 : DEFER     0 create-instance-var DOES> [ here ] @ >instance @ execute ;
  73 : BUFFER:     create-instance-buf DOES> [ here ] @ >instance ;
  74
  75 PREVIOUS DEFINITIONS
  76
  77 \ Save XTs of the above instance-words (put on the stack with "[ here ]")
  78 CONSTANT <instancebuffer>
  79 CONSTANT <instancedefer>
  80 CONSTANT <instancevalue>
  81 CONSTANT <instancevariable>
  82
  83 \ check whether a value or a defer word is an
  84 \ instance word: It must be a CREATE word and
  85 \ the DOES> part must do >instance as first thing
  86
  87 : (instance?) ( xt -- xt true|false )
  88    dup @ <create> = IF
  89       dup cell+ @ cell+ @ ['] >instance =
  90    ELSE
  91       false
  92    THEN
  93 ;
  94
  95 \ This word does instance values in compile mode.
  96 \ It corresponds to DOTO from engine.in
  97 : (doito) ( value R:*CFA -- )
  98    r> cell+ dup >r
  99    @ cell+ cell+ @ >instance !
 100 ;
 101 ' (doito) CONSTANT <(doito)>
 102
 103 : to ( value wordname<> -- )
 104    ' (instance?)
 105    state @ IF
 106       \ compile mode handling normal or instance value
 107       IF ['] (doito) ELSE ['] DOTO THEN
 108       , , EXIT
 109    THEN
 110    IF
 111       cell+ cell+ @ >instance ! \ interp mode instance value
 112    ELSE
 113       cell+ !                   \ interp mode normal value
 114    THEN
 115 ; IMMEDIATE
 116
 117 : behavior  ( defer-xt -- contents-xt )
 118    dup cell+ @ <instancedefer> = IF   \ Is defer-xt an INSTANCE DEFER ?
 119       2 cells + @ >instance @
 120    ELSE
 121       behavior
 122    THEN
 123 ;
 124
 125 : INSTANCE  ALSO instance-words ;
 126
 127 : my-parent  my-self instance>parent @ ;
 128 : my-args    my-self instance>args 2@ swap ;
 129
 130 \ copy args from original instance to new created
 131 : set-my-args   ( old-addr len -- )
 132    dup IF                             \ IF len > 0                    ( old-addr len )
 133       dup alloc-mem                   \ | allocate space for new args ( old-addr len new-addr )
 134       2dup my-self instance>args 2!   \ | write into instance struct  ( old-addr len new-addr )
 135       swap move                       \ | and copy the args           ( )
 136    ELSE                               \ ELSE                          ( old-addr len )
 137       my-self instance>args 2!        \ | set new args to zero, too   ( )
 138    THEN                               \ FI
 139 ;
 140
 141 \ Current node has already been set, when this is called.
 142 : create-instance-data ( -- instance )
 143    get-node dup node>instance-template @    ( phandle instance-template )
 144    swap node>instance-size @                ( instance-template instance-size )
 145    dup >r
 146    dup alloc-mem dup >r swap move r>        ( instance )
 147    dup instance>size r> swap !              \ Store size for destroy-instance
 148    dup instance>#units 0 swap !             \ Use node unit by default
 149 ;
 150 : create-instance ( -- )
 151    my-self create-instance-data
 152    dup to my-self instance>parent !
 153    get-node my-self instance>node !
 154 ;
 155
 156 : destroy-instance ( instance -- )
 157    dup instance>args @ ?dup IF               \ Free instance args?
 158       over instance>args-len @  free-mem
 159    THEN
 160    dup instance>size @  free-mem
 161 ;
 162
 163 : ihandle>phandle ( ihandle -- phandle )
 164    dup 0= ABORT" no current instance" instance>node @
 165 ;
 166
 167 : push-my-self ( ihandle -- )  r> my-self >r >r to my-self ;
 168 : pop-my-self ( -- )  r> r> to my-self >r ;
 169 : call-package  push-my-self execute pop-my-self ;
 170 : $call-static ( ... str len node -- ??? )
 171 \  cr ." call for " 3dup -rot type ."  on node " .
 172    find-method IF execute ELSE -1 throw THEN
 173 ;
 174
 175 : $call-my-method  ( str len -- )
 176    my-self ihandle>phandle $call-static
 177 ;
 178
 179 : $call-method  ( str len ihandle -- )
 180    push-my-self
 181    ['] $call-my-method CATCH ?dup IF
 182       pop-my-self THROW
 183    THEN
 184    pop-my-self
 185 ;
 186
 187 0 VALUE calling-child
 188
 189 : $call-parent
 190    my-self ihandle>phandle TO calling-child
 191    my-parent $call-method
 192    0 TO calling-child
 193 ;