![[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: \ *****************************************************************************
2: \ * Copyright (c) 2004, 2008 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:
14: \ Support for device node instances.
15:
16: 0 VALUE my-self
17:
18: : >instance
19: my-self 0= ABORT" No instance!"
20: my-self +
21: ;
22:
23: : (create-instance-var) ( initial-value -- )
24: get-node ?dup 0= ABORT" Instance word outside device context!"
25: dup node>instance @ ( iv phandle tmp-ihandle )
26: swap node>instance-size dup @ ( iv tmp-ih *instance-size instance-size )
27: dup , \ compile current instance ptr
28: swap 1 cells swap +! ( iv tmp-ih instance-size )
29: + !
30: ;
31:
32: : create-instance-var ( "name" initial-value -- )
33: CREATE (create-instance-var) PREVIOUS ;
34:
35: VOCABULARY instance-words ALSO instance-words DEFINITIONS
36:
37: : VARIABLE 0 create-instance-var DOES> @ >instance ;
38: : VALUE create-instance-var DOES> @ >instance @ ;
39: : DEFER 0 create-instance-var DOES> @ >instance @ execute ;
40: \ No support for BUFFER: yet.
41:
42: PREVIOUS DEFINITIONS
43:
44: \ check whether a value or a defer word is an
45: \ instance word: It must be a CREATE word and
46: \ the DOES> part must do >instance as first thing
47:
48: : (instance?) ( xt -- xt true|false )
49: dup @ <create> = IF
50: dup cell+ @ cell+ @ ['] >instance =
51: ELSE
52: false
53: THEN
54: ;
55:
56: \ This word does instance values in compile mode.
57: \ It corresponds to DOTO from engine.in
58: : (doito) ( value R:*CFA -- )
59: r> cell+ dup >r
60: @ cell+ cell+ @ >instance !
61: ;
62:
63: : to ( value wordname<> -- )
64: ' (instance?)
65: state @ IF
66: \ compile mode handling normal or instance value
67: IF ['] (doito) ELSE ['] DOTO THEN
68: , , EXIT
69: THEN
70: IF
71: cell+ cell+ @ >instance ! \ interp mode instance value
72: ELSE
73: cell+ ! \ interp mode normal value
74: THEN
75: ; IMMEDIATE
76:
77: : INSTANCE ALSO instance-words ;
78:
79:
80: STRUCT
81: /n FIELD instance>node
82: /n FIELD instance>parent
83: /n FIELD instance>args
84: /n FIELD instance>args-len
85: CONSTANT /instance-header
86:
87: : my-parent my-self instance>parent @ ;
88: : my-args my-self instance>args 2@ ;
89:
90: \ copy args from original instance to new created
91: : set-my-args ( old-addr len -- )
92: dup IF \ IF len > 0 ( old-addr len )
93: dup alloc-mem \ | allocate space for new args ( old-addr len new-addr )
94: swap 2dup \ | write the new address ( old-addr new-addr len new-addr len )
95: my-self instance>args 2! \ | into the instance table ( old-addr new-addr len )
96: move \ | and copy the args ( -- )
97: ELSE \ ELSE ( old-addr len )
98: my-self instance>args 2! \ | set new args to zero, too ( )
99: THEN \ FI
100: ;
101:
102: \ Current node has already been set, when this is called.
103: : create-instance-data ( -- instance )
104: get-node dup node>instance @ swap node>instance-size @ ( instance instance-size )
105: dup alloc-mem dup >r swap move r>
106: ;
107: : create-instance ( -- )
108: my-self create-instance-data
109: dup to my-self instance>parent !
110: get-node my-self instance>node !
111: ;
112:
113: : destroy-instance ( instance -- )
114: dup @ node>instance-size @ free-mem
115: ;
116:
117: : ihandle>phandle ( ihandle -- phandle )
118: dup 0= ABORT" no current instance" instance>node @
119: ;
120:
121: : push-my-self ( ihandle -- ) r> my-self >r >r to my-self ;
122: : pop-my-self ( -- ) r> r> to my-self >r ;
123: : call-package push-my-self execute pop-my-self ;
124: : $call-static ( ... str len node -- ??? )
125: \ cr ." call for " 3dup -rot type ." on node " .
126: find-method IF execute ELSE -1 throw THEN
127: ;
128: : $call-my-method ( str len -- ) my-self ihandle>phandle $call-static ;
129: : $call-method push-my-self $call-my-method pop-my-self ;
130: : $call-parent my-parent $call-method ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.