xref: /illumos-gate/usr/src/common/ficl/softcore/oo.fr (revision afc2ba1d)
1*afc2ba1dSToomas SoomeS" FICL_WANT_OOP" ENVIRONMENT? drop [if]
2*afc2ba1dSToomas Soome\ ** ficl/softwords/oo.fr
3*afc2ba1dSToomas Soome\ ** F I C L   O - O   E X T E N S I O N S
4*afc2ba1dSToomas Soome\ ** john sadler aug 1998
5*afc2ba1dSToomas Soome
6*afc2ba1dSToomas Soome.( loading ficl O-O extensions ) cr
7*afc2ba1dSToomas Soome17 ficl-vocabulary oop
8*afc2ba1dSToomas Soomealso oop definitions
9*afc2ba1dSToomas Soome
10*afc2ba1dSToomas Soome\ Design goals:
11*afc2ba1dSToomas Soome\ 0. Traditional OOP: late binding by default for safety.
12*afc2ba1dSToomas Soome\    Early binding if you ask for it.
13*afc2ba1dSToomas Soome\ 1. Single inheritance
14*afc2ba1dSToomas Soome\ 2. Object aggregation (has-a relationship)
15*afc2ba1dSToomas Soome\ 3. Support objects in the dictionary and as proxies for
16*afc2ba1dSToomas Soome\    existing structures (by reference):
17*afc2ba1dSToomas Soome\    *** A ficl object can wrap a C struct ***
18*afc2ba1dSToomas Soome\ 4. Separate name-spaces for methods - methods are
19*afc2ba1dSToomas Soome\    only visible in the context of a class / object
20*afc2ba1dSToomas Soome\ 5. Methods can be overridden, and subclasses can add methods.
21*afc2ba1dSToomas Soome\    No limit on number of methods.
22*afc2ba1dSToomas Soome
23*afc2ba1dSToomas Soome\ General info:
24*afc2ba1dSToomas Soome\ Classes are objects, too: all classes are instances of METACLASS
25*afc2ba1dSToomas Soome\ All classes are derived (by convention) from OBJECT. This
26*afc2ba1dSToomas Soome\ base class provides a default initializer and superclass
27*afc2ba1dSToomas Soome\ access method
28*afc2ba1dSToomas Soome
29*afc2ba1dSToomas Soome\ A ficl object binds instance storage (payload) to a class.
30*afc2ba1dSToomas Soome\ object  ( -- instance class )
31*afc2ba1dSToomas Soome\ All objects push their payload address and class address when
32*afc2ba1dSToomas Soome\ executed.
33*afc2ba1dSToomas Soome
34*afc2ba1dSToomas Soome\ A ficl class consists of a parent class pointer, a wordlist
35*afc2ba1dSToomas Soome\ ID for the methods of the class, and a size for the payload
36*afc2ba1dSToomas Soome\ of objects created by the class. A class is an object.
37*afc2ba1dSToomas Soome\ The NEW method creates and initializes an instance of a class.
38*afc2ba1dSToomas Soome\ Classes have this footprint:
39*afc2ba1dSToomas Soome\ cell 0: parent class address
40*afc2ba1dSToomas Soome\ cell 1: wordlist ID
41*afc2ba1dSToomas Soome\ cell 2: size of instance's payload
42*afc2ba1dSToomas Soome
43*afc2ba1dSToomas Soome\ Methods expect an object couple ( instance class )
44*afc2ba1dSToomas Soome\ on the stack. This is by convention - ficl has no way to
45*afc2ba1dSToomas Soome\ police your code to make sure this is always done, but it
46*afc2ba1dSToomas Soome\ happens naturally if you use the facilities presented here.
47*afc2ba1dSToomas Soome\
48*afc2ba1dSToomas Soome\ Overridden methods must maintain the same stack signature as
49*afc2ba1dSToomas Soome\ their predecessors. Ficl has no way of enforcing this, either.
50*afc2ba1dSToomas Soome\
51*afc2ba1dSToomas Soome\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
52*afc2ba1dSToomas Soome\ has an extra field for the vtable method count. Hasvtable declares
53*afc2ba1dSToomas Soome\ refs to vtable classes
54*afc2ba1dSToomas Soome\
55*afc2ba1dSToomas Soome\ Revised Nov 2001 - metaclass debug method now finds only metaclass methods
56*afc2ba1dSToomas Soome\
57*afc2ba1dSToomas Soome\ Planned: Ficl vtable support
58*afc2ba1dSToomas Soome\ Each class has a vtable size parameter
59*afc2ba1dSToomas Soome\ END-CLASS allocates and clears the vtable - then it walks class's method
60*afc2ba1dSToomas Soome\ list and inserts all new methods into table. For each method, if the table
61*afc2ba1dSToomas Soome\ slot is already nonzero, do nothing (overridden method). Otherwise fill
62*afc2ba1dSToomas Soome\ vtable slot. Now do same check for parent class vtable, filling only
63*afc2ba1dSToomas Soome\ empty slots in the new vtable.
64*afc2ba1dSToomas Soome\ Methods are now structured as follows:
65*afc2ba1dSToomas Soome\ - header
66*afc2ba1dSToomas Soome\ - vtable index
67*afc2ba1dSToomas Soome\ - xt
68*afc2ba1dSToomas Soome\ :noname definition for code
69*afc2ba1dSToomas Soome\
70*afc2ba1dSToomas Soome\ : is redefined to check for override, fill in vtable index, increment method
71*afc2ba1dSToomas Soome\ count if not an override, create header and fill in index. Allot code pointer
72*afc2ba1dSToomas Soome\ and run :noname
73*afc2ba1dSToomas Soome\ ; is overridden to fill in xt returned by :noname
74*afc2ba1dSToomas Soome\ --> compiles code to fetch vtable address, offset by index, and execute
75*afc2ba1dSToomas Soome\ => looks up xt in the vtable and compiles it directly
76*afc2ba1dSToomas Soome
77*afc2ba1dSToomas Soome
78*afc2ba1dSToomas Soome
79*afc2ba1dSToomas Soomeuser current-class
80*afc2ba1dSToomas Soome0 current-class !
81*afc2ba1dSToomas Soome
82*afc2ba1dSToomas Soome\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
83*afc2ba1dSToomas Soome\ ** L A T E   B I N D I N G
84*afc2ba1dSToomas Soome\ Compile the method name, and code to find and
85*afc2ba1dSToomas Soome\ execute it at run-time...
86*afc2ba1dSToomas Soome\
87*afc2ba1dSToomas Soome
88*afc2ba1dSToomas Soome\ p a r s e - m e t h o d
89*afc2ba1dSToomas Soome\ compiles a method name so that it pushes
90*afc2ba1dSToomas Soome\ the string base address and count at run-time.
91*afc2ba1dSToomas Soome
92*afc2ba1dSToomas Soome: parse-method  \ name  run: ( -- c-addr u )
93*afc2ba1dSToomas Soome    parse-word
94*afc2ba1dSToomas Soome    postpone sliteral
95*afc2ba1dSToomas Soome; compile-only
96*afc2ba1dSToomas Soome
97*afc2ba1dSToomas Soome
98*afc2ba1dSToomas Soome
99*afc2ba1dSToomas Soome: (lookup-method)  { class 2:name -- class 0 | class xt 1 | class xt -1  }
100*afc2ba1dSToomas Soome    class  name class cell+ @  ( class c-addr u wid )
101*afc2ba1dSToomas Soome    search-wordlist
102*afc2ba1dSToomas Soome;
103*afc2ba1dSToomas Soome
104*afc2ba1dSToomas Soome\ l o o k u p - m e t h o d
105*afc2ba1dSToomas Soome\ takes a counted string method name from the stack (as compiled
106*afc2ba1dSToomas Soome\ by parse-method) and attempts to look this method up in the method list of
107*afc2ba1dSToomas Soome\ the class that's on the stack. If successful, it leaves the class on the stack
108*afc2ba1dSToomas Soome\ and pushes the xt of the method. If not, it aborts with an error message.
109*afc2ba1dSToomas Soome
110*afc2ba1dSToomas Soome: lookup-method  { class 2:name -- class xt }
111*afc2ba1dSToomas Soome    class name (lookup-method)    ( 0 | xt 1 | xt -1 )
112*afc2ba1dSToomas Soome    0= if
113*afc2ba1dSToomas Soome        name type ."  not found in "
114*afc2ba1dSToomas Soome        class body> >name type
115*afc2ba1dSToomas Soome        cr abort
116*afc2ba1dSToomas Soome    endif
117*afc2ba1dSToomas Soome;
118*afc2ba1dSToomas Soome
119*afc2ba1dSToomas Soome: find-method-xt   \ name ( class -- class xt )
120*afc2ba1dSToomas Soome    parse-word lookup-method
121*afc2ba1dSToomas Soome;
122*afc2ba1dSToomas Soome
123*afc2ba1dSToomas Soome: catch-method  ( instance class c-addr u -- <method-signature> exc-flag )
124*afc2ba1dSToomas Soome    lookup-method catch
125*afc2ba1dSToomas Soome;
126*afc2ba1dSToomas Soome
127*afc2ba1dSToomas Soome: exec-method  ( instance class c-addr u -- <method-signature> )
128*afc2ba1dSToomas Soome    lookup-method execute
129*afc2ba1dSToomas Soome;
130*afc2ba1dSToomas Soome
131*afc2ba1dSToomas Soome\ Method lookup operator takes a class-addr and instance-addr
132*afc2ba1dSToomas Soome\ and executes the method from the class's wordlist if
133*afc2ba1dSToomas Soome\ interpreting. If compiling, bind late.
134*afc2ba1dSToomas Soome\
135*afc2ba1dSToomas Soome: -->   ( instance class -- ??? )
136*afc2ba1dSToomas Soome    state @ 0= if
137*afc2ba1dSToomas Soome        find-method-xt execute
138*afc2ba1dSToomas Soome    else
139*afc2ba1dSToomas Soome        parse-method  postpone exec-method
140*afc2ba1dSToomas Soome    endif
141*afc2ba1dSToomas Soome; immediate
142*afc2ba1dSToomas Soome
143*afc2ba1dSToomas Soome\ Method lookup with CATCH in case of exceptions
144*afc2ba1dSToomas Soome: c->   ( instance class -- ?? exc-flag )
145*afc2ba1dSToomas Soome    state @ 0= if
146*afc2ba1dSToomas Soome        find-method-xt catch
147*afc2ba1dSToomas Soome    else
148*afc2ba1dSToomas Soome        parse-method  postpone catch-method
149*afc2ba1dSToomas Soome    endif
150*afc2ba1dSToomas Soome; immediate
151*afc2ba1dSToomas Soome
152*afc2ba1dSToomas Soome\ METHOD  makes global words that do method invocations by late binding
153*afc2ba1dSToomas Soome\ in case you prefer this style (no --> in your code)
154*afc2ba1dSToomas Soome\ Example: everything has next and prev for array access, so...
155*afc2ba1dSToomas Soome\ method next
156*afc2ba1dSToomas Soome\ method prev
157*afc2ba1dSToomas Soome\ my-instance next ( does whatever next does to my-instance by late binding )
158*afc2ba1dSToomas Soome
159*afc2ba1dSToomas Soome: method   create does> body> >name lookup-method execute ;
160*afc2ba1dSToomas Soome
161*afc2ba1dSToomas Soome
162*afc2ba1dSToomas Soome\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
163*afc2ba1dSToomas Soome\ ** E A R L Y   B I N D I N G
164*afc2ba1dSToomas Soome\ Early binding operator compiles code to execute a method
165*afc2ba1dSToomas Soome\ given its class at compile time. Classes are immediate,
166*afc2ba1dSToomas Soome\ so they leave their cell-pair on the stack when compiling.
167*afc2ba1dSToomas Soome\ Example:
168*afc2ba1dSToomas Soome\   : get-wid   metaclass => .wid @ ;
169*afc2ba1dSToomas Soome\ Usage
170*afc2ba1dSToomas Soome\   my-class get-wid  ( -- wid-of-my-class )
171*afc2ba1dSToomas Soome\
172*afc2ba1dSToomas Soome1 ficl-named-wordlist instance-vars
173*afc2ba1dSToomas Soomeinstance-vars dup >search ficl-set-current
174*afc2ba1dSToomas Soome
175*afc2ba1dSToomas Soome: =>   \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
176*afc2ba1dSToomas Soome    drop find-method-xt compile, drop
177*afc2ba1dSToomas Soome; immediate compile-only
178*afc2ba1dSToomas Soome
179*afc2ba1dSToomas Soome: my=>   \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
180*afc2ba1dSToomas Soome    current-class @ dup postpone =>
181*afc2ba1dSToomas Soome; immediate compile-only
182*afc2ba1dSToomas Soome
183*afc2ba1dSToomas Soome\ Problem: my=[ assumes that each method except the last is an obj: member
184*afc2ba1dSToomas Soome\ which contains its class as the first field of its parameter area. The code
185*afc2ba1dSToomas Soome\ detects non-obect members and assumes the class does not change in this case.
186*afc2ba1dSToomas Soome\ This handles methods like index, prev, and next correctly, but does not deal
187*afc2ba1dSToomas Soome\ correctly with CLASS.
188*afc2ba1dSToomas Soome: my=[   \ same as my=> , but binds a chain of methods
189*afc2ba1dSToomas Soome    current-class @
190*afc2ba1dSToomas Soome    begin
191*afc2ba1dSToomas Soome        parse-word 2dup             ( class c-addr u c-addr u )
192*afc2ba1dSToomas Soome        s" ]" compare while         ( class c-addr u )
193*afc2ba1dSToomas Soome        lookup-method               ( class xt )
194*afc2ba1dSToomas Soome        dup compile,                ( class xt )
195*afc2ba1dSToomas Soome        dup ?object if        \ If object member, get new class. Otherwise assume same class
196*afc2ba1dSToomas Soome           nip >body cell+ @        ( new-class )
197*afc2ba1dSToomas Soome        else
198*afc2ba1dSToomas Soome           drop                     ( class )
199*afc2ba1dSToomas Soome        endif
200*afc2ba1dSToomas Soome    repeat 2drop drop
201*afc2ba1dSToomas Soome; immediate compile-only
202*afc2ba1dSToomas Soome
203*afc2ba1dSToomas Soome
204*afc2ba1dSToomas Soome\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
205*afc2ba1dSToomas Soome\ ** I N S T A N C E   V A R I A B L E S
206*afc2ba1dSToomas Soome\ Instance variables (IV) are represented by words in the class's
207*afc2ba1dSToomas Soome\ private wordlist. Each IV word contains the offset
208*afc2ba1dSToomas Soome\ of the IV it represents, and runs code to add that offset
209*afc2ba1dSToomas Soome\ to the base address of an instance when executed.
210*afc2ba1dSToomas Soome\ The metaclass SUB method, defined below, leaves the address
211*afc2ba1dSToomas Soome\ of the new class's offset field and its initial size on the
212*afc2ba1dSToomas Soome\ stack for these words to update. When a class definition is
213*afc2ba1dSToomas Soome\ complete, END-CLASS saves the final size in the class's size
214*afc2ba1dSToomas Soome\ field, and restores the search order and compile wordlist to
215*afc2ba1dSToomas Soome\ prior state. Note that these words are hidden in their own
216*afc2ba1dSToomas Soome\ wordlist to prevent accidental use outside a SUB END-CLASS pair.
217*afc2ba1dSToomas Soome\
218*afc2ba1dSToomas Soome: do-instance-var
219*afc2ba1dSToomas Soome    does>   ( instance class addr[offset] -- addr[field] )
220*afc2ba1dSToomas Soome        nip @ +
221*afc2ba1dSToomas Soome;
222*afc2ba1dSToomas Soome
223*afc2ba1dSToomas Soome: addr-units:  ( offset size "name" -- offset' )
224*afc2ba1dSToomas Soome    create over , +
225*afc2ba1dSToomas Soome    do-instance-var
226*afc2ba1dSToomas Soome;
227*afc2ba1dSToomas Soome
228*afc2ba1dSToomas Soome: chars:    \ ( offset nCells "name" -- offset' ) Create n char member.
229*afc2ba1dSToomas Soome   chars addr-units: ;
230*afc2ba1dSToomas Soome
231*afc2ba1dSToomas Soome: char:     \ ( offset nCells "name" -- offset' ) Create 1 char member.
232*afc2ba1dSToomas Soome   1 chars: ;
233*afc2ba1dSToomas Soome
234*afc2ba1dSToomas Soome: cells:  ( offset nCells "name" -- offset' )
235*afc2ba1dSToomas Soome    cells >r aligned r> addr-units:
236*afc2ba1dSToomas Soome;
237*afc2ba1dSToomas Soome
238*afc2ba1dSToomas Soome: cell:   ( offset nCells "name" -- offset' )
239*afc2ba1dSToomas Soome    1 cells: ;
240*afc2ba1dSToomas Soome
241*afc2ba1dSToomas Soome\ Aggregate an object into the class...
242*afc2ba1dSToomas Soome\ Needs the class of the instance to create
243*afc2ba1dSToomas Soome\ Example: object obj: m_obj
244*afc2ba1dSToomas Soome\
245*afc2ba1dSToomas Soome: do-aggregate
246*afc2ba1dSToomas Soome    objectify
247*afc2ba1dSToomas Soome    does>   ( instance class pfa -- a-instance a-class )
248*afc2ba1dSToomas Soome    2@          ( inst class a-class a-offset )
249*afc2ba1dSToomas Soome    2swap drop  ( a-class a-offset inst )
250*afc2ba1dSToomas Soome    + swap      ( a-inst a-class )
251*afc2ba1dSToomas Soome;
252*afc2ba1dSToomas Soome
253*afc2ba1dSToomas Soome: obj:   { offset class meta -- offset' }  \ "name"
254*afc2ba1dSToomas Soome    create  offset , class ,
255*afc2ba1dSToomas Soome    class meta --> get-size  offset +
256*afc2ba1dSToomas Soome    do-aggregate
257*afc2ba1dSToomas Soome;
258*afc2ba1dSToomas Soome
259*afc2ba1dSToomas Soome\ Aggregate an array of objects into a class
260*afc2ba1dSToomas Soome\ Usage example:
261*afc2ba1dSToomas Soome\ 3 my-class array: my-array
262*afc2ba1dSToomas Soome\ Makes an instance variable array of 3 instances of my-class
263*afc2ba1dSToomas Soome\ named my-array.
264*afc2ba1dSToomas Soome\
265*afc2ba1dSToomas Soome: array:   ( offset n class meta "name" -- offset' )
266*afc2ba1dSToomas Soome    locals| meta class nobjs offset |
267*afc2ba1dSToomas Soome    create offset , class ,
268*afc2ba1dSToomas Soome    class meta --> get-size  nobjs * offset +
269*afc2ba1dSToomas Soome    do-aggregate
270*afc2ba1dSToomas Soome;
271*afc2ba1dSToomas Soome
272*afc2ba1dSToomas Soome\ Aggregate a pointer to an object: REF is a member variable
273*afc2ba1dSToomas Soome\ whose class is set at compile time. This is useful for wrapping
274*afc2ba1dSToomas Soome\ data structures in C, where there is only a pointer and the type
275*afc2ba1dSToomas Soome\ it refers to is known. If you want polymorphism, see c_ref
276*afc2ba1dSToomas Soome\ in classes.fr. REF is only useful for pre-initialized structures,
277*afc2ba1dSToomas Soome\ since there's no supported way to set one.
278*afc2ba1dSToomas Soome: ref:   ( offset class meta "name" -- offset' )
279*afc2ba1dSToomas Soome    locals| meta class offset |
280*afc2ba1dSToomas Soome    create offset , class ,
281*afc2ba1dSToomas Soome    offset cell+
282*afc2ba1dSToomas Soome    does>    ( inst class pfa -- ptr-inst ptr-class )
283*afc2ba1dSToomas Soome    2@       ( inst class ptr-class ptr-offset )
284*afc2ba1dSToomas Soome    2swap drop + @ swap
285*afc2ba1dSToomas Soome;
286*afc2ba1dSToomas Soome
287*afc2ba1dSToomas SoomeS" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
288*afc2ba1dSToomas Soome\ vcall extensions contributed by Guy Carver
289*afc2ba1dSToomas Soome: vcall:  ( paramcnt "name" -- )
290*afc2ba1dSToomas Soome    current-class @ 8 + dup @ dup 1+ rot !  \ Kludge fix to get to .vtCount before it's defined.
291*afc2ba1dSToomas Soome    create , ,                              \ ( paramcnt index -- )
292*afc2ba1dSToomas Soome    does>                                   \ ( inst class pfa -- ptr-inst ptr-class )
293*afc2ba1dSToomas Soome   nip 2@ vcall                             \ ( params offset inst class offset -- )
294*afc2ba1dSToomas Soome;
295*afc2ba1dSToomas Soome
296*afc2ba1dSToomas Soome: vcallr: 0x80000000 or vcall: ;            \ Call with return address desired.
297*afc2ba1dSToomas Soome
298*afc2ba1dSToomas SoomeS" FICL_WANT_FLOAT" ENVIRONMENT? drop [if]
299*afc2ba1dSToomas Soome: vcallf:                                   \ ( paramcnt -<name>- f: r )
300*afc2ba1dSToomas Soome    0x80000000 or
301*afc2ba1dSToomas Soome    current-class @ 8 + dup @ dup 1+ rot !  \ Kludge fix to get to .vtCount before it's defined.
302*afc2ba1dSToomas Soome    create , ,                              \ ( paramcnt index -- )
303*afc2ba1dSToomas Soome    does>                                   \ ( inst class pfa -- ptr-inst ptr-class )
304*afc2ba1dSToomas Soome    nip 2@ vcall f>                         \ ( params offset inst class offset -- f: r )
305*afc2ba1dSToomas Soome;
306*afc2ba1dSToomas Soome
307*afc2ba1dSToomas Soome[endif] \ FICL_WANT_FLOAT
308*afc2ba1dSToomas Soome[endif] \ FICL_WANT_VCALL
309*afc2ba1dSToomas Soome
310*afc2ba1dSToomas Soome\ END-CLASS terminates construction of a class by storing
311*afc2ba1dSToomas Soome\  the size of its instance variables in the class's size field
312*afc2ba1dSToomas Soome\ ( -- old-wid addr[size] 0 )
313*afc2ba1dSToomas Soome\
314*afc2ba1dSToomas Soome: end-class  ( old-wid addr[size] size -- )
315*afc2ba1dSToomas Soome    swap ! set-current
316*afc2ba1dSToomas Soome    search> drop        \ pop struct builder wordlist
317*afc2ba1dSToomas Soome;
318*afc2ba1dSToomas Soome
319*afc2ba1dSToomas Soome\ See resume-class (a metaclass method) below for usage
320*afc2ba1dSToomas Soome\ This is equivalent to end-class for now, but that will change
321*afc2ba1dSToomas Soome\ when we support vtable bindings.
322*afc2ba1dSToomas Soome: suspend-class  ( old-wid addr[size] size -- )   end-class ;
323*afc2ba1dSToomas Soome
324*afc2ba1dSToomas Soomeset-current previous
325*afc2ba1dSToomas Soome\ E N D   I N S T A N C E   V A R I A B L E S
326*afc2ba1dSToomas Soome
327*afc2ba1dSToomas Soome
328*afc2ba1dSToomas Soome\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
329*afc2ba1dSToomas Soome\ D O - D O - I N S T A N C E
330*afc2ba1dSToomas Soome\ Makes a class method that contains the code for an
331*afc2ba1dSToomas Soome\ instance of the class. This word gets compiled into
332*afc2ba1dSToomas Soome\ the wordlist of every class by the SUB method.
333*afc2ba1dSToomas Soome\ PRECONDITION: current-class contains the class address
334*afc2ba1dSToomas Soome\ why use a state variable instead of the stack?
335*afc2ba1dSToomas Soome\ >> Stack state is not well-defined during compilation (there are
336*afc2ba1dSToomas Soome\ >> control structure match codes on the stack, of undefined size
337*afc2ba1dSToomas Soome\ >> easiest way around this is use of this thread-local variable
338*afc2ba1dSToomas Soome\
339*afc2ba1dSToomas Soome: do-do-instance  ( -- )
340*afc2ba1dSToomas Soome    s" : .do-instance does> [ current-class @ ] literal ;"
341*afc2ba1dSToomas Soome    evaluate
342*afc2ba1dSToomas Soome;
343*afc2ba1dSToomas Soome
344*afc2ba1dSToomas Soome\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
345*afc2ba1dSToomas Soome\ ** M E T A C L A S S
346*afc2ba1dSToomas Soome\ Every class is an instance of metaclass. This lets
347*afc2ba1dSToomas Soome\ classes have methods that are different from those
348*afc2ba1dSToomas Soome\ of their instances.
349*afc2ba1dSToomas Soome\ Classes are IMMEDIATE to make early binding simpler
350*afc2ba1dSToomas Soome\ See above...
351*afc2ba1dSToomas Soome\
352*afc2ba1dSToomas Soome:noname
353*afc2ba1dSToomas Soome    wordlist
354*afc2ba1dSToomas Soome    create
355*afc2ba1dSToomas Soome    immediate
356*afc2ba1dSToomas Soome    0       ,   \ NULL parent class
357*afc2ba1dSToomas Soome    dup     ,   \ wid
358*afc2ba1dSToomas Soome[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
359*afc2ba1dSToomas Soome    4 cells ,   \ instance size
360*afc2ba1dSToomas Soome[else]
361*afc2ba1dSToomas Soome    3 cells ,   \ instance size
362*afc2ba1dSToomas Soome[endif]
363*afc2ba1dSToomas Soome    ficl-set-current
364*afc2ba1dSToomas Soome    does> dup
365*afc2ba1dSToomas Soome;  execute metaclass
366*afc2ba1dSToomas Soome\ now brand OBJECT's wordlist (so that ORDER can display it by name)
367*afc2ba1dSToomas Soomemetaclass drop cell+ @ brand-wordlist
368*afc2ba1dSToomas Soome
369*afc2ba1dSToomas Soomemetaclass drop current-class !
370*afc2ba1dSToomas Soomedo-do-instance
371*afc2ba1dSToomas Soome
372*afc2ba1dSToomas Soome\
373*afc2ba1dSToomas Soome\ C L A S S   M E T H O D S
374*afc2ba1dSToomas Soome\
375*afc2ba1dSToomas Soomeinstance-vars >search
376*afc2ba1dSToomas Soome
377*afc2ba1dSToomas Soomecreate .super  ( class metaclass -- parent-class )
378*afc2ba1dSToomas Soome    0 cells , do-instance-var
379*afc2ba1dSToomas Soome
380*afc2ba1dSToomas Soomecreate .wid    ( class metaclass -- wid ) \ return wid of class
381*afc2ba1dSToomas Soome    1 cells , do-instance-var
382*afc2ba1dSToomas Soome
383*afc2ba1dSToomas SoomeS" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
384*afc2ba1dSToomas Soomecreate .vtCount   \ Number of VTABLE methods, if any
385*afc2ba1dSToomas Soome    2 cells , do-instance-var
386*afc2ba1dSToomas Soome
387*afc2ba1dSToomas Soomecreate  .size  ( class metaclass -- size ) \ return class's payload size
388*afc2ba1dSToomas Soome    3 cells , do-instance-var
389*afc2ba1dSToomas Soome
390*afc2ba1dSToomas Soome[else]
391*afc2ba1dSToomas Soome
392*afc2ba1dSToomas Soomecreate  .size  ( class metaclass -- size ) \ return class's payload size
393*afc2ba1dSToomas Soome    2 cells , do-instance-var
394*afc2ba1dSToomas Soome
395*afc2ba1dSToomas Soome[endif]
396*afc2ba1dSToomas Soome
397*afc2ba1dSToomas Soome: get-size    metaclass => .size  @ ;
398*afc2ba1dSToomas Soome: get-wid     metaclass => .wid   @ ;
399*afc2ba1dSToomas Soome: get-super   metaclass => .super @ ;
400*afc2ba1dSToomas SoomeS" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
401*afc2ba1dSToomas Soome: get-vtCount metaclass => .vtCount @ ;
402*afc2ba1dSToomas Soome: get-vtAdd   metaclass => .vtCount ;
403*afc2ba1dSToomas Soome[endif]
404*afc2ba1dSToomas Soome
405*afc2ba1dSToomas Soome\ create an uninitialized instance of a class, leaving
406*afc2ba1dSToomas Soome\ the address of the new instance and its class
407*afc2ba1dSToomas Soome\
408*afc2ba1dSToomas Soome: instance   ( class metaclass "name" -- instance class )
409*afc2ba1dSToomas Soome    locals| meta parent |
410*afc2ba1dSToomas Soome    create
411*afc2ba1dSToomas Soome    here parent --> .do-instance \ ( inst class )
412*afc2ba1dSToomas Soome    parent meta metaclass => get-size
413*afc2ba1dSToomas Soome    allot                        \ allocate payload space
414*afc2ba1dSToomas Soome;
415*afc2ba1dSToomas Soome
416*afc2ba1dSToomas Soome\ create an uninitialized array
417*afc2ba1dSToomas Soome: array   ( n class metaclass "name" -- n instance class )
418*afc2ba1dSToomas Soome    locals| meta parent nobj |
419*afc2ba1dSToomas Soome    create  nobj
420*afc2ba1dSToomas Soome    here parent --> .do-instance \ ( nobj inst class )
421*afc2ba1dSToomas Soome    parent meta metaclass => get-size
422*afc2ba1dSToomas Soome    nobj *  allot           \ allocate payload space
423*afc2ba1dSToomas Soome;
424*afc2ba1dSToomas Soome
425*afc2ba1dSToomas Soome\ create an initialized instance
426*afc2ba1dSToomas Soome\
427*afc2ba1dSToomas Soome: new   \ ( class metaclass "name" -- )
428*afc2ba1dSToomas Soome    metaclass => instance --> init
429*afc2ba1dSToomas Soome;
430*afc2ba1dSToomas Soome
431*afc2ba1dSToomas Soome\ create an initialized array of instances
432*afc2ba1dSToomas Soome: new-array   ( n class metaclass "name" -- )
433*afc2ba1dSToomas Soome    metaclass => array
434*afc2ba1dSToomas Soome    --> array-init
435*afc2ba1dSToomas Soome;
436*afc2ba1dSToomas Soome
437*afc2ba1dSToomas Soome\ Create an anonymous initialized instance from the heap
438*afc2ba1dSToomas Soome: alloc   \ ( class metaclass -- instance class )
439*afc2ba1dSToomas Soome    locals| meta class |
440*afc2ba1dSToomas Soome    class meta metaclass => get-size allocate   ( -- addr fail-flag )
441*afc2ba1dSToomas Soome    abort" allocate failed "                    ( -- addr )
442*afc2ba1dSToomas Soome    class 2dup --> init
443*afc2ba1dSToomas Soome;
444*afc2ba1dSToomas Soome
445*afc2ba1dSToomas Soome\ Create an anonymous array of initialized instances from the heap
446*afc2ba1dSToomas Soome: alloc-array   \ ( n class metaclass -- instance class )
447*afc2ba1dSToomas Soome    locals| meta class nobj |
448*afc2ba1dSToomas Soome    class meta metaclass => get-size
449*afc2ba1dSToomas Soome    nobj * allocate                 ( -- addr fail-flag )
450*afc2ba1dSToomas Soome    abort" allocate failed "        ( -- addr )
451*afc2ba1dSToomas Soome    nobj over class --> array-init
452*afc2ba1dSToomas Soome    class
453*afc2ba1dSToomas Soome;
454*afc2ba1dSToomas Soome
455*afc2ba1dSToomas Soome\ Create an anonymous initialized instance from the dictionary
456*afc2ba1dSToomas Soome: allot   { 2:this -- 2:instance }
457*afc2ba1dSToomas Soome    here   ( instance-address )
458*afc2ba1dSToomas Soome    this my=> get-size  allot
459*afc2ba1dSToomas Soome    this drop 2dup --> init
460*afc2ba1dSToomas Soome;
461*afc2ba1dSToomas Soome
462*afc2ba1dSToomas Soome\ Create an anonymous array of initialized instances from the dictionary
463*afc2ba1dSToomas Soome: allot-array   { nobj 2:this -- 2:instance }
464*afc2ba1dSToomas Soome    here   ( instance-address )
465*afc2ba1dSToomas Soome    this my=> get-size  nobj * allot
466*afc2ba1dSToomas Soome    this drop 2dup     ( 2instance 2instance )
467*afc2ba1dSToomas Soome    nobj -rot --> array-init
468*afc2ba1dSToomas Soome;
469*afc2ba1dSToomas Soome
470*afc2ba1dSToomas Soome\ create a proxy object with initialized payload address given
471*afc2ba1dSToomas Soome: ref   ( instance-addr class metaclass "name" -- )
472*afc2ba1dSToomas Soome    drop create , ,
473*afc2ba1dSToomas Soome    does> 2@
474*afc2ba1dSToomas Soome;
475*afc2ba1dSToomas Soome
476*afc2ba1dSToomas Soome\ suspend-class and resume-class help to build mutually referent classes.
477*afc2ba1dSToomas Soome\ Example:
478*afc2ba1dSToomas Soome\ object subclass c-akbar
479*afc2ba1dSToomas Soome\ suspend-class   ( put akbar on hold while we define jeff )
480*afc2ba1dSToomas Soome\ object subclass c-jeff
481*afc2ba1dSToomas Soome\     c-akbar ref: .akbar
482*afc2ba1dSToomas Soome\     ( and whatever else comprises this class )
483*afc2ba1dSToomas Soome\ end-class    ( done with c-jeff )
484*afc2ba1dSToomas Soome\ c-akbar --> resume-class
485*afc2ba1dSToomas Soome\     c-jeff ref: .jeff
486*afc2ba1dSToomas Soome\     ( and whatever else goes in c-akbar )
487*afc2ba1dSToomas Soome\ end-class    ( done with c-akbar )
488*afc2ba1dSToomas Soome\
489*afc2ba1dSToomas Soome: resume-class   { 2:this -- old-wid addr[size] size }
490*afc2ba1dSToomas Soome    this --> .wid @ ficl-set-current  ( old-wid )
491*afc2ba1dSToomas Soome    this --> .size dup @   ( old-wid addr[size] size )
492*afc2ba1dSToomas Soome    instance-vars >search
493*afc2ba1dSToomas Soome;
494*afc2ba1dSToomas Soome
495*afc2ba1dSToomas Soome\ create a subclass
496*afc2ba1dSToomas Soome\ This method leaves the stack and search order ready for instance variable
497*afc2ba1dSToomas Soome\ building. Pushes the instance-vars wordlist onto the search order,
498*afc2ba1dSToomas Soome\ and sets the compilation wordlist to be the private wordlist of the
499*afc2ba1dSToomas Soome\ new class. The class's wordlist is deliberately NOT in the search order -
500*afc2ba1dSToomas Soome\ to prevent methods from getting used with wrong data.
501*afc2ba1dSToomas Soome\ Postcondition: leaves the address of the new class in current-class
502*afc2ba1dSToomas Soome: sub   ( class metaclass "name" -- old-wid addr[size] size )
503*afc2ba1dSToomas Soome    wordlist
504*afc2ba1dSToomas Soome    locals| wid meta parent |
505*afc2ba1dSToomas Soome    parent meta metaclass => get-wid
506*afc2ba1dSToomas Soome    wid wid-set-super       \ set superclass
507*afc2ba1dSToomas Soome    create  immediate       \ get the  subclass name
508*afc2ba1dSToomas Soome    wid brand-wordlist      \ label the subclass wordlist
509*afc2ba1dSToomas Soome    here current-class !    \ prep for do-do-instance
510*afc2ba1dSToomas Soome    parent ,                \ save parent class
511*afc2ba1dSToomas Soome    wid    ,                \ save wid
512*afc2ba1dSToomas Soome[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
513*afc2ba1dSToomas Soome    parent meta --> get-vtCount ,
514*afc2ba1dSToomas Soome[endif]
515*afc2ba1dSToomas Soome    here parent meta --> get-size dup ,  ( addr[size] size )
516*afc2ba1dSToomas Soome    metaclass => .do-instance
517*afc2ba1dSToomas Soome    wid ficl-set-current -rot
518*afc2ba1dSToomas Soome    do-do-instance
519*afc2ba1dSToomas Soome    instance-vars >search \ push struct builder wordlist
520*afc2ba1dSToomas Soome;
521*afc2ba1dSToomas Soome
522*afc2ba1dSToomas Soome\ OFFSET-OF returns the offset of an instance variable
523*afc2ba1dSToomas Soome\ from the instance base address. If the next token is not
524*afc2ba1dSToomas Soome\ the name of in instance variable method, you get garbage
525*afc2ba1dSToomas Soome\ results -- there is no way at present to check for this error.
526*afc2ba1dSToomas Soome: offset-of   ( class metaclass "name" -- offset )
527*afc2ba1dSToomas Soome    drop find-method-xt nip >body @ ;
528*afc2ba1dSToomas Soome
529*afc2ba1dSToomas Soome\ ID returns the string name cell-pair of its class
530*afc2ba1dSToomas Soome: id   ( class metaclass -- c-addr u )
531*afc2ba1dSToomas Soome    drop body> >name  ;
532*afc2ba1dSToomas Soome
533*afc2ba1dSToomas Soome\ list methods of the class
534*afc2ba1dSToomas Soome: methods \ ( class meta -- )
535*afc2ba1dSToomas Soome    locals| meta class |
536*afc2ba1dSToomas Soome    begin
537*afc2ba1dSToomas Soome        class body> >name type ."  methods:" cr
538*afc2ba1dSToomas Soome        class meta --> get-wid >search words cr previous
539*afc2ba1dSToomas Soome        class meta metaclass => get-super
540*afc2ba1dSToomas Soome        dup to class
541*afc2ba1dSToomas Soome    0= until  cr
542*afc2ba1dSToomas Soome;
543*afc2ba1dSToomas Soome
544*afc2ba1dSToomas Soome\ list class's ancestors
545*afc2ba1dSToomas Soome: pedigree  ( class meta -- )
546*afc2ba1dSToomas Soome    locals| meta class |
547*afc2ba1dSToomas Soome    begin
548*afc2ba1dSToomas Soome        class body> >name type space
549*afc2ba1dSToomas Soome        class meta metaclass => get-super
550*afc2ba1dSToomas Soome        dup to class
551*afc2ba1dSToomas Soome    0= until  cr
552*afc2ba1dSToomas Soome;
553*afc2ba1dSToomas Soome
554*afc2ba1dSToomas Soome\ decompile an instance method
555*afc2ba1dSToomas Soome: see  ( class meta -- )
556*afc2ba1dSToomas Soome    metaclass => get-wid >search see previous ;
557*afc2ba1dSToomas Soome
558*afc2ba1dSToomas Soome\ debug a method of metaclass
559*afc2ba1dSToomas Soome\ Eg: my-class --> debug my-method
560*afc2ba1dSToomas Soome: debug  ( class meta -- )
561*afc2ba1dSToomas Soome	find-method-xt debug-xt ;
562*afc2ba1dSToomas Soome
563*afc2ba1dSToomas Soomeprevious set-current
564*afc2ba1dSToomas Soome\ E N D   M E T A C L A S S
565*afc2ba1dSToomas Soome
566*afc2ba1dSToomas Soome\ ** META is a nickname for the address of METACLASS...
567*afc2ba1dSToomas Soomemetaclass drop
568*afc2ba1dSToomas Soomeconstant meta
569*afc2ba1dSToomas Soome
570*afc2ba1dSToomas Soome\ ** SUBCLASS is a nickname for a class's SUB method...
571*afc2ba1dSToomas Soome\ Subclass compilation ends when you invoke end-class
572*afc2ba1dSToomas Soome\ This method is late bound for safety...
573*afc2ba1dSToomas Soome: subclass   --> sub ;
574*afc2ba1dSToomas Soome
575*afc2ba1dSToomas SoomeS" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
576*afc2ba1dSToomas Soome\ VTABLE Support extensions (Guy Carver)
577*afc2ba1dSToomas Soome\ object --> sub mine hasvtable
578*afc2ba1dSToomas Soome: hasvtable 4 + ; immediate
579*afc2ba1dSToomas Soome[endif]
580*afc2ba1dSToomas Soome
581*afc2ba1dSToomas Soome
582*afc2ba1dSToomas Soome\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
583*afc2ba1dSToomas Soome\ ** O B J E C T
584*afc2ba1dSToomas Soome\ Root of all classes
585*afc2ba1dSToomas Soome:noname
586*afc2ba1dSToomas Soome    wordlist
587*afc2ba1dSToomas Soome    create  immediate
588*afc2ba1dSToomas Soome    0       ,   \ NULL parent class
589*afc2ba1dSToomas Soome    dup     ,   \ wid
590*afc2ba1dSToomas Soome    0       ,   \ instance size
591*afc2ba1dSToomas Soome[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
592*afc2ba1dSToomas Soome    0       ,   \ .vtCount
593*afc2ba1dSToomas Soome[endif]
594*afc2ba1dSToomas Soome    ficl-set-current
595*afc2ba1dSToomas Soome    does> meta
596*afc2ba1dSToomas Soome;  execute object
597*afc2ba1dSToomas Soome\ now brand OBJECT's wordlist (so that ORDER can display it by name)
598*afc2ba1dSToomas Soomeobject drop cell+ @ brand-wordlist
599*afc2ba1dSToomas Soome
600*afc2ba1dSToomas Soomeobject drop current-class !
601*afc2ba1dSToomas Soomedo-do-instance
602*afc2ba1dSToomas Soomeinstance-vars >search
603*afc2ba1dSToomas Soome
604*afc2ba1dSToomas Soome\ O B J E C T   M E T H O D S
605*afc2ba1dSToomas Soome\ Convert instance cell-pair to class cell-pair
606*afc2ba1dSToomas Soome\ Useful for binding class methods from an instance
607*afc2ba1dSToomas Soome: class  ( instance class -- class metaclass )
608*afc2ba1dSToomas Soome    nip meta ;
609*afc2ba1dSToomas Soome
610*afc2ba1dSToomas Soome\ default INIT method zero fills an instance
611*afc2ba1dSToomas Soome: init   ( instance class -- )
612*afc2ba1dSToomas Soome    meta
613*afc2ba1dSToomas Soome    metaclass => get-size   ( inst size )
614*afc2ba1dSToomas Soome    erase ;
615*afc2ba1dSToomas Soome
616*afc2ba1dSToomas Soome\ Apply INIT to an array of NOBJ objects...
617*afc2ba1dSToomas Soome\
618*afc2ba1dSToomas Soome: array-init   ( nobj inst class -- )
619*afc2ba1dSToomas Soome    0 dup locals| &init &next class inst |
620*afc2ba1dSToomas Soome    \
621*afc2ba1dSToomas Soome    \ bind methods outside the loop to save time
622*afc2ba1dSToomas Soome    \
623*afc2ba1dSToomas Soome    class s" init" lookup-method to &init
624*afc2ba1dSToomas Soome          s" next" lookup-method to &next
625*afc2ba1dSToomas Soome    drop
626*afc2ba1dSToomas Soome    0 ?do
627*afc2ba1dSToomas Soome        inst class 2dup
628*afc2ba1dSToomas Soome        &init execute
629*afc2ba1dSToomas Soome        &next execute  drop to inst
630*afc2ba1dSToomas Soome    loop
631*afc2ba1dSToomas Soome;
632*afc2ba1dSToomas Soome
633*afc2ba1dSToomas Soome\ free storage allocated to a heap instance by alloc or alloc-array
634*afc2ba1dSToomas Soome\ NOTE: not protected against errors like FREEing something that's
635*afc2ba1dSToomas Soome\ really in the dictionary.
636*afc2ba1dSToomas Soome: free   \ ( instance class -- )
637*afc2ba1dSToomas Soome    drop free
638*afc2ba1dSToomas Soome    abort" free failed "
639*afc2ba1dSToomas Soome;
640*afc2ba1dSToomas Soome
641*afc2ba1dSToomas Soome\ Instance aliases for common class methods
642*afc2ba1dSToomas Soome\ Upcast to parent class
643*afc2ba1dSToomas Soome: super     ( instance class -- instance parent-class )
644*afc2ba1dSToomas Soome    meta  metaclass => get-super ;
645*afc2ba1dSToomas Soome
646*afc2ba1dSToomas Soome: pedigree  ( instance class -- )
647*afc2ba1dSToomas Soome    object => class
648*afc2ba1dSToomas Soome    metaclass => pedigree ;
649*afc2ba1dSToomas Soome
650*afc2ba1dSToomas Soome: size      ( instance class -- sizeof-instance )
651*afc2ba1dSToomas Soome    object => class
652*afc2ba1dSToomas Soome    metaclass => get-size ;
653*afc2ba1dSToomas Soome
654*afc2ba1dSToomas Soome: methods   ( instance class -- )
655*afc2ba1dSToomas Soome    object => class
656*afc2ba1dSToomas Soome    metaclass => methods ;
657*afc2ba1dSToomas Soome
658*afc2ba1dSToomas Soome\ Array indexing methods...
659*afc2ba1dSToomas Soome\ Usage examples:
660*afc2ba1dSToomas Soome\ 10 object-array --> index
661*afc2ba1dSToomas Soome\ obj --> next
662*afc2ba1dSToomas Soome\
663*afc2ba1dSToomas Soome: index   ( n instance class -- instance[n] class )
664*afc2ba1dSToomas Soome    locals| class inst |
665*afc2ba1dSToomas Soome    inst class
666*afc2ba1dSToomas Soome    object => class
667*afc2ba1dSToomas Soome    metaclass => get-size  *   ( n*size )
668*afc2ba1dSToomas Soome    inst +  class ;
669*afc2ba1dSToomas Soome
670*afc2ba1dSToomas Soome: next   ( instance[n] class -- instance[n+1] class )
671*afc2ba1dSToomas Soome    locals| class inst |
672*afc2ba1dSToomas Soome    inst class
673*afc2ba1dSToomas Soome    object => class
674*afc2ba1dSToomas Soome    metaclass => get-size
675*afc2ba1dSToomas Soome    inst +
676*afc2ba1dSToomas Soome    class ;
677*afc2ba1dSToomas Soome
678*afc2ba1dSToomas Soome: prev   ( instance[n] class -- instance[n-1] class )
679*afc2ba1dSToomas Soome    locals| class inst |
680*afc2ba1dSToomas Soome    inst class
681*afc2ba1dSToomas Soome    object => class
682*afc2ba1dSToomas Soome    metaclass => get-size
683*afc2ba1dSToomas Soome    inst swap -
684*afc2ba1dSToomas Soome    class ;
685*afc2ba1dSToomas Soome
686*afc2ba1dSToomas Soome: debug   ( 2this --  ?? )
687*afc2ba1dSToomas Soome    find-method-xt debug-xt ;
688*afc2ba1dSToomas Soome
689*afc2ba1dSToomas Soomeprevious set-current
690*afc2ba1dSToomas Soome\ E N D   O B J E C T
691*afc2ba1dSToomas Soome
692*afc2ba1dSToomas Soome\ reset to default search order
693*afc2ba1dSToomas Soomeonly definitions
694*afc2ba1dSToomas Soome
695*afc2ba1dSToomas Soome\ redefine oop in default search order to put OOP words in the search order and make them
696*afc2ba1dSToomas Soome\ the compiling wordlist...
697*afc2ba1dSToomas Soome
698*afc2ba1dSToomas Soome: oo   only also oop definitions ;
699*afc2ba1dSToomas Soome
700*afc2ba1dSToomas Soome[endif]