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