![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instance.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs|
Return to instance.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs |
1.1 root 1: \ *****************************************************************************
1.1.1.2 root 2: \ * Copyright (c) 2004, 2011 IBM Corporation
1.1 root 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:
1.1.1.3 ! root 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 )
1.1 root 33: my-self 0= ABORT" No instance!"
1.1.1.3 ! root 34: dup my-self instance>size @ >= ABORT" Instance access out of bounds!"
1.1 root 35: my-self +
36: ;
37:
38: : (create-instance-var) ( initial-value -- )
1.1.1.3 ! root 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 )
1.1 root 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 -- )
1.1.1.3 ! root 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: ;
1.1 root 67:
68: VOCABULARY instance-words ALSO instance-words DEFINITIONS
69:
1.1.1.2 root 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 ;
1.1.1.3 ! root 73: : BUFFER: create-instance-buf DOES> [ here ] @ >instance ;
1.1 root 74:
75: PREVIOUS DEFINITIONS
76:
1.1.1.2 root 77: \ Save XTs of the above instance-words (put on the stack with "[ here ]")
1.1.1.3 ! root 78: CONSTANT <instancebuffer>
1.1.1.2 root 79: CONSTANT <instancedefer>
80: CONSTANT <instancevalue>
81: CONSTANT <instancevariable>
82:
1.1 root 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: ;
1.1.1.3 ! root 101: ' (doito) CONSTANT <(doito)>
1.1 root 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:
1.1.1.3 ! root 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: ;
1.1 root 124:
1.1.1.3 ! root 125: : INSTANCE ALSO instance-words ;
1.1 root 126:
127: : my-parent my-self instance>parent @ ;
1.1.1.3 ! root 128: : my-args my-self instance>args 2@ swap ;
1.1 root 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 )
1.1.1.3 ! root 134: 2dup my-self instance>args 2! \ | write into instance struct ( old-addr len new-addr )
! 135: swap move \ | and copy the args ( )
1.1 root 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 )
1.1.1.3 ! root 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
1.1 root 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 -- )
1.1.1.3 ! root 157: dup instance>args @ ?dup IF \ Free instance args?
! 158: over instance>args-len @ free-mem
! 159: THEN
! 160: dup instance>size @ free-mem
1.1 root 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: ;
1.1.1.3 ! root 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: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.