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] 701