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: releng/11.0/sys/boot/ficl/softwords/oo.fr 167850 2007-03-23 22:26:01Z jkim $ 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 8994290Sdcs\ p a r s e - m e t h o d 9094290Sdcs\ compiles a method name so that it pushes 9194290Sdcs\ the string base address and count at run-time. 9294290Sdcs 9340843Smsmith: parse-method \ name run: ( -- c-addr u ) 9440843Smsmith parse-word 9594290Sdcs postpone sliteral 9640843Smsmith; compile-only 9740843Smsmith 98167850Sjkim 99167850Sjkim 100167850Sjkim: (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 } 101167850Sjkim class name class cell+ @ ( class c-addr u wid ) 102167850Sjkim search-wordlist 103167850Sjkim; 104167850Sjkim 10594290Sdcs\ l o o k u p - m e t h o d 10694290Sdcs\ takes a counted string method name from the stack (as compiled 10794290Sdcs\ by parse-method) and attempts to look this method up in the method list of 10894290Sdcs\ the class that's on the stack. If successful, it leaves the class on the stack 10994290Sdcs\ and pushes the xt of the method. If not, it aborts with an error message. 11094290Sdcs 11176116Sdcs: lookup-method { class 2:name -- class xt } 112167850Sjkim class name (lookup-method) ( 0 | xt 1 | xt -1 ) 11394290Sdcs 0= if 11494290Sdcs name type ." not found in " 11576116Sdcs class body> >name type 11640843Smsmith cr abort 11794290Sdcs endif 11840843Smsmith; 11940843Smsmith 12040843Smsmith: find-method-xt \ name ( class -- class xt ) 12194290Sdcs parse-word lookup-method 12240843Smsmith; 12340843Smsmith 12476116Sdcs: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) 12576116Sdcs lookup-method catch 12676116Sdcs; 12776116Sdcs 12876116Sdcs: exec-method ( instance class c-addr u -- <method-signature> ) 12976116Sdcs lookup-method execute 13076116Sdcs; 13176116Sdcs 13240843Smsmith\ Method lookup operator takes a class-addr and instance-addr 13340843Smsmith\ and executes the method from the class's wordlist if 13440843Smsmith\ interpreting. If compiling, bind late. 13540843Smsmith\ 13640843Smsmith: --> ( instance class -- ??? ) 13740843Smsmith state @ 0= if 13894290Sdcs find-method-xt execute 13940843Smsmith else 14094290Sdcs parse-method postpone exec-method 14140843Smsmith endif 14240843Smsmith; immediate 14340843Smsmith 14476116Sdcs\ Method lookup with CATCH in case of exceptions 14576116Sdcs: c-> ( instance class -- ?? exc-flag ) 14676116Sdcs state @ 0= if 14794290Sdcs find-method-xt catch 14876116Sdcs else 14994290Sdcs parse-method postpone catch-method 15076116Sdcs endif 15176116Sdcs; immediate 15240843Smsmith 15376116Sdcs\ METHOD makes global words that do method invocations by late binding 15476116Sdcs\ in case you prefer this style (no --> in your code) 15594290Sdcs\ Example: everything has next and prev for array access, so... 15694290Sdcs\ method next 15794290Sdcs\ method prev 15894290Sdcs\ my-instance next ( does whatever next does to my-instance by late binding ) 15994290Sdcs 16076116Sdcs: method create does> body> >name lookup-method execute ; 16176116Sdcs 16276116Sdcs 16340843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 16440843Smsmith\ ** E A R L Y B I N D I N G 16540843Smsmith\ Early binding operator compiles code to execute a method 16640843Smsmith\ given its class at compile time. Classes are immediate, 16740843Smsmith\ so they leave their cell-pair on the stack when compiling. 16840843Smsmith\ Example: 16940843Smsmith\ : get-wid metaclass => .wid @ ; 17040843Smsmith\ Usage 17140843Smsmith\ my-class get-wid ( -- wid-of-my-class ) 17240843Smsmith\ 17376116Sdcs1 ficl-named-wordlist instance-vars 17476116Sdcsinstance-vars dup >search ficl-set-current 17576116Sdcs 17640843Smsmith: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 17794290Sdcs drop find-method-xt compile, drop 17840843Smsmith; immediate compile-only 17940843Smsmith 18076116Sdcs: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class 18176116Sdcs current-class @ dup postpone => 18276116Sdcs; immediate compile-only 18340843Smsmith 18494290Sdcs\ Problem: my=[ assumes that each method except the last is am obj: member 18594290Sdcs\ which contains its class as the first field of its parameter area. The code 18694290Sdcs\ detects non-obect members and assumes the class does not change in this case. 18794290Sdcs\ This handles methods like index, prev, and next correctly, but does not deal 18894290Sdcs\ correctly with CLASS. 18976116Sdcs: my=[ \ same as my=> , but binds a chain of methods 19076116Sdcs current-class @ 19176116Sdcs begin 19294290Sdcs parse-word 2dup ( class c-addr u c-addr u ) 19394290Sdcs s" ]" compare while ( class c-addr u ) 19494290Sdcs lookup-method ( class xt ) 19594290Sdcs dup compile, ( class xt ) 19694290Sdcs dup ?object if \ If object member, get new class. Otherwise assume same class 19794290Sdcs nip >body cell+ @ ( new-class ) 19894290Sdcs else 19994290Sdcs drop ( class ) 20094290Sdcs endif 20176116Sdcs repeat 2drop drop 20276116Sdcs; immediate compile-only 20376116Sdcs 20476116Sdcs 20540843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 20640843Smsmith\ ** I N S T A N C E V A R I A B L E S 20740843Smsmith\ Instance variables (IV) are represented by words in the class's 20840843Smsmith\ private wordlist. Each IV word contains the offset 20940843Smsmith\ of the IV it represents, and runs code to add that offset 21040843Smsmith\ to the base address of an instance when executed. 21140843Smsmith\ The metaclass SUB method, defined below, leaves the address 21240843Smsmith\ of the new class's offset field and its initial size on the 21340843Smsmith\ stack for these words to update. When a class definition is 21440843Smsmith\ complete, END-CLASS saves the final size in the class's size 21540843Smsmith\ field, and restores the search order and compile wordlist to 21640843Smsmith\ prior state. Note that these words are hidden in their own 21740843Smsmith\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 21840843Smsmith\ 21940843Smsmith: do-instance-var 22040843Smsmith does> ( instance class addr[offset] -- addr[field] ) 22194290Sdcs nip @ + 22240843Smsmith; 22340843Smsmith 22440843Smsmith: addr-units: ( offset size "name" -- offset' ) 22540843Smsmith create over , + 22640843Smsmith do-instance-var 22740843Smsmith; 22840843Smsmith 22994290Sdcs: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 23040843Smsmith chars addr-units: ; 23140843Smsmith 23294290Sdcs: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 23340843Smsmith 1 chars: ; 23440843Smsmith 23540843Smsmith: cells: ( offset nCells "name" -- offset' ) 23694290Sdcs cells >r aligned r> addr-units: 23740843Smsmith; 23840843Smsmith 23940843Smsmith: cell: ( offset nCells "name" -- offset' ) 24040843Smsmith 1 cells: ; 24140843Smsmith 24240843Smsmith\ Aggregate an object into the class... 24340843Smsmith\ Needs the class of the instance to create 24440843Smsmith\ Example: object obj: m_obj 24540843Smsmith\ 24640843Smsmith: do-aggregate 24794290Sdcs objectify 24894290Sdcs does> ( instance class pfa -- a-instance a-class ) 24994290Sdcs 2@ ( inst class a-class a-offset ) 25094290Sdcs 2swap drop ( a-class a-offset inst ) 25194290Sdcs + swap ( a-inst a-class ) 25240843Smsmith; 25340843Smsmith 25494290Sdcs: obj: { offset class meta -- offset' } \ "name" 25540843Smsmith create offset , class , 25694290Sdcs class meta --> get-size offset + 25794290Sdcs do-aggregate 25840843Smsmith; 25940843Smsmith 26040843Smsmith\ Aggregate an array of objects into a class 26140843Smsmith\ Usage example: 26240843Smsmith\ 3 my-class array: my-array 26340843Smsmith\ Makes an instance variable array of 3 instances of my-class 26440843Smsmith\ named my-array. 26540843Smsmith\ 26640843Smsmith: array: ( offset n class meta "name" -- offset' ) 26794290Sdcs locals| meta class nobjs offset | 26894290Sdcs create offset , class , 26994290Sdcs class meta --> get-size nobjs * offset + 27094290Sdcs do-aggregate 27140843Smsmith; 27240843Smsmith 27340843Smsmith\ Aggregate a pointer to an object: REF is a member variable 27440843Smsmith\ whose class is set at compile time. This is useful for wrapping 27540843Smsmith\ data structures in C, where there is only a pointer and the type 27640843Smsmith\ it refers to is known. If you want polymorphism, see c_ref 27740843Smsmith\ in classes.fr. REF is only useful for pre-initialized structures, 27840843Smsmith\ since there's no supported way to set one. 27940843Smsmith: ref: ( offset class meta "name" -- offset' ) 28094290Sdcs locals| meta class offset | 28194290Sdcs create offset , class , 28294290Sdcs offset cell+ 28394290Sdcs does> ( inst class pfa -- ptr-inst ptr-class ) 28494290Sdcs 2@ ( inst class ptr-class ptr-offset ) 28594290Sdcs 2swap drop + @ swap 28640843Smsmith; 28740843Smsmith 28894290Sdcs\ #if FICL_WANT_VCALL 28994290Sdcs\ vcall extensions contributed by Guy Carver 29094290Sdcs: vcall: ( paramcnt "name" -- ) 29194290Sdcs current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. 29294290Sdcs create , , \ ( paramcnt index -- ) 29394290Sdcs does> \ ( inst class pfa -- ptr-inst ptr-class ) 29494290Sdcs nip 2@ vcall \ ( params offset inst class offset -- ) 29594290Sdcs; 29694290Sdcs 29794290Sdcs: vcallr: 0x80000000 or vcall: ; \ Call with return address desired. 29894290Sdcs 29994290Sdcs\ #if FICL_WANT_FLOAT 30094290Sdcs: vcallf: \ ( paramcnt -<name>- f: r ) 30194290Sdcs 0x80000000 or 30294290Sdcs current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. 30394290Sdcs create , , \ ( paramcnt index -- ) 30494290Sdcs does> \ ( inst class pfa -- ptr-inst ptr-class ) 30594290Sdcs nip 2@ vcall f> \ ( params offset inst class offset -- f: r ) 30694290Sdcs; 30794290Sdcs\ #endif /* FLOAT */ 30894290Sdcs\ #endif /* VCALL */ 30994290Sdcs 31040843Smsmith\ END-CLASS terminates construction of a class by storing 31140843Smsmith\ the size of its instance variables in the class's size field 31240843Smsmith\ ( -- old-wid addr[size] 0 ) 31340843Smsmith\ 31440843Smsmith: end-class ( old-wid addr[size] size -- ) 31540843Smsmith swap ! set-current 31694290Sdcs search> drop \ pop struct builder wordlist 31740843Smsmith; 31840843Smsmith 31976116Sdcs\ See resume-class (a metaclass method) below for usage 32076116Sdcs\ This is equivalent to end-class for now, but that will change 32176116Sdcs\ when we support vtable bindings. 32276116Sdcs: suspend-class ( old-wid addr[size] size -- ) end-class ; 32376116Sdcs 32440843Smsmithset-current previous 32540843Smsmith\ E N D I N S T A N C E V A R I A B L E S 32640843Smsmith 32740843Smsmith 32840843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 32940843Smsmith\ D O - D O - I N S T A N C E 33040843Smsmith\ Makes a class method that contains the code for an 33140843Smsmith\ instance of the class. This word gets compiled into 33240843Smsmith\ the wordlist of every class by the SUB method. 33340843Smsmith\ PRECONDITION: current-class contains the class address 33460959Sdcs\ why use a state variable instead of the stack? 33594290Sdcs\ >> Stack state is not well-defined during compilation (there are 33660959Sdcs\ >> control structure match codes on the stack, of undefined size 33760959Sdcs\ >> easiest way around this is use of this thread-local variable 33840843Smsmith\ 33940843Smsmith: do-do-instance ( -- ) 34040843Smsmith s" : .do-instance does> [ current-class @ ] literal ;" 34140843Smsmith evaluate 34240843Smsmith; 34340843Smsmith 34440843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 34540843Smsmith\ ** M E T A C L A S S 34640843Smsmith\ Every class is an instance of metaclass. This lets 34740843Smsmith\ classes have methods that are different from those 34840843Smsmith\ of their instances. 34940843Smsmith\ Classes are IMMEDIATE to make early binding simpler 35040843Smsmith\ See above... 35140843Smsmith\ 35240843Smsmith:noname 35394290Sdcs wordlist 35494290Sdcs create 35560959Sdcs immediate 35694290Sdcs 0 , \ NULL parent class 35794290Sdcs dup , \ wid 35894290Sdcs\ #if FICL_WANT_VCALL 35994290Sdcs 4 cells , \ instance size 36094290Sdcs\ #else 36194290Sdcs 3 cells , \ instance size 36294290Sdcs\ #endif 36394290Sdcs ficl-set-current 36494290Sdcs does> dup 36576116Sdcs; execute metaclass 36676116Sdcs\ now brand OBJECT's wordlist (so that ORDER can display it by name) 36776116Sdcsmetaclass drop cell+ @ brand-wordlist 36840843Smsmith 36940843Smsmithmetaclass drop current-class ! 37040843Smsmithdo-do-instance 37140843Smsmith 37240843Smsmith\ 37340843Smsmith\ C L A S S M E T H O D S 37440843Smsmith\ 37540843Smsmithinstance-vars >search 37640843Smsmith 37740843Smsmithcreate .super ( class metaclass -- parent-class ) 37840843Smsmith 0 cells , do-instance-var 37940843Smsmith 38040843Smsmithcreate .wid ( class metaclass -- wid ) \ return wid of class 38140843Smsmith 1 cells , do-instance-var 38240843Smsmith 38394290Sdcs\ #if FICL_WANT_VCALL 38494290Sdcscreate .vtCount \ Number of VTABLE methods, if any 38594290Sdcs 2 cells , do-instance-var 38694290Sdcs 38740843Smsmithcreate .size ( class metaclass -- size ) \ return class's payload size 38894290Sdcs 3 cells , do-instance-var 38994290Sdcs\ #else 39094290Sdcscreate .size ( class metaclass -- size ) \ return class's payload size 39140843Smsmith 2 cells , do-instance-var 39294290Sdcs\ #endif 39340843Smsmith 39440843Smsmith: get-size metaclass => .size @ ; 39540843Smsmith: get-wid metaclass => .wid @ ; 39640843Smsmith: get-super metaclass => .super @ ; 39794290Sdcs\ #if FICL_WANT_VCALL 39894290Sdcs: get-vtCount metaclass => .vtCount @ ; 39994290Sdcs: get-vtAdd metaclass => .vtCount ; 40094290Sdcs\ #endif 40140843Smsmith 40240843Smsmith\ create an uninitialized instance of a class, leaving 40340843Smsmith\ the address of the new instance and its class 40440843Smsmith\ 40540843Smsmith: instance ( class metaclass "name" -- instance class ) 40640843Smsmith locals| meta parent | 40794290Sdcs create 40840843Smsmith here parent --> .do-instance \ ( inst class ) 40940843Smsmith parent meta metaclass => get-size 41040843Smsmith allot \ allocate payload space 41140843Smsmith; 41240843Smsmith 41340843Smsmith\ create an uninitialized array 41440843Smsmith: array ( n class metaclass "name" -- n instance class ) 41540843Smsmith locals| meta parent nobj | 41694290Sdcs create nobj 41740843Smsmith here parent --> .do-instance \ ( nobj inst class ) 41840843Smsmith parent meta metaclass => get-size 41994290Sdcs nobj * allot \ allocate payload space 42040843Smsmith; 42140843Smsmith 42240843Smsmith\ create an initialized instance 42340843Smsmith\ 42440843Smsmith: new \ ( class metaclass "name" -- ) 42540843Smsmith metaclass => instance --> init 42640843Smsmith; 42740843Smsmith 42840843Smsmith\ create an initialized array of instances 42940843Smsmith: new-array ( n class metaclass "name" -- ) 43094290Sdcs metaclass => array 43194290Sdcs --> array-init 43240843Smsmith; 43340843Smsmith 43460959Sdcs\ Create an anonymous initialized instance from the heap 43560959Sdcs: alloc \ ( class metaclass -- instance class ) 43660959Sdcs locals| meta class | 43760959Sdcs class meta metaclass => get-size allocate ( -- addr fail-flag ) 43860959Sdcs abort" allocate failed " ( -- addr ) 43960959Sdcs class 2dup --> init 44060959Sdcs; 44160959Sdcs 44260959Sdcs\ Create an anonymous array of initialized instances from the heap 44360959Sdcs: alloc-array \ ( n class metaclass -- instance class ) 44460959Sdcs locals| meta class nobj | 44560959Sdcs class meta metaclass => get-size 44660959Sdcs nobj * allocate ( -- addr fail-flag ) 44760959Sdcs abort" allocate failed " ( -- addr ) 44860959Sdcs nobj over class --> array-init 44960959Sdcs class 45060959Sdcs; 45160959Sdcs 45276116Sdcs\ Create an anonymous initialized instance from the dictionary 45376116Sdcs: allot { 2:this -- 2:instance } 45476116Sdcs here ( instance-address ) 45576116Sdcs this my=> get-size allot 45676116Sdcs this drop 2dup --> init 45776116Sdcs; 45876116Sdcs 45976116Sdcs\ Create an anonymous array of initialized instances from the dictionary 46076116Sdcs: allot-array { nobj 2:this -- 2:instance } 46176116Sdcs here ( instance-address ) 46276116Sdcs this my=> get-size nobj * allot 46376116Sdcs this drop 2dup ( 2instance 2instance ) 46476116Sdcs nobj -rot --> array-init 46576116Sdcs; 46676116Sdcs 46740843Smsmith\ create a proxy object with initialized payload address given 46840843Smsmith: ref ( instance-addr class metaclass "name" -- ) 46940843Smsmith drop create , , 47040843Smsmith does> 2@ 47140843Smsmith; 47240843Smsmith 47376116Sdcs\ suspend-class and resume-class help to build mutually referent classes. 47476116Sdcs\ Example: 47576116Sdcs\ object subclass c-akbar 47676116Sdcs\ suspend-class ( put akbar on hold while we define jeff ) 47776116Sdcs\ object subclass c-jeff 47876116Sdcs\ c-akbar ref: .akbar 47976116Sdcs\ ( and whatever else comprises this class ) 48076116Sdcs\ end-class ( done with c-jeff ) 48176116Sdcs\ c-akbar --> resume-class 48276116Sdcs\ c-jeff ref: .jeff 48376116Sdcs\ ( and whatever else goes in c-akbar ) 48476116Sdcs\ end-class ( done with c-akbar ) 48576116Sdcs\ 48676116Sdcs: resume-class { 2:this -- old-wid addr[size] size } 48776116Sdcs this --> .wid @ ficl-set-current ( old-wid ) 48876116Sdcs this --> .size dup @ ( old-wid addr[size] size ) 48976116Sdcs instance-vars >search 49076116Sdcs; 49176116Sdcs 49240843Smsmith\ create a subclass 49376116Sdcs\ This method leaves the stack and search order ready for instance variable 49476116Sdcs\ building. Pushes the instance-vars wordlist onto the search order, 49576116Sdcs\ and sets the compilation wordlist to be the private wordlist of the 49676116Sdcs\ new class. The class's wordlist is deliberately NOT in the search order - 49776116Sdcs\ to prevent methods from getting used with wrong data. 49876116Sdcs\ Postcondition: leaves the address of the new class in current-class 49940843Smsmith: sub ( class metaclass "name" -- old-wid addr[size] size ) 50040843Smsmith wordlist 50194290Sdcs locals| wid meta parent | 50294290Sdcs parent meta metaclass => get-wid 50394290Sdcs wid wid-set-super \ set superclass 50494290Sdcs create immediate \ get the subclass name 50576116Sdcs wid brand-wordlist \ label the subclass wordlist 50694290Sdcs here current-class ! \ prep for do-do-instance 50794290Sdcs parent , \ save parent class 50894290Sdcs wid , \ save wid 50994290Sdcs\ #if FICL_WANT_VCALL 51094290Sdcs parent meta --> get-vtCount , 51194290Sdcs\ #endif 51294290Sdcs here parent meta --> get-size dup , ( addr[size] size ) 51394290Sdcs metaclass => .do-instance 51494290Sdcs wid ficl-set-current -rot 51594290Sdcs do-do-instance 51694290Sdcs instance-vars >search \ push struct builder wordlist 51740843Smsmith; 51840843Smsmith 51940843Smsmith\ OFFSET-OF returns the offset of an instance variable 52040843Smsmith\ from the instance base address. If the next token is not 52140843Smsmith\ the name of in instance variable method, you get garbage 52240843Smsmith\ results -- there is no way at present to check for this error. 52340843Smsmith: offset-of ( class metaclass "name" -- offset ) 52440843Smsmith drop find-method-xt nip >body @ ; 52540843Smsmith 52640843Smsmith\ ID returns the string name cell-pair of its class 52740843Smsmith: id ( class metaclass -- c-addr u ) 52894290Sdcs drop body> >name ; 52940843Smsmith 53040843Smsmith\ list methods of the class 53140843Smsmith: methods \ ( class meta -- ) 53294290Sdcs locals| meta class | 53394290Sdcs begin 53494290Sdcs class body> >name type ." methods:" cr 53594290Sdcs class meta --> get-wid >search words cr previous 53694290Sdcs class meta metaclass => get-super 53794290Sdcs dup to class 53894290Sdcs 0= until cr 53940843Smsmith; 54040843Smsmith 54140843Smsmith\ list class's ancestors 54240843Smsmith: pedigree ( class meta -- ) 54394290Sdcs locals| meta class | 54494290Sdcs begin 54594290Sdcs class body> >name type space 54694290Sdcs class meta metaclass => get-super 54794290Sdcs dup to class 54894290Sdcs 0= until cr 54940843Smsmith; 55040843Smsmith 55194290Sdcs\ decompile an instance method 55240843Smsmith: see ( class meta -- ) 55340843Smsmith metaclass => get-wid >search see previous ; 55440843Smsmith 55594290Sdcs\ debug a method of metaclass 55694290Sdcs\ Eg: my-class --> debug my-method 55794290Sdcs: debug ( class meta -- ) 55894290Sdcs find-method-xt debug-xt ; 55994290Sdcs 56094290Sdcsprevious set-current 56140843Smsmith\ E N D M E T A C L A S S 56240843Smsmith 56376116Sdcs\ ** META is a nickname for the address of METACLASS... 56440843Smsmithmetaclass drop 56540843Smsmithconstant meta 56640843Smsmith 56776116Sdcs\ ** SUBCLASS is a nickname for a class's SUB method... 56840843Smsmith\ Subclass compilation ends when you invoke end-class 56940843Smsmith\ This method is late bound for safety... 57040843Smsmith: subclass --> sub ; 57140843Smsmith 57294290Sdcs\ #if FICL_WANT_VCALL 57394290Sdcs\ VTABLE Support extensions (Guy Carver) 57494290Sdcs\ object --> sub mine hasvtable 57594290Sdcs: hasvtable 4 + ; immediate 57694290Sdcs\ #endif 57740843Smsmith 57894290Sdcs 57940843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 58040843Smsmith\ ** O B J E C T 58140843Smsmith\ Root of all classes 58240843Smsmith:noname 58394290Sdcs wordlist 58494290Sdcs create immediate 58594290Sdcs 0 , \ NULL parent class 58694290Sdcs dup , \ wid 58794290Sdcs 0 , \ instance size 58894290Sdcs ficl-set-current 58994290Sdcs does> meta 59040843Smsmith; execute object 59176116Sdcs\ now brand OBJECT's wordlist (so that ORDER can display it by name) 59276116Sdcsobject drop cell+ @ brand-wordlist 59340843Smsmith 59440843Smsmithobject drop current-class ! 59540843Smsmithdo-do-instance 59676116Sdcsinstance-vars >search 59740843Smsmith 59840843Smsmith\ O B J E C T M E T H O D S 59940843Smsmith\ Convert instance cell-pair to class cell-pair 60040843Smsmith\ Useful for binding class methods from an instance 60140843Smsmith: class ( instance class -- class metaclass ) 60294290Sdcs nip meta ; 60340843Smsmith 60440843Smsmith\ default INIT method zero fills an instance 60540843Smsmith: init ( instance class -- ) 60640843Smsmith meta 60740843Smsmith metaclass => get-size ( inst size ) 60840843Smsmith erase ; 60940843Smsmith 61040843Smsmith\ Apply INIT to an array of NOBJ objects... 61140843Smsmith\ 61240843Smsmith: array-init ( nobj inst class -- ) 61394290Sdcs 0 dup locals| &init &next class inst | 61494290Sdcs \ 61594290Sdcs \ bind methods outside the loop to save time 61694290Sdcs \ 61794290Sdcs class s" init" lookup-method to &init 61894290Sdcs s" next" lookup-method to &next 61994290Sdcs drop 62094290Sdcs 0 ?do 62194290Sdcs inst class 2dup 62294290Sdcs &init execute 62394290Sdcs &next execute drop to inst 62494290Sdcs loop 62540843Smsmith; 62640843Smsmith 62760959Sdcs\ free storage allocated to a heap instance by alloc or alloc-array 62860959Sdcs\ NOTE: not protected against errors like FREEing something that's 62960959Sdcs\ really in the dictionary. 63060959Sdcs: free \ ( instance class -- ) 63194290Sdcs drop free 63294290Sdcs abort" free failed " 63360959Sdcs; 63460959Sdcs 63540843Smsmith\ Instance aliases for common class methods 63640843Smsmith\ Upcast to parent class 63740843Smsmith: super ( instance class -- instance parent-class ) 63840843Smsmith meta metaclass => get-super ; 63940843Smsmith 64040843Smsmith: pedigree ( instance class -- ) 64194290Sdcs object => class 64240843Smsmith metaclass => pedigree ; 64340843Smsmith 64440843Smsmith: size ( instance class -- sizeof-instance ) 64594290Sdcs object => class 64640843Smsmith metaclass => get-size ; 64740843Smsmith 64840843Smsmith: methods ( instance class -- ) 64994290Sdcs object => class 65040843Smsmith metaclass => methods ; 65140843Smsmith 65240843Smsmith\ Array indexing methods... 65340843Smsmith\ Usage examples: 65440843Smsmith\ 10 object-array --> index 65540843Smsmith\ obj --> next 65640843Smsmith\ 65740843Smsmith: index ( n instance class -- instance[n] class ) 65894290Sdcs locals| class inst | 65994290Sdcs inst class 66040843Smsmith object => class 66194290Sdcs metaclass => get-size * ( n*size ) 66294290Sdcs inst + class ; 66340843Smsmith 66440843Smsmith: next ( instance[n] class -- instance[n+1] class ) 66594290Sdcs locals| class inst | 66694290Sdcs inst class 66740843Smsmith object => class 66894290Sdcs metaclass => get-size 66994290Sdcs inst + 67094290Sdcs class ; 67140843Smsmith 67240843Smsmith: prev ( instance[n] class -- instance[n-1] class ) 67394290Sdcs locals| class inst | 67494290Sdcs inst class 67540843Smsmith object => class 67694290Sdcs metaclass => get-size 67794290Sdcs inst swap - 67894290Sdcs class ; 67940843Smsmith 68076116Sdcs: debug ( 2this -- ?? ) 68176116Sdcs find-method-xt debug-xt ; 68276116Sdcs 68376116Sdcsprevious set-current 68440843Smsmith\ E N D O B J E C T 68540843Smsmith 68694290Sdcs\ reset to default search order 68794290Sdcsonly definitions 68840843Smsmith 68994290Sdcs\ redefine oop in default search order to put OOP words in the search order and make them 69094290Sdcs\ the compiling wordlist... 69194290Sdcs 69294290Sdcs: oo only also oop definitions ; 69394290Sdcs 69476116Sdcs\ #endif 695