oo.fr revision 94290
176116Sdcs\ #if FICL_WANT_OOP 240843Smsmith\ ** ficl/softwords/oo.fr 340843Smsmith\ ** F I C L O - O E X T E N S I O N S 440843Smsmith\ ** john sadler aug 1998 560959Sdcs\ 660959Sdcs\ $FreeBSD: head/sys/boot/ficl/softwords/oo.fr 94290 2002-04-09 17:45:28Z dcs $ 740843Smsmith 876116Sdcs17 ficl-vocabulary oop 940843Smsmithalso oop definitions 1040843Smsmith 1140843Smsmith\ Design goals: 1240843Smsmith\ 0. Traditional OOP: late binding by default for safety. 1340843Smsmith\ Early binding if you ask for it. 1440843Smsmith\ 1. Single inheritance 1540843Smsmith\ 2. Object aggregation (has-a relationship) 1640843Smsmith\ 3. Support objects in the dictionary and as proxies for 1740843Smsmith\ existing structures (by reference): 1840843Smsmith\ *** A ficl object can wrap a C struct *** 1940843Smsmith\ 4. Separate name-spaces for methods - methods are 2040843Smsmith\ only visible in the context of a class / object 2140843Smsmith\ 5. Methods can be overridden, and subclasses can add methods. 2240843Smsmith\ No limit on number of methods. 2340843Smsmith 2440843Smsmith\ General info: 2540843Smsmith\ Classes are objects, too: all classes are instances of METACLASS 2640843Smsmith\ All classes are derived (by convention) from OBJECT. This 2740843Smsmith\ base class provides a default initializer and superclass 2840843Smsmith\ access method 2940843Smsmith 3040843Smsmith\ A ficl object binds instance storage (payload) to a class. 3140843Smsmith\ object ( -- instance class ) 3240843Smsmith\ All objects push their payload address and class address when 3394290Sdcs\ executed. 3440843Smsmith 3540843Smsmith\ A ficl class consists of a parent class pointer, a wordlist 3640843Smsmith\ ID for the methods of the class, and a size for the payload 3740843Smsmith\ of objects created by the class. A class is an object. 3840843Smsmith\ The NEW method creates and initializes an instance of a class. 3940843Smsmith\ Classes have this footprint: 4040843Smsmith\ cell 0: parent class address 4140843Smsmith\ cell 1: wordlist ID 4240843Smsmith\ cell 2: size of instance's payload 4340843Smsmith 4440843Smsmith\ Methods expect an object couple ( instance class ) 4594290Sdcs\ on the stack. This is by convention - ficl has no way to 4694290Sdcs\ police your code to make sure this is always done, but it 4794290Sdcs\ happens naturally if you use the facilities presented here. 4894290Sdcs\ 4940843Smsmith\ Overridden methods must maintain the same stack signature as 5094290Sdcs\ their predecessors. Ficl has no way of enforcing this, either. 5194290Sdcs\ 5294290Sdcs\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now 5394290Sdcs\ has an extra field for the vtable method count. Hasvtable declares 5494290Sdcs\ refs to vtable classes 5594290Sdcs\ 5694290Sdcs\ Revised Nov 2001 - metaclass debug method now finds only metaclass methods 5794290Sdcs\ 5894290Sdcs\ Planned: Ficl vtable support 5994290Sdcs\ Each class has a vtable size parameter 6094290Sdcs\ END-CLASS allocates and clears the vtable - then it walks class's method 6194290Sdcs\ list and inserts all new methods into table. For each method, if the table 6294290Sdcs\ slot is already nonzero, do nothing (overridden method). Otherwise fill 6394290Sdcs\ vtable slot. Now do same check for parent class vtable, filling only 6494290Sdcs\ empty slots in the new vtable. 6594290Sdcs\ Methods are now structured as follows: 6694290Sdcs\ - header 6794290Sdcs\ - vtable index 6894290Sdcs\ - xt 6994290Sdcs\ :noname definition for code 7094290Sdcs\ 7194290Sdcs\ : is redefined to check for override, fill in vtable index, increment method 7294290Sdcs\ count if not an override, create header and fill in index. Allot code pointer 7394290Sdcs\ and run :noname 7494290Sdcs\ ; is overridden to fill in xt returned by :noname 7594290Sdcs\ --> compiles code to fetch vtable address, offset by index, and execute 7694290Sdcs\ => looks up xt in the vtable and compiles it directly 7740843Smsmith 7894290Sdcs 7994290Sdcs 8040843Smsmithuser current-class 8140843Smsmith0 current-class ! 8240843Smsmith 8340843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 8440843Smsmith\ ** L A T E B I N D I N G 8540843Smsmith\ Compile the method name, and code to find and 8640843Smsmith\ execute it at run-time... 8740843Smsmith\ 8876116Sdcs 8976116Sdcshide 9076116Sdcs 9194290Sdcs\ p a r s e - m e t h o d 9294290Sdcs\ compiles a method name so that it pushes 9394290Sdcs\ the string base address and count at run-time. 9494290Sdcs 9540843Smsmith: parse-method \ name run: ( -- c-addr u ) 9640843Smsmith parse-word 9794290Sdcs postpone sliteral 9840843Smsmith; compile-only 9940843Smsmith 10094290Sdcs\ l o o k u p - m e t h o d 10194290Sdcs\ takes a counted string method name from the stack (as compiled 10294290Sdcs\ by parse-method) and attempts to look this method up in the method list of 10394290Sdcs\ the class that's on the stack. If successful, it leaves the class on the stack 10494290Sdcs\ and pushes the xt of the method. If not, it aborts with an error message. 10594290Sdcs 10676116Sdcs: lookup-method { class 2:name -- class xt } 10794290Sdcs name class cell+ @ ( c-addr u wid ) 10894290Sdcs search-wordlist ( 0 | xt 1 | xt -1 ) 10994290Sdcs 0= if 11094290Sdcs name type ." not found in " 11176116Sdcs class body> >name type 11240843Smsmith cr abort 11394290Sdcs endif 11476116Sdcs class swap 11540843Smsmith; 11640843Smsmith 11740843Smsmith: find-method-xt \ name ( class -- class xt ) 11894290Sdcs parse-word lookup-method 11940843Smsmith; 12040843Smsmith 12176116Sdcsset-current ( stop hiding definitions ) 12240843Smsmith 12376116Sdcs: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) 12476116Sdcs lookup-method catch 12576116Sdcs; 12676116Sdcs 12776116Sdcs: exec-method ( instance class c-addr u -- <method-signature> ) 12876116Sdcs lookup-method execute 12976116Sdcs; 13076116Sdcs 13140843Smsmith\ Method lookup operator takes a class-addr and instance-addr 13240843Smsmith\ and executes the method from the class's wordlist if 13340843Smsmith\ interpreting. If compiling, bind late. 13440843Smsmith\ 13540843Smsmith: --> ( instance class -- ??? ) 13640843Smsmith state @ 0= if 13794290Sdcs find-method-xt execute 13840843Smsmith else 13994290Sdcs parse-method postpone exec-method 14040843Smsmith endif 14140843Smsmith; immediate 14240843Smsmith 14376116Sdcs\ Method lookup with CATCH in case of exceptions 14476116Sdcs: c-> ( instance class -- ?? exc-flag ) 14576116Sdcs state @ 0= if 14694290Sdcs find-method-xt catch 14776116Sdcs else 14894290Sdcs parse-method postpone catch-method 14976116Sdcs endif 15076116Sdcs; immediate 15140843Smsmith 15276116Sdcs\ METHOD makes global words that do method invocations by late binding 15376116Sdcs\ in case you prefer this style (no --> in your code) 15494290Sdcs\ Example: everything has next and prev for array access, so... 15594290Sdcs\ method next 15694290Sdcs\ method prev 15794290Sdcs\ my-instance next ( does whatever next does to my-instance by late binding ) 15894290Sdcs 15976116Sdcs: method create does> body> >name lookup-method execute ; 16076116Sdcs 16176116Sdcs 16240843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 16340843Smsmith\ ** E A R L Y B I N D I N G 16440843Smsmith\ Early binding operator compiles code to execute a method 16540843Smsmith\ given its class at compile time. Classes are immediate, 16640843Smsmith\ so they leave their cell-pair on the stack when compiling. 16740843Smsmith\ Example: 16840843Smsmith\ : get-wid metaclass => .wid @ ; 16940843Smsmith\ Usage 17040843Smsmith\ my-class get-wid ( -- wid-of-my-class ) 17140843Smsmith\ 17276116Sdcs1 ficl-named-wordlist instance-vars 17376116Sdcsinstance-vars dup >search ficl-set-current 17476116Sdcs 17540843Smsmith: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 17694290Sdcs drop find-method-xt compile, drop 17740843Smsmith; immediate compile-only 17840843Smsmith 17976116Sdcs: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class 18076116Sdcs current-class @ dup postpone => 18176116Sdcs; immediate compile-only 18240843Smsmith 18394290Sdcs\ Problem: my=[ assumes that each method except the last is am obj: member 18494290Sdcs\ which contains its class as the first field of its parameter area. The code 18594290Sdcs\ detects non-obect members and assumes the class does not change in this case. 18694290Sdcs\ This handles methods like index, prev, and next correctly, but does not deal 18794290Sdcs\ correctly with CLASS. 18876116Sdcs: my=[ \ same as my=> , but binds a chain of methods 18976116Sdcs current-class @ 19076116Sdcs begin 19194290Sdcs parse-word 2dup ( class c-addr u c-addr u ) 19294290Sdcs s" ]" compare while ( class c-addr u ) 19394290Sdcs lookup-method ( class xt ) 19494290Sdcs dup compile, ( class xt ) 19594290Sdcs dup ?object if \ If object member, get new class. Otherwise assume same class 19694290Sdcs nip >body cell+ @ ( new-class ) 19794290Sdcs else 19894290Sdcs drop ( class ) 19994290Sdcs endif 20076116Sdcs repeat 2drop drop 20176116Sdcs; immediate compile-only 20276116Sdcs 20376116Sdcs 20440843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 20540843Smsmith\ ** I N S T A N C E V A R I A B L E S 20640843Smsmith\ Instance variables (IV) are represented by words in the class's 20740843Smsmith\ private wordlist. Each IV word contains the offset 20840843Smsmith\ of the IV it represents, and runs code to add that offset 20940843Smsmith\ to the base address of an instance when executed. 21040843Smsmith\ The metaclass SUB method, defined below, leaves the address 21140843Smsmith\ of the new class's offset field and its initial size on the 21240843Smsmith\ stack for these words to update. When a class definition is 21340843Smsmith\ complete, END-CLASS saves the final size in the class's size 21440843Smsmith\ field, and restores the search order and compile wordlist to 21540843Smsmith\ prior state. Note that these words are hidden in their own 21640843Smsmith\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 21740843Smsmith\ 21840843Smsmith: do-instance-var 21940843Smsmith does> ( instance class addr[offset] -- addr[field] ) 22094290Sdcs nip @ + 22140843Smsmith; 22240843Smsmith 22340843Smsmith: addr-units: ( offset size "name" -- offset' ) 22440843Smsmith create over , + 22540843Smsmith do-instance-var 22640843Smsmith; 22740843Smsmith 22894290Sdcs: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 22940843Smsmith chars addr-units: ; 23040843Smsmith 23194290Sdcs: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 23240843Smsmith 1 chars: ; 23340843Smsmith 23440843Smsmith: cells: ( offset nCells "name" -- offset' ) 23594290Sdcs cells >r aligned r> addr-units: 23640843Smsmith; 23740843Smsmith 23840843Smsmith: cell: ( offset nCells "name" -- offset' ) 23940843Smsmith 1 cells: ; 24040843Smsmith 24140843Smsmith\ Aggregate an object into the class... 24240843Smsmith\ Needs the class of the instance to create 24340843Smsmith\ Example: object obj: m_obj 24440843Smsmith\ 24540843Smsmith: do-aggregate 24694290Sdcs objectify 24794290Sdcs does> ( instance class pfa -- a-instance a-class ) 24894290Sdcs 2@ ( inst class a-class a-offset ) 24994290Sdcs 2swap drop ( a-class a-offset inst ) 25094290Sdcs + swap ( a-inst a-class ) 25140843Smsmith; 25240843Smsmith 25394290Sdcs: obj: { offset class meta -- offset' } \ "name" 25440843Smsmith create offset , class , 25594290Sdcs class meta --> get-size offset + 25694290Sdcs do-aggregate 25740843Smsmith; 25840843Smsmith 25940843Smsmith\ Aggregate an array of objects into a class 26040843Smsmith\ Usage example: 26140843Smsmith\ 3 my-class array: my-array 26240843Smsmith\ Makes an instance variable array of 3 instances of my-class 26340843Smsmith\ named my-array. 26440843Smsmith\ 26540843Smsmith: array: ( offset n class meta "name" -- offset' ) 26694290Sdcs locals| meta class nobjs offset | 26794290Sdcs create offset , class , 26894290Sdcs class meta --> get-size nobjs * offset + 26994290Sdcs do-aggregate 27040843Smsmith; 27140843Smsmith 27240843Smsmith\ Aggregate a pointer to an object: REF is a member variable 27340843Smsmith\ whose class is set at compile time. This is useful for wrapping 27440843Smsmith\ data structures in C, where there is only a pointer and the type 27540843Smsmith\ it refers to is known. If you want polymorphism, see c_ref 27640843Smsmith\ in classes.fr. REF is only useful for pre-initialized structures, 27740843Smsmith\ since there's no supported way to set one. 27840843Smsmith: ref: ( offset class meta "name" -- offset' ) 27994290Sdcs locals| meta class offset | 28094290Sdcs create offset , class , 28194290Sdcs offset cell+ 28294290Sdcs does> ( inst class pfa -- ptr-inst ptr-class ) 28394290Sdcs 2@ ( inst class ptr-class ptr-offset ) 28494290Sdcs 2swap drop + @ swap 28540843Smsmith; 28640843Smsmith 28794290Sdcs\ #if FICL_WANT_VCALL 28894290Sdcs\ vcall extensions contributed by Guy Carver 28994290Sdcs: vcall: ( paramcnt "name" -- ) 29094290Sdcs current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. 29194290Sdcs create , , \ ( paramcnt index -- ) 29294290Sdcs does> \ ( inst class pfa -- ptr-inst ptr-class ) 29394290Sdcs nip 2@ vcall \ ( params offset inst class offset -- ) 29494290Sdcs; 29594290Sdcs 29694290Sdcs: vcallr: 0x80000000 or vcall: ; \ Call with return address desired. 29794290Sdcs 29894290Sdcs\ #if FICL_WANT_FLOAT 29994290Sdcs: vcallf: \ ( paramcnt -<name>- f: r ) 30094290Sdcs 0x80000000 or 30194290Sdcs current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. 30294290Sdcs create , , \ ( paramcnt index -- ) 30394290Sdcs does> \ ( inst class pfa -- ptr-inst ptr-class ) 30494290Sdcs nip 2@ vcall f> \ ( params offset inst class offset -- f: r ) 30594290Sdcs; 30694290Sdcs\ #endif /* FLOAT */ 30794290Sdcs\ #endif /* VCALL */ 30894290Sdcs 30940843Smsmith\ END-CLASS terminates construction of a class by storing 31040843Smsmith\ the size of its instance variables in the class's size field 31140843Smsmith\ ( -- old-wid addr[size] 0 ) 31240843Smsmith\ 31340843Smsmith: end-class ( old-wid addr[size] size -- ) 31440843Smsmith swap ! set-current 31594290Sdcs search> drop \ pop struct builder wordlist 31640843Smsmith; 31740843Smsmith 31876116Sdcs\ See resume-class (a metaclass method) below for usage 31976116Sdcs\ This is equivalent to end-class for now, but that will change 32076116Sdcs\ when we support vtable bindings. 32176116Sdcs: suspend-class ( old-wid addr[size] size -- ) end-class ; 32276116Sdcs 32340843Smsmithset-current previous 32440843Smsmith\ E N D I N S T A N C E V A R I A B L E S 32540843Smsmith 32640843Smsmith 32740843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 32840843Smsmith\ D O - D O - I N S T A N C E 32940843Smsmith\ Makes a class method that contains the code for an 33040843Smsmith\ instance of the class. This word gets compiled into 33140843Smsmith\ the wordlist of every class by the SUB method. 33240843Smsmith\ PRECONDITION: current-class contains the class address 33360959Sdcs\ why use a state variable instead of the stack? 33494290Sdcs\ >> Stack state is not well-defined during compilation (there are 33560959Sdcs\ >> control structure match codes on the stack, of undefined size 33660959Sdcs\ >> easiest way around this is use of this thread-local variable 33740843Smsmith\ 33840843Smsmith: do-do-instance ( -- ) 33940843Smsmith s" : .do-instance does> [ current-class @ ] literal ;" 34040843Smsmith evaluate 34140843Smsmith; 34240843Smsmith 34340843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 34440843Smsmith\ ** M E T A C L A S S 34540843Smsmith\ Every class is an instance of metaclass. This lets 34640843Smsmith\ classes have methods that are different from those 34740843Smsmith\ of their instances. 34840843Smsmith\ Classes are IMMEDIATE to make early binding simpler 34940843Smsmith\ See above... 35040843Smsmith\ 35140843Smsmith:noname 35294290Sdcs wordlist 35394290Sdcs create 35460959Sdcs immediate 35594290Sdcs 0 , \ NULL parent class 35694290Sdcs dup , \ wid 35794290Sdcs\ #if FICL_WANT_VCALL 35894290Sdcs 4 cells , \ instance size 35994290Sdcs\ #else 36094290Sdcs 3 cells , \ instance size 36194290Sdcs\ #endif 36294290Sdcs ficl-set-current 36394290Sdcs does> dup 36476116Sdcs; execute metaclass 36576116Sdcs\ now brand OBJECT's wordlist (so that ORDER can display it by name) 36676116Sdcsmetaclass drop cell+ @ brand-wordlist 36740843Smsmith 36840843Smsmithmetaclass drop current-class ! 36940843Smsmithdo-do-instance 37040843Smsmith 37140843Smsmith\ 37240843Smsmith\ C L A S S M E T H O D S 37340843Smsmith\ 37440843Smsmithinstance-vars >search 37540843Smsmith 37640843Smsmithcreate .super ( class metaclass -- parent-class ) 37740843Smsmith 0 cells , do-instance-var 37840843Smsmith 37940843Smsmithcreate .wid ( class metaclass -- wid ) \ return wid of class 38040843Smsmith 1 cells , do-instance-var 38140843Smsmith 38294290Sdcs\ #if FICL_WANT_VCALL 38394290Sdcscreate .vtCount \ Number of VTABLE methods, if any 38494290Sdcs 2 cells , do-instance-var 38594290Sdcs 38640843Smsmithcreate .size ( class metaclass -- size ) \ return class's payload size 38794290Sdcs 3 cells , do-instance-var 38894290Sdcs\ #else 38994290Sdcscreate .size ( class metaclass -- size ) \ return class's payload size 39040843Smsmith 2 cells , do-instance-var 39194290Sdcs\ #endif 39240843Smsmith 39340843Smsmith: get-size metaclass => .size @ ; 39440843Smsmith: get-wid metaclass => .wid @ ; 39540843Smsmith: get-super metaclass => .super @ ; 39694290Sdcs\ #if FICL_WANT_VCALL 39794290Sdcs: get-vtCount metaclass => .vtCount @ ; 39894290Sdcs: get-vtAdd metaclass => .vtCount ; 39994290Sdcs\ #endif 40040843Smsmith 40140843Smsmith\ create an uninitialized instance of a class, leaving 40240843Smsmith\ the address of the new instance and its class 40340843Smsmith\ 40440843Smsmith: instance ( class metaclass "name" -- instance class ) 40540843Smsmith locals| meta parent | 40694290Sdcs create 40740843Smsmith here parent --> .do-instance \ ( inst class ) 40840843Smsmith parent meta metaclass => get-size 40940843Smsmith allot \ allocate payload space 41040843Smsmith; 41140843Smsmith 41240843Smsmith\ create an uninitialized array 41340843Smsmith: array ( n class metaclass "name" -- n instance class ) 41440843Smsmith locals| meta parent nobj | 41594290Sdcs create nobj 41640843Smsmith here parent --> .do-instance \ ( nobj inst class ) 41740843Smsmith parent meta metaclass => get-size 41894290Sdcs nobj * allot \ allocate payload space 41940843Smsmith; 42040843Smsmith 42140843Smsmith\ create an initialized instance 42240843Smsmith\ 42340843Smsmith: new \ ( class metaclass "name" -- ) 42440843Smsmith metaclass => instance --> init 42540843Smsmith; 42640843Smsmith 42740843Smsmith\ create an initialized array of instances 42840843Smsmith: new-array ( n class metaclass "name" -- ) 42994290Sdcs metaclass => array 43094290Sdcs --> array-init 43140843Smsmith; 43240843Smsmith 43360959Sdcs\ Create an anonymous initialized instance from the heap 43460959Sdcs: alloc \ ( class metaclass -- instance class ) 43560959Sdcs locals| meta class | 43660959Sdcs class meta metaclass => get-size allocate ( -- addr fail-flag ) 43760959Sdcs abort" allocate failed " ( -- addr ) 43860959Sdcs class 2dup --> init 43960959Sdcs; 44060959Sdcs 44160959Sdcs\ Create an anonymous array of initialized instances from the heap 44260959Sdcs: alloc-array \ ( n class metaclass -- instance class ) 44360959Sdcs locals| meta class nobj | 44460959Sdcs class meta metaclass => get-size 44560959Sdcs nobj * allocate ( -- addr fail-flag ) 44660959Sdcs abort" allocate failed " ( -- addr ) 44760959Sdcs nobj over class --> array-init 44860959Sdcs class 44960959Sdcs; 45060959Sdcs 45176116Sdcs\ Create an anonymous initialized instance from the dictionary 45276116Sdcs: allot { 2:this -- 2:instance } 45376116Sdcs here ( instance-address ) 45476116Sdcs this my=> get-size allot 45576116Sdcs this drop 2dup --> init 45676116Sdcs; 45776116Sdcs 45876116Sdcs\ Create an anonymous array of initialized instances from the dictionary 45976116Sdcs: allot-array { nobj 2:this -- 2:instance } 46076116Sdcs here ( instance-address ) 46176116Sdcs this my=> get-size nobj * allot 46276116Sdcs this drop 2dup ( 2instance 2instance ) 46376116Sdcs nobj -rot --> array-init 46476116Sdcs; 46576116Sdcs 46640843Smsmith\ create a proxy object with initialized payload address given 46740843Smsmith: ref ( instance-addr class metaclass "name" -- ) 46840843Smsmith drop create , , 46940843Smsmith does> 2@ 47040843Smsmith; 47140843Smsmith 47276116Sdcs\ suspend-class and resume-class help to build mutually referent classes. 47376116Sdcs\ Example: 47476116Sdcs\ object subclass c-akbar 47576116Sdcs\ suspend-class ( put akbar on hold while we define jeff ) 47676116Sdcs\ object subclass c-jeff 47776116Sdcs\ c-akbar ref: .akbar 47876116Sdcs\ ( and whatever else comprises this class ) 47976116Sdcs\ end-class ( done with c-jeff ) 48076116Sdcs\ c-akbar --> resume-class 48176116Sdcs\ c-jeff ref: .jeff 48276116Sdcs\ ( and whatever else goes in c-akbar ) 48376116Sdcs\ end-class ( done with c-akbar ) 48476116Sdcs\ 48576116Sdcs: resume-class { 2:this -- old-wid addr[size] size } 48676116Sdcs this --> .wid @ ficl-set-current ( old-wid ) 48776116Sdcs this --> .size dup @ ( old-wid addr[size] size ) 48876116Sdcs instance-vars >search 48976116Sdcs; 49076116Sdcs 49140843Smsmith\ create a subclass 49276116Sdcs\ This method leaves the stack and search order ready for instance variable 49376116Sdcs\ building. Pushes the instance-vars wordlist onto the search order, 49476116Sdcs\ and sets the compilation wordlist to be the private wordlist of the 49576116Sdcs\ new class. The class's wordlist is deliberately NOT in the search order - 49676116Sdcs\ to prevent methods from getting used with wrong data. 49776116Sdcs\ Postcondition: leaves the address of the new class in current-class 49840843Smsmith: sub ( class metaclass "name" -- old-wid addr[size] size ) 49940843Smsmith wordlist 50094290Sdcs locals| wid meta parent | 50194290Sdcs parent meta metaclass => get-wid 50294290Sdcs wid wid-set-super \ set superclass 50394290Sdcs create immediate \ get the subclass name 50476116Sdcs wid brand-wordlist \ label the subclass wordlist 50594290Sdcs here current-class ! \ prep for do-do-instance 50694290Sdcs parent , \ save parent class 50794290Sdcs wid , \ save wid 50894290Sdcs\ #if FICL_WANT_VCALL 50994290Sdcs parent meta --> get-vtCount , 51094290Sdcs\ #endif 51194290Sdcs here parent meta --> get-size dup , ( addr[size] size ) 51294290Sdcs metaclass => .do-instance 51394290Sdcs wid ficl-set-current -rot 51494290Sdcs do-do-instance 51594290Sdcs instance-vars >search \ push struct builder wordlist 51640843Smsmith; 51740843Smsmith 51840843Smsmith\ OFFSET-OF returns the offset of an instance variable 51940843Smsmith\ from the instance base address. If the next token is not 52040843Smsmith\ the name of in instance variable method, you get garbage 52140843Smsmith\ results -- there is no way at present to check for this error. 52240843Smsmith: offset-of ( class metaclass "name" -- offset ) 52340843Smsmith drop find-method-xt nip >body @ ; 52440843Smsmith 52540843Smsmith\ ID returns the string name cell-pair of its class 52640843Smsmith: id ( class metaclass -- c-addr u ) 52794290Sdcs drop body> >name ; 52840843Smsmith 52940843Smsmith\ list methods of the class 53040843Smsmith: methods \ ( class meta -- ) 53194290Sdcs locals| meta class | 53294290Sdcs begin 53394290Sdcs class body> >name type ." methods:" cr 53494290Sdcs class meta --> get-wid >search words cr previous 53594290Sdcs class meta metaclass => get-super 53694290Sdcs dup to class 53794290Sdcs 0= until cr 53840843Smsmith; 53940843Smsmith 54040843Smsmith\ list class's ancestors 54140843Smsmith: pedigree ( class meta -- ) 54294290Sdcs locals| meta class | 54394290Sdcs begin 54494290Sdcs class body> >name type space 54594290Sdcs class meta metaclass => get-super 54694290Sdcs dup to class 54794290Sdcs 0= until cr 54840843Smsmith; 54940843Smsmith 55094290Sdcs\ decompile an instance method 55140843Smsmith: see ( class meta -- ) 55240843Smsmith metaclass => get-wid >search see previous ; 55340843Smsmith 55494290Sdcs\ debug a method of metaclass 55594290Sdcs\ Eg: my-class --> debug my-method 55694290Sdcs: debug ( class meta -- ) 55794290Sdcs find-method-xt debug-xt ; 55894290Sdcs 55994290Sdcsprevious set-current 56040843Smsmith\ E N D M E T A C L A S S 56140843Smsmith 56276116Sdcs\ ** META is a nickname for the address of METACLASS... 56340843Smsmithmetaclass drop 56440843Smsmithconstant meta 56540843Smsmith 56676116Sdcs\ ** SUBCLASS is a nickname for a class's SUB method... 56740843Smsmith\ Subclass compilation ends when you invoke end-class 56840843Smsmith\ This method is late bound for safety... 56940843Smsmith: subclass --> sub ; 57040843Smsmith 57194290Sdcs\ #if FICL_WANT_VCALL 57294290Sdcs\ VTABLE Support extensions (Guy Carver) 57394290Sdcs\ object --> sub mine hasvtable 57494290Sdcs: hasvtable 4 + ; immediate 57594290Sdcs\ #endif 57640843Smsmith 57794290Sdcs 57840843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 57940843Smsmith\ ** O B J E C T 58040843Smsmith\ Root of all classes 58140843Smsmith:noname 58294290Sdcs wordlist 58394290Sdcs create immediate 58494290Sdcs 0 , \ NULL parent class 58594290Sdcs dup , \ wid 58694290Sdcs 0 , \ instance size 58794290Sdcs ficl-set-current 58894290Sdcs does> meta 58940843Smsmith; execute object 59076116Sdcs\ now brand OBJECT's wordlist (so that ORDER can display it by name) 59176116Sdcsobject drop cell+ @ brand-wordlist 59240843Smsmith 59340843Smsmithobject drop current-class ! 59440843Smsmithdo-do-instance 59576116Sdcsinstance-vars >search 59640843Smsmith 59740843Smsmith\ O B J E C T M E T H O D S 59840843Smsmith\ Convert instance cell-pair to class cell-pair 59940843Smsmith\ Useful for binding class methods from an instance 60040843Smsmith: class ( instance class -- class metaclass ) 60194290Sdcs nip meta ; 60240843Smsmith 60340843Smsmith\ default INIT method zero fills an instance 60440843Smsmith: init ( instance class -- ) 60540843Smsmith meta 60640843Smsmith metaclass => get-size ( inst size ) 60740843Smsmith erase ; 60840843Smsmith 60940843Smsmith\ Apply INIT to an array of NOBJ objects... 61040843Smsmith\ 61140843Smsmith: array-init ( nobj inst class -- ) 61294290Sdcs 0 dup locals| &init &next class inst | 61394290Sdcs \ 61494290Sdcs \ bind methods outside the loop to save time 61594290Sdcs \ 61694290Sdcs class s" init" lookup-method to &init 61794290Sdcs s" next" lookup-method to &next 61894290Sdcs drop 61994290Sdcs 0 ?do 62094290Sdcs inst class 2dup 62194290Sdcs &init execute 62294290Sdcs &next execute drop to inst 62394290Sdcs loop 62440843Smsmith; 62540843Smsmith 62660959Sdcs\ free storage allocated to a heap instance by alloc or alloc-array 62760959Sdcs\ NOTE: not protected against errors like FREEing something that's 62860959Sdcs\ really in the dictionary. 62960959Sdcs: free \ ( instance class -- ) 63094290Sdcs drop free 63194290Sdcs abort" free failed " 63260959Sdcs; 63360959Sdcs 63440843Smsmith\ Instance aliases for common class methods 63540843Smsmith\ Upcast to parent class 63640843Smsmith: super ( instance class -- instance parent-class ) 63740843Smsmith meta metaclass => get-super ; 63840843Smsmith 63940843Smsmith: pedigree ( instance class -- ) 64094290Sdcs object => class 64140843Smsmith metaclass => pedigree ; 64240843Smsmith 64340843Smsmith: size ( instance class -- sizeof-instance ) 64494290Sdcs object => class 64540843Smsmith metaclass => get-size ; 64640843Smsmith 64740843Smsmith: methods ( instance class -- ) 64894290Sdcs object => class 64940843Smsmith metaclass => methods ; 65040843Smsmith 65140843Smsmith\ Array indexing methods... 65240843Smsmith\ Usage examples: 65340843Smsmith\ 10 object-array --> index 65440843Smsmith\ obj --> next 65540843Smsmith\ 65640843Smsmith: index ( n instance class -- instance[n] class ) 65794290Sdcs locals| class inst | 65894290Sdcs inst class 65940843Smsmith object => class 66094290Sdcs metaclass => get-size * ( n*size ) 66194290Sdcs inst + class ; 66240843Smsmith 66340843Smsmith: next ( instance[n] class -- instance[n+1] class ) 66494290Sdcs locals| class inst | 66594290Sdcs inst class 66640843Smsmith object => class 66794290Sdcs metaclass => get-size 66894290Sdcs inst + 66994290Sdcs class ; 67040843Smsmith 67140843Smsmith: prev ( instance[n] class -- instance[n-1] class ) 67294290Sdcs locals| class inst | 67394290Sdcs inst class 67440843Smsmith object => class 67594290Sdcs metaclass => get-size 67694290Sdcs inst swap - 67794290Sdcs class ; 67840843Smsmith 67976116Sdcs: debug ( 2this -- ?? ) 68076116Sdcs find-method-xt debug-xt ; 68176116Sdcs 68276116Sdcsprevious set-current 68340843Smsmith\ E N D O B J E C T 68440843Smsmith 68594290Sdcs\ reset to default search order 68694290Sdcsonly definitions 68740843Smsmith 68894290Sdcs\ redefine oop in default search order to put OOP words in the search order and make them 68994290Sdcs\ the compiling wordlist... 69094290Sdcs 69194290Sdcs: oo only also oop definitions ; 69294290Sdcs 69376116Sdcs\ #endif 694