oo.fr revision 40843
140843Smsmith\ ** ficl/softwords/oo.fr 240843Smsmith\ ** F I C L O - O E X T E N S I O N S 340843Smsmith\ ** john sadler aug 1998 440843Smsmith 540843Smsmith.( loading ficl O-O extensions ) cr 640843Smsmith7 ficl-vocabulary oop 740843Smsmithalso oop definitions 840843Smsmith 940843Smsmith\ Design goals: 1040843Smsmith\ 0. Traditional OOP: late binding by default for safety. 1140843Smsmith\ Early binding if you ask for it. 1240843Smsmith\ 1. Single inheritance 1340843Smsmith\ 2. Object aggregation (has-a relationship) 1440843Smsmith\ 3. Support objects in the dictionary and as proxies for 1540843Smsmith\ existing structures (by reference): 1640843Smsmith\ *** A ficl object can wrap a C struct *** 1740843Smsmith\ 4. Separate name-spaces for methods - methods are 1840843Smsmith\ only visible in the context of a class / object 1940843Smsmith\ 5. Methods can be overridden, and subclasses can add methods. 2040843Smsmith\ No limit on number of methods. 2140843Smsmith 2240843Smsmith\ General info: 2340843Smsmith\ Classes are objects, too: all classes are instances of METACLASS 2440843Smsmith\ All classes are derived (by convention) from OBJECT. This 2540843Smsmith\ base class provides a default initializer and superclass 2640843Smsmith\ access method 2740843Smsmith 2840843Smsmith\ A ficl object binds instance storage (payload) to a class. 2940843Smsmith\ object ( -- instance class ) 3040843Smsmith\ All objects push their payload address and class address when 3140843Smsmith\ executed. All objects have this footprint: 3240843Smsmith\ cell 0: first payload cell 3340843Smsmith 3440843Smsmith\ A ficl class consists of a parent class pointer, a wordlist 3540843Smsmith\ ID for the methods of the class, and a size for the payload 3640843Smsmith\ of objects created by the class. A class is an object. 3740843Smsmith\ The NEW method creates and initializes an instance of a class. 3840843Smsmith\ Classes have this footprint: 3940843Smsmith\ cell 0: parent class address 4040843Smsmith\ cell 1: wordlist ID 4140843Smsmith\ cell 2: size of instance's payload 4240843Smsmith 4340843Smsmith\ Methods expect an object couple ( instance class ) 4440843Smsmith\ on the stack. 4540843Smsmith\ Overridden methods must maintain the same stack signature as 4640843Smsmith\ their predecessors. Ficl has no way of enforcing this, though. 4740843Smsmith 4840843Smsmithuser current-class 4940843Smsmith0 current-class ! 5040843Smsmith 5140843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 5240843Smsmith\ ** L A T E B I N D I N G 5340843Smsmith\ Compile the method name, and code to find and 5440843Smsmith\ execute it at run-time... 5540843Smsmith\ parse-method compiles the method name so that it pushes 5640843Smsmith\ the string base address and count at run-time. 5740843Smsmith\ 5840843Smsmith: parse-method \ name run: ( -- c-addr u ) 5940843Smsmith parse-word 6040843Smsmith postpone sliteral 6140843Smsmith; compile-only 6240843Smsmith 6340843Smsmith: lookup-method ( class c-addr u -- class xt ) 6440843Smsmith 2dup 6540843Smsmith local u 6640843Smsmith local c-addr 6740843Smsmith end-locals 6840843Smsmith 2 pick cell+ @ ( -- class c-addr u wid ) 6940843Smsmith search-wordlist ( -- class 0 | xt 1 | xt -1 ) 7040843Smsmith 0= if 7140843Smsmith c-addr u type ." not found in " 7240843Smsmith body> >name type 7340843Smsmith cr abort 7440843Smsmith endif 7540843Smsmith; 7640843Smsmith 7740843Smsmith: exec-method ( instance class c-addr u -- <method-signature> ) 7840843Smsmith lookup-method execute 7940843Smsmith; 8040843Smsmith 8140843Smsmith: find-method-xt \ name ( class -- class xt ) 8240843Smsmith parse-word lookup-method 8340843Smsmith; 8440843Smsmith 8540843Smsmith 8640843Smsmith\ Method lookup operator takes a class-addr and instance-addr 8740843Smsmith\ and executes the method from the class's wordlist if 8840843Smsmith\ interpreting. If compiling, bind late. 8940843Smsmith\ 9040843Smsmith: --> ( instance class -- ??? ) 9140843Smsmith state @ 0= if 9240843Smsmith find-method-xt execute 9340843Smsmith else 9440843Smsmith parse-method postpone exec-method 9540843Smsmith endif 9640843Smsmith; immediate 9740843Smsmith 9840843Smsmith 9940843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 10040843Smsmith\ ** E A R L Y B I N D I N G 10140843Smsmith\ Early binding operator compiles code to execute a method 10240843Smsmith\ given its class at compile time. Classes are immediate, 10340843Smsmith\ so they leave their cell-pair on the stack when compiling. 10440843Smsmith\ Example: 10540843Smsmith\ : get-wid metaclass => .wid @ ; 10640843Smsmith\ Usage 10740843Smsmith\ my-class get-wid ( -- wid-of-my-class ) 10840843Smsmith\ 10940843Smsmith: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 11040843Smsmith drop find-method-xt compile, drop 11140843Smsmith; immediate compile-only 11240843Smsmith 11340843Smsmith 11440843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 11540843Smsmith\ ** I N S T A N C E V A R I A B L E S 11640843Smsmith\ Instance variables (IV) are represented by words in the class's 11740843Smsmith\ private wordlist. Each IV word contains the offset 11840843Smsmith\ of the IV it represents, and runs code to add that offset 11940843Smsmith\ to the base address of an instance when executed. 12040843Smsmith\ The metaclass SUB method, defined below, leaves the address 12140843Smsmith\ of the new class's offset field and its initial size on the 12240843Smsmith\ stack for these words to update. When a class definition is 12340843Smsmith\ complete, END-CLASS saves the final size in the class's size 12440843Smsmith\ field, and restores the search order and compile wordlist to 12540843Smsmith\ prior state. Note that these words are hidden in their own 12640843Smsmith\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 12740843Smsmith\ 12840843Smsmithwordlist 12940843Smsmithdup constant instance-vars 13040843Smsmithdup >search ficl-set-current 13140843Smsmith: do-instance-var 13240843Smsmith does> ( instance class addr[offset] -- addr[field] ) 13340843Smsmith nip @ + 13440843Smsmith; 13540843Smsmith 13640843Smsmith: addr-units: ( offset size "name" -- offset' ) 13740843Smsmith create over , + 13840843Smsmith do-instance-var 13940843Smsmith; 14040843Smsmith 14140843Smsmith: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 14240843Smsmith chars addr-units: ; 14340843Smsmith 14440843Smsmith: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 14540843Smsmith 1 chars: ; 14640843Smsmith 14740843Smsmith: cells: ( offset nCells "name" -- offset' ) 14840843Smsmith cells >r aligned r> addr-units: 14940843Smsmith; 15040843Smsmith 15140843Smsmith: cell: ( offset nCells "name" -- offset' ) 15240843Smsmith 1 cells: ; 15340843Smsmith 15440843Smsmith\ Aggregate an object into the class... 15540843Smsmith\ Needs the class of the instance to create 15640843Smsmith\ Example: object obj: m_obj 15740843Smsmith\ 15840843Smsmith: do-aggregate 15940843Smsmith does> ( instance class pfa -- a-instance a-class ) 16040843Smsmith 2@ ( inst class a-class a-offset ) 16140843Smsmith 2swap drop ( a-class a-offset inst ) 16240843Smsmith + swap ( a-inst a-class ) 16340843Smsmith; 16440843Smsmith 16540843Smsmith: obj: ( offset class meta "name" -- offset' ) 16640843Smsmith locals| meta class offset | 16740843Smsmith create offset , class , 16840843Smsmith class meta --> get-size offset + 16940843Smsmith do-aggregate 17040843Smsmith; 17140843Smsmith 17240843Smsmith\ Aggregate an array of objects into a class 17340843Smsmith\ Usage example: 17440843Smsmith\ 3 my-class array: my-array 17540843Smsmith\ Makes an instance variable array of 3 instances of my-class 17640843Smsmith\ named my-array. 17740843Smsmith\ 17840843Smsmith: array: ( offset n class meta "name" -- offset' ) 17940843Smsmith locals| meta class nobjs offset | 18040843Smsmith create offset , class , 18140843Smsmith class meta --> get-size nobjs * offset + 18240843Smsmith do-aggregate 18340843Smsmith; 18440843Smsmith 18540843Smsmith\ Aggregate a pointer to an object: REF is a member variable 18640843Smsmith\ whose class is set at compile time. This is useful for wrapping 18740843Smsmith\ data structures in C, where there is only a pointer and the type 18840843Smsmith\ it refers to is known. If you want polymorphism, see c_ref 18940843Smsmith\ in classes.fr. REF is only useful for pre-initialized structures, 19040843Smsmith\ since there's no supported way to set one. 19140843Smsmith: ref: ( offset class meta "name" -- offset' ) 19240843Smsmith locals| meta class offset | 19340843Smsmith create offset , class , 19440843Smsmith offset cell+ 19540843Smsmith does> ( inst class pfa -- ptr-inst ptr-class ) 19640843Smsmith 2@ ( inst class ptr-class ptr-offset ) 19740843Smsmith 2swap drop + @ swap 19840843Smsmith; 19940843Smsmith 20040843Smsmith\ END-CLASS terminates construction of a class by storing 20140843Smsmith\ the size of its instance variables in the class's size field 20240843Smsmith\ ( -- old-wid addr[size] 0 ) 20340843Smsmith\ 20440843Smsmith: end-class ( old-wid addr[size] size -- ) 20540843Smsmith swap ! set-current 20640843Smsmith search> drop \ pop struct builder wordlist 20740843Smsmith; 20840843Smsmith 20940843Smsmithset-current previous 21040843Smsmith\ E N D I N S T A N C E V A R I A B L E S 21140843Smsmith 21240843Smsmith 21340843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 21440843Smsmith\ D O - D O - I N S T A N C E 21540843Smsmith\ Makes a class method that contains the code for an 21640843Smsmith\ instance of the class. This word gets compiled into 21740843Smsmith\ the wordlist of every class by the SUB method. 21840843Smsmith\ PRECONDITION: current-class contains the class address 21940843Smsmith\ 22040843Smsmith: do-do-instance ( -- ) 22140843Smsmith s" : .do-instance does> [ current-class @ ] literal ;" 22240843Smsmith evaluate 22340843Smsmith; 22440843Smsmith 22540843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 22640843Smsmith\ ** M E T A C L A S S 22740843Smsmith\ Every class is an instance of metaclass. This lets 22840843Smsmith\ classes have methods that are different from those 22940843Smsmith\ of their instances. 23040843Smsmith\ Classes are IMMEDIATE to make early binding simpler 23140843Smsmith\ See above... 23240843Smsmith\ 23340843Smsmith:noname 23440843Smsmith wordlist 23540843Smsmith create immediate 23640843Smsmith 0 , \ NULL parent class 23740843Smsmith dup , \ wid 23840843Smsmith 3 cells , \ instance size 23940843Smsmith ficl-set-current 24040843Smsmith does> dup 24140843Smsmith; execute metaclass 24240843Smsmith 24340843Smsmithmetaclass drop current-class ! 24440843Smsmithdo-do-instance 24540843Smsmith 24640843Smsmith\ 24740843Smsmith\ C L A S S M E T H O D S 24840843Smsmith\ 24940843Smsmithinstance-vars >search 25040843Smsmith 25140843Smsmithcreate .super ( class metaclass -- parent-class ) 25240843Smsmith 0 cells , do-instance-var 25340843Smsmith 25440843Smsmithcreate .wid ( class metaclass -- wid ) \ return wid of class 25540843Smsmith 1 cells , do-instance-var 25640843Smsmith 25740843Smsmithcreate .size ( class metaclass -- size ) \ return class's payload size 25840843Smsmith 2 cells , do-instance-var 25940843Smsmith 26040843Smsmithprevious 26140843Smsmith 26240843Smsmith: get-size metaclass => .size @ ; 26340843Smsmith: get-wid metaclass => .wid @ ; 26440843Smsmith: get-super metaclass => .super @ ; 26540843Smsmith 26640843Smsmith\ create an uninitialized instance of a class, leaving 26740843Smsmith\ the address of the new instance and its class 26840843Smsmith\ 26940843Smsmith: instance ( class metaclass "name" -- instance class ) 27040843Smsmith locals| meta parent | 27140843Smsmith create 27240843Smsmith here parent --> .do-instance \ ( inst class ) 27340843Smsmith parent meta metaclass => get-size 27440843Smsmith allot \ allocate payload space 27540843Smsmith; 27640843Smsmith 27740843Smsmith\ create an uninitialized array 27840843Smsmith: array ( n class metaclass "name" -- n instance class ) 27940843Smsmith locals| meta parent nobj | 28040843Smsmith create nobj 28140843Smsmith here parent --> .do-instance \ ( nobj inst class ) 28240843Smsmith parent meta metaclass => get-size 28340843Smsmith nobj * allot \ allocate payload space 28440843Smsmith; 28540843Smsmith 28640843Smsmith\ create an initialized instance 28740843Smsmith\ 28840843Smsmith: new \ ( class metaclass "name" -- ) 28940843Smsmith metaclass => instance --> init 29040843Smsmith; 29140843Smsmith 29240843Smsmith\ create an initialized array of instances 29340843Smsmith: new-array ( n class metaclass "name" -- ) 29440843Smsmith metaclass => array 29540843Smsmith --> array-init 29640843Smsmith; 29740843Smsmith 29840843Smsmith\ create a proxy object with initialized payload address given 29940843Smsmith: ref ( instance-addr class metaclass "name" -- ) 30040843Smsmith drop create , , 30140843Smsmith does> 2@ 30240843Smsmith; 30340843Smsmith 30440843Smsmith\ create a subclass 30540843Smsmith: sub ( class metaclass "name" -- old-wid addr[size] size ) 30640843Smsmith wordlist 30740843Smsmith locals| wid meta parent | 30840843Smsmith parent meta metaclass => get-wid 30940843Smsmith wid wid-set-super 31040843Smsmith create immediate 31140843Smsmith here current-class ! \ prep for do-do-instance 31240843Smsmith parent , \ save parent class 31340843Smsmith wid , \ save wid 31440843Smsmith here parent meta --> get-size dup , ( addr[size] size ) 31540843Smsmith metaclass => .do-instance 31640843Smsmith wid ficl-set-current -rot 31740843Smsmith do-do-instance 31840843Smsmith instance-vars >search \ push struct builder wordlist 31940843Smsmith; 32040843Smsmith 32140843Smsmith\ OFFSET-OF returns the offset of an instance variable 32240843Smsmith\ from the instance base address. If the next token is not 32340843Smsmith\ the name of in instance variable method, you get garbage 32440843Smsmith\ results -- there is no way at present to check for this error. 32540843Smsmith: offset-of ( class metaclass "name" -- offset ) 32640843Smsmith drop find-method-xt nip >body @ ; 32740843Smsmith 32840843Smsmith\ ID returns the string name cell-pair of its class 32940843Smsmith: id ( class metaclass -- c-addr u ) 33040843Smsmith drop body> >name ; 33140843Smsmith 33240843Smsmith\ list methods of the class 33340843Smsmith: methods \ ( class meta -- ) 33440843Smsmith locals| meta class | 33540843Smsmith begin 33640843Smsmith class body> >name type ." methods:" cr 33740843Smsmith class meta --> get-wid >search words cr previous 33840843Smsmith class meta metaclass => get-super 33940843Smsmith dup to class 34040843Smsmith 0= until cr 34140843Smsmith; 34240843Smsmith 34340843Smsmith\ list class's ancestors 34440843Smsmith: pedigree ( class meta -- ) 34540843Smsmith locals| meta class | 34640843Smsmith begin 34740843Smsmith class body> >name type space 34840843Smsmith class meta metaclass => get-super 34940843Smsmith dup to class 35040843Smsmith 0= until cr 35140843Smsmith; 35240843Smsmith 35340843Smsmith\ decompile a method 35440843Smsmith: see ( class meta -- ) 35540843Smsmith metaclass => get-wid >search see previous ; 35640843Smsmith 35740843Smsmithset-current 35840843Smsmith\ E N D M E T A C L A S S 35940843Smsmith 36040843Smsmith\ META is a nickname for the address of METACLASS... 36140843Smsmithmetaclass drop 36240843Smsmithconstant meta 36340843Smsmith 36440843Smsmith\ SUBCLASS is a nickname for a class's SUB method... 36540843Smsmith\ Subclass compilation ends when you invoke end-class 36640843Smsmith\ This method is late bound for safety... 36740843Smsmith: subclass --> sub ; 36840843Smsmith 36940843Smsmith 37040843Smsmith\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 37140843Smsmith\ ** O B J E C T 37240843Smsmith\ Root of all classes 37340843Smsmith:noname 37440843Smsmith wordlist 37540843Smsmith create immediate 37640843Smsmith 0 , \ NULL parent class 37740843Smsmith dup , \ wid 37840843Smsmith 0 , \ instance size 37940843Smsmith ficl-set-current 38040843Smsmith does> meta 38140843Smsmith; execute object 38240843Smsmith 38340843Smsmithobject drop current-class ! 38440843Smsmithdo-do-instance 38540843Smsmith 38640843Smsmith\ O B J E C T M E T H O D S 38740843Smsmith\ Convert instance cell-pair to class cell-pair 38840843Smsmith\ Useful for binding class methods from an instance 38940843Smsmith: class ( instance class -- class metaclass ) 39040843Smsmith nip meta ; 39140843Smsmith 39240843Smsmith\ default INIT method zero fills an instance 39340843Smsmith: init ( instance class -- ) 39440843Smsmith meta 39540843Smsmith metaclass => get-size ( inst size ) 39640843Smsmith erase ; 39740843Smsmith 39840843Smsmith\ Apply INIT to an array of NOBJ objects... 39940843Smsmith\ 40040843Smsmith: array-init ( nobj inst class -- ) 40140843Smsmith 0 dup locals| &init &next class inst | 40240843Smsmith \ 40340843Smsmith \ bind methods outside the loop to save time 40440843Smsmith \ 40540843Smsmith class s" init" lookup-method to &init 40640843Smsmith s" next" lookup-method to &next 40740843Smsmith drop 40840843Smsmith 0 ?do 40940843Smsmith inst class 2dup 41040843Smsmith &init execute 41140843Smsmith &next execute drop to inst 41240843Smsmith loop 41340843Smsmith; 41440843Smsmith 41540843Smsmith\ Instance aliases for common class methods 41640843Smsmith\ Upcast to parent class 41740843Smsmith: super ( instance class -- instance parent-class ) 41840843Smsmith meta metaclass => get-super ; 41940843Smsmith 42040843Smsmith: pedigree ( instance class -- ) 42140843Smsmith object => class 42240843Smsmith metaclass => pedigree ; 42340843Smsmith 42440843Smsmith: size ( instance class -- sizeof-instance ) 42540843Smsmith object => class 42640843Smsmith metaclass => get-size ; 42740843Smsmith 42840843Smsmith: methods ( instance class -- ) 42940843Smsmith object => class 43040843Smsmith metaclass => methods ; 43140843Smsmith 43240843Smsmith\ Array indexing methods... 43340843Smsmith\ Usage examples: 43440843Smsmith\ 10 object-array --> index 43540843Smsmith\ obj --> next 43640843Smsmith\ 43740843Smsmith: index ( n instance class -- instance[n] class ) 43840843Smsmith locals| class inst | 43940843Smsmith inst class 44040843Smsmith object => class 44140843Smsmith metaclass => get-size * ( n*size ) 44240843Smsmith inst + class ; 44340843Smsmith 44440843Smsmith: next ( instance[n] class -- instance[n+1] class ) 44540843Smsmith locals| class inst | 44640843Smsmith inst class 44740843Smsmith object => class 44840843Smsmith metaclass => get-size 44940843Smsmith inst + 45040843Smsmith class ; 45140843Smsmith 45240843Smsmith: prev ( instance[n] class -- instance[n-1] class ) 45340843Smsmith locals| class inst | 45440843Smsmith inst class 45540843Smsmith object => class 45640843Smsmith metaclass => get-size 45740843Smsmith inst swap - 45840843Smsmith class ; 45940843Smsmith 46040843Smsmithset-current 46140843Smsmith\ E N D O B J E C T 46240843Smsmith 46340843Smsmith 46440843Smsmithprevious definitions 465