diff options
Diffstat (limited to 'softcore/oo.fr')
| -rw-r--r-- | softcore/oo.fr | 700 |
1 files changed, 700 insertions, 0 deletions
diff --git a/softcore/oo.fr b/softcore/oo.fr new file mode 100644 index 000000000000..fcb801d7de26 --- /dev/null +++ b/softcore/oo.fr @@ -0,0 +1,700 @@ +S" FICL_WANT_OOP" ENVIRONMENT? drop [if] +\ ** ficl/softwords/oo.fr +\ ** F I C L O - O E X T E N S I O N S +\ ** john sadler aug 1998 + +.( loading ficl O-O extensions ) cr +17 ficl-vocabulary oop +also oop definitions + +\ Design goals: +\ 0. Traditional OOP: late binding by default for safety. +\ Early binding if you ask for it. +\ 1. Single inheritance +\ 2. Object aggregation (has-a relationship) +\ 3. Support objects in the dictionary and as proxies for +\ existing structures (by reference): +\ *** A ficl object can wrap a C struct *** +\ 4. Separate name-spaces for methods - methods are +\ only visible in the context of a class / object +\ 5. Methods can be overridden, and subclasses can add methods. +\ No limit on number of methods. + +\ General info: +\ Classes are objects, too: all classes are instances of METACLASS +\ All classes are derived (by convention) from OBJECT. This +\ base class provides a default initializer and superclass +\ access method + +\ A ficl object binds instance storage (payload) to a class. +\ object ( -- instance class ) +\ All objects push their payload address and class address when +\ executed. + +\ A ficl class consists of a parent class pointer, a wordlist +\ ID for the methods of the class, and a size for the payload +\ of objects created by the class. A class is an object. +\ The NEW method creates and initializes an instance of a class. +\ Classes have this footprint: +\ cell 0: parent class address +\ cell 1: wordlist ID +\ cell 2: size of instance's payload + +\ Methods expect an object couple ( instance class ) +\ on the stack. This is by convention - ficl has no way to +\ police your code to make sure this is always done, but it +\ happens naturally if you use the facilities presented here. +\ +\ Overridden methods must maintain the same stack signature as +\ their predecessors. Ficl has no way of enforcing this, either. +\ +\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now +\ has an extra field for the vtable method count. Hasvtable declares +\ refs to vtable classes +\ +\ Revised Nov 2001 - metaclass debug method now finds only metaclass methods +\ +\ Planned: Ficl vtable support +\ Each class has a vtable size parameter +\ END-CLASS allocates and clears the vtable - then it walks class's method +\ list and inserts all new methods into table. For each method, if the table +\ slot is already nonzero, do nothing (overridden method). Otherwise fill +\ vtable slot. Now do same check for parent class vtable, filling only +\ empty slots in the new vtable. +\ Methods are now structured as follows: +\ - header +\ - vtable index +\ - xt +\ :noname definition for code +\ +\ : is redefined to check for override, fill in vtable index, increment method +\ count if not an override, create header and fill in index. Allot code pointer +\ and run :noname +\ ; is overridden to fill in xt returned by :noname +\ --> compiles code to fetch vtable address, offset by index, and execute +\ => looks up xt in the vtable and compiles it directly + + + +user current-class +0 current-class ! + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +\ ** L A T E B I N D I N G +\ Compile the method name, and code to find and +\ execute it at run-time... +\ + +\ p a r s e - m e t h o d +\ compiles a method name so that it pushes +\ the string base address and count at run-time. + +: parse-method \ name run: ( -- c-addr u ) + parse-word + postpone sliteral +; compile-only + + + +: (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 } + class name class cell+ @ ( class c-addr u wid ) + search-wordlist +; + +\ l o o k u p - m e t h o d +\ takes a counted string method name from the stack (as compiled +\ by parse-method) and attempts to look this method up in the method list of +\ the class that's on the stack. If successful, it leaves the class on the stack +\ and pushes the xt of the method. If not, it aborts with an error message. + +: lookup-method { class 2:name -- class xt } + class name (lookup-method) ( 0 | xt 1 | xt -1 ) + 0= if + name type ." not found in " + class body> >name type + cr abort + endif +; + +: find-method-xt \ name ( class -- class xt ) + parse-word lookup-method +; + +: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) + lookup-method catch +; + +: exec-method ( instance class c-addr u -- <method-signature> ) + lookup-method execute +; + +\ Method lookup operator takes a class-addr and instance-addr +\ and executes the method from the class's wordlist if +\ interpreting. If compiling, bind late. +\ +: --> ( instance class -- ??? ) + state @ 0= if + find-method-xt execute + else + parse-method postpone exec-method + endif +; immediate + +\ Method lookup with CATCH in case of exceptions +: c-> ( instance class -- ?? exc-flag ) + state @ 0= if + find-method-xt catch + else + parse-method postpone catch-method + endif +; immediate + +\ METHOD makes global words that do method invocations by late binding +\ in case you prefer this style (no --> in your code) +\ Example: everything has next and prev for array access, so... +\ method next +\ method prev +\ my-instance next ( does whatever next does to my-instance by late binding ) + +: method create does> body> >name lookup-method execute ; + + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +\ ** E A R L Y B I N D I N G +\ Early binding operator compiles code to execute a method +\ given its class at compile time. Classes are immediate, +\ so they leave their cell-pair on the stack when compiling. +\ Example: +\ : get-wid metaclass => .wid @ ; +\ Usage +\ my-class get-wid ( -- wid-of-my-class ) +\ +1 ficl-named-wordlist instance-vars +instance-vars dup >search ficl-set-current + +: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method + drop find-method-xt compile, drop +; immediate compile-only + +: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class + current-class @ dup postpone => +; immediate compile-only + +\ Problem: my=[ assumes that each method except the last is an obj: member +\ which contains its class as the first field of its parameter area. The code +\ detects non-obect members and assumes the class does not change in this case. +\ This handles methods like index, prev, and next correctly, but does not deal +\ correctly with CLASS. +: my=[ \ same as my=> , but binds a chain of methods + current-class @ + begin + parse-word 2dup ( class c-addr u c-addr u ) + s" ]" compare while ( class c-addr u ) + lookup-method ( class xt ) + dup compile, ( class xt ) + dup ?object if \ If object member, get new class. Otherwise assume same class + nip >body cell+ @ ( new-class ) + else + drop ( class ) + endif + repeat 2drop drop +; immediate compile-only + + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +\ ** I N S T A N C E V A R I A B L E S +\ Instance variables (IV) are represented by words in the class's +\ private wordlist. Each IV word contains the offset +\ of the IV it represents, and runs code to add that offset +\ to the base address of an instance when executed. +\ The metaclass SUB method, defined below, leaves the address +\ of the new class's offset field and its initial size on the +\ stack for these words to update. When a class definition is +\ complete, END-CLASS saves the final size in the class's size +\ field, and restores the search order and compile wordlist to +\ prior state. Note that these words are hidden in their own +\ wordlist to prevent accidental use outside a SUB END-CLASS pair. +\ +: do-instance-var + does> ( instance class addr[offset] -- addr[field] ) + nip @ + +; + +: addr-units: ( offset size "name" -- offset' ) + create over , + + do-instance-var +; + +: chars: \ ( offset nCells "name" -- offset' ) Create n char member. + chars addr-units: ; + +: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. + 1 chars: ; + +: cells: ( offset nCells "name" -- offset' ) + cells >r aligned r> addr-units: +; + +: cell: ( offset nCells "name" -- offset' ) + 1 cells: ; + +\ Aggregate an object into the class... +\ Needs the class of the instance to create +\ Example: object obj: m_obj +\ +: do-aggregate + objectify + does> ( instance class pfa -- a-instance a-class ) + 2@ ( inst class a-class a-offset ) + 2swap drop ( a-class a-offset inst ) + + swap ( a-inst a-class ) +; + +: obj: { offset class meta -- offset' } \ "name" + create offset , class , + class meta --> get-size offset + + do-aggregate +; + +\ Aggregate an array of objects into a class +\ Usage example: +\ 3 my-class array: my-array +\ Makes an instance variable array of 3 instances of my-class +\ named my-array. +\ +: array: ( offset n class meta "name" -- offset' ) + locals| meta class nobjs offset | + create offset , class , + class meta --> get-size nobjs * offset + + do-aggregate +; + +\ Aggregate a pointer to an object: REF is a member variable +\ whose class is set at compile time. This is useful for wrapping +\ data structures in C, where there is only a pointer and the type +\ it refers to is known. If you want polymorphism, see c_ref +\ in classes.fr. REF is only useful for pre-initialized structures, +\ since there's no supported way to set one. +: ref: ( offset class meta "name" -- offset' ) + locals| meta class offset | + create offset , class , + offset cell+ + does> ( inst class pfa -- ptr-inst ptr-class ) + 2@ ( inst class ptr-class ptr-offset ) + 2swap drop + @ swap +; + +S" FICL_WANT_VCALL" ENVIRONMENT? drop [if] +\ vcall extensions contributed by Guy Carver +: vcall: ( paramcnt "name" -- ) + current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. + create , , \ ( paramcnt index -- ) + does> \ ( inst class pfa -- ptr-inst ptr-class ) + nip 2@ vcall \ ( params offset inst class offset -- ) +; + +: vcallr: 0x80000000 or vcall: ; \ Call with return address desired. + +S" FICL_WANT_FLOAT" ENVIRONMENT? drop [if] +: vcallf: \ ( paramcnt -<name>- f: r ) + 0x80000000 or + current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. + create , , \ ( paramcnt index -- ) + does> \ ( inst class pfa -- ptr-inst ptr-class ) + nip 2@ vcall f> \ ( params offset inst class offset -- f: r ) +; + +[endif] \ FICL_WANT_FLOAT +[endif] \ FICL_WANT_VCALL + +\ END-CLASS terminates construction of a class by storing +\ the size of its instance variables in the class's size field +\ ( -- old-wid addr[size] 0 ) +\ +: end-class ( old-wid addr[size] size -- ) + swap ! set-current + search> drop \ pop struct builder wordlist +; + +\ See resume-class (a metaclass method) below for usage +\ This is equivalent to end-class for now, but that will change +\ when we support vtable bindings. +: suspend-class ( old-wid addr[size] size -- ) end-class ; + +set-current previous +\ E N D I N S T A N C E V A R I A B L E S + + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +\ D O - D O - I N S T A N C E +\ Makes a class method that contains the code for an +\ instance of the class. This word gets compiled into +\ the wordlist of every class by the SUB method. +\ PRECONDITION: current-class contains the class address +\ why use a state variable instead of the stack? +\ >> Stack state is not well-defined during compilation (there are +\ >> control structure match codes on the stack, of undefined size +\ >> easiest way around this is use of this thread-local variable +\ +: do-do-instance ( -- ) + s" : .do-instance does> [ current-class @ ] literal ;" + evaluate +; + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +\ ** M E T A C L A S S +\ Every class is an instance of metaclass. This lets +\ classes have methods that are different from those +\ of their instances. +\ Classes are IMMEDIATE to make early binding simpler +\ See above... +\ +:noname + wordlist + create + immediate + 0 , \ NULL parent class + dup , \ wid +[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if] + 4 cells , \ instance size +[else] + 3 cells , \ instance size +[endif] + ficl-set-current + does> dup +; execute metaclass +\ now brand OBJECT's wordlist (so that ORDER can display it by name) +metaclass drop cell+ @ brand-wordlist + +metaclass drop current-class ! +do-do-instance + +\ +\ C L A S S M E T H O D S +\ +instance-vars >search + +create .super ( class metaclass -- parent-class ) + 0 cells , do-instance-var + +create .wid ( class metaclass -- wid ) \ return wid of class + 1 cells , do-instance-var + +S" FICL_WANT_VCALL" ENVIRONMENT? drop [if] +create .vtCount \ Number of VTABLE methods, if any + 2 cells , do-instance-var + +create .size ( class metaclass -- size ) \ return class's payload size + 3 cells , do-instance-var + +[else] + +create .size ( class metaclass -- size ) \ return class's payload size + 2 cells , do-instance-var + +[endif] + +: get-size metaclass => .size @ ; +: get-wid metaclass => .wid @ ; +: get-super metaclass => .super @ ; +S" FICL_WANT_VCALL" ENVIRONMENT? drop [if] +: get-vtCount metaclass => .vtCount @ ; +: get-vtAdd metaclass => .vtCount ; +[endif] + +\ create an uninitialized instance of a class, leaving +\ the address of the new instance and its class +\ +: instance ( class metaclass "name" -- instance class ) + locals| meta parent | + create + here parent --> .do-instance \ ( inst class ) + parent meta metaclass => get-size + allot \ allocate payload space +; + +\ create an uninitialized array +: array ( n class metaclass "name" -- n instance class ) + locals| meta parent nobj | + create nobj + here parent --> .do-instance \ ( nobj inst class ) + parent meta metaclass => get-size + nobj * allot \ allocate payload space +; + +\ create an initialized instance +\ +: new \ ( class metaclass "name" -- ) + metaclass => instance --> init +; + +\ create an initialized array of instances +: new-array ( n class metaclass "name" -- ) + metaclass => array + --> array-init +; + +\ Create an anonymous initialized instance from the heap +: alloc \ ( class metaclass -- instance class ) + locals| meta class | + class meta metaclass => get-size allocate ( -- addr fail-flag ) + abort" allocate failed " ( -- addr ) + class 2dup --> init +; + +\ Create an anonymous array of initialized instances from the heap +: alloc-array \ ( n class metaclass -- instance class ) + locals| meta class nobj | + class meta metaclass => get-size + nobj * allocate ( -- addr fail-flag ) + abort" allocate failed " ( -- addr ) + nobj over class --> array-init + class +; + +\ Create an anonymous initialized instance from the dictionary +: allot { 2:this -- 2:instance } + here ( instance-address ) + this my=> get-size allot + this drop 2dup --> init +; + +\ Create an anonymous array of initialized instances from the dictionary +: allot-array { nobj 2:this -- 2:instance } + here ( instance-address ) + this my=> get-size nobj * allot + this drop 2dup ( 2instance 2instance ) + nobj -rot --> array-init +; + +\ create a proxy object with initialized payload address given +: ref ( instance-addr class metaclass "name" -- ) + drop create , , + does> 2@ +; + +\ suspend-class and resume-class help to build mutually referent classes. +\ Example: +\ object subclass c-akbar +\ suspend-class ( put akbar on hold while we define jeff ) +\ object subclass c-jeff +\ c-akbar ref: .akbar +\ ( and whatever else comprises this class ) +\ end-class ( done with c-jeff ) +\ c-akbar --> resume-class +\ c-jeff ref: .jeff +\ ( and whatever else goes in c-akbar ) +\ end-class ( done with c-akbar ) +\ +: resume-class { 2:this -- old-wid addr[size] size } + this --> .wid @ ficl-set-current ( old-wid ) + this --> .size dup @ ( old-wid addr[size] size ) + instance-vars >search +; + +\ create a subclass +\ This method leaves the stack and search order ready for instance variable +\ building. Pushes the instance-vars wordlist onto the search order, +\ and sets the compilation wordlist to be the private wordlist of the +\ new class. The class's wordlist is deliberately NOT in the search order - +\ to prevent methods from getting used with wrong data. +\ Postcondition: leaves the address of the new class in current-class +: sub ( class metaclass "name" -- old-wid addr[size] size ) + wordlist + locals| wid meta parent | + parent meta metaclass => get-wid + wid wid-set-super \ set superclass + create immediate \ get the subclass name + wid brand-wordlist \ label the subclass wordlist + here current-class ! \ prep for do-do-instance + parent , \ save parent class + wid , \ save wid +[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if] + parent meta --> get-vtCount , +[endif] + here parent meta --> get-size dup , ( addr[size] size ) + metaclass => .do-instance + wid ficl-set-current -rot + do-do-instance + instance-vars >search \ push struct builder wordlist +; + +\ OFFSET-OF returns the offset of an instance variable +\ from the instance base address. If the next token is not +\ the name of in instance variable method, you get garbage +\ results -- there is no way at present to check for this error. +: offset-of ( class metaclass "name" -- offset ) + drop find-method-xt nip >body @ ; + +\ ID returns the string name cell-pair of its class +: id ( class metaclass -- c-addr u ) + drop body> >name ; + +\ list methods of the class +: methods \ ( class meta -- ) + locals| meta class | + begin + class body> >name type ." methods:" cr + class meta --> get-wid >search words cr previous + class meta metaclass => get-super + dup to class + 0= until cr +; + +\ list class's ancestors +: pedigree ( class meta -- ) + locals| meta class | + begin + class body> >name type space + class meta metaclass => get-super + dup to class + 0= until cr +; + +\ decompile an instance method +: see ( class meta -- ) + metaclass => get-wid >search see previous ; + +\ debug a method of metaclass +\ Eg: my-class --> debug my-method +: debug ( class meta -- ) + find-method-xt debug-xt ; + +previous set-current +\ E N D M E T A C L A S S + +\ ** META is a nickname for the address of METACLASS... +metaclass drop +constant meta + +\ ** SUBCLASS is a nickname for a class's SUB method... +\ Subclass compilation ends when you invoke end-class +\ This method is late bound for safety... +: subclass --> sub ; + +S" FICL_WANT_VCALL" ENVIRONMENT? drop [if] +\ VTABLE Support extensions (Guy Carver) +\ object --> sub mine hasvtable +: hasvtable 4 + ; immediate +[endif] + + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +\ ** O B J E C T +\ Root of all classes +:noname + wordlist + create immediate + 0 , \ NULL parent class + dup , \ wid + 0 , \ instance size +[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if] + 0 , \ .vtCount +[endif] + ficl-set-current + does> meta +; execute object +\ now brand OBJECT's wordlist (so that ORDER can display it by name) +object drop cell+ @ brand-wordlist + +object drop current-class ! +do-do-instance +instance-vars >search + +\ O B J E C T M E T H O D S +\ Convert instance cell-pair to class cell-pair +\ Useful for binding class methods from an instance +: class ( instance class -- class metaclass ) + nip meta ; + +\ default INIT method zero fills an instance +: init ( instance class -- ) + meta + metaclass => get-size ( inst size ) + erase ; + +\ Apply INIT to an array of NOBJ objects... +\ +: array-init ( nobj inst class -- ) + 0 dup locals| &init &next class inst | + \ + \ bind methods outside the loop to save time + \ + class s" init" lookup-method to &init + s" next" lookup-method to &next + drop + 0 ?do + inst class 2dup + &init execute + &next execute drop to inst + loop +; + +\ free storage allocated to a heap instance by alloc or alloc-array +\ NOTE: not protected against errors like FREEing something that's +\ really in the dictionary. +: free \ ( instance class -- ) + drop free + abort" free failed " +; + +\ Instance aliases for common class methods +\ Upcast to parent class +: super ( instance class -- instance parent-class ) + meta metaclass => get-super ; + +: pedigree ( instance class -- ) + object => class + metaclass => pedigree ; + +: size ( instance class -- sizeof-instance ) + object => class + metaclass => get-size ; + +: methods ( instance class -- ) + object => class + metaclass => methods ; + +\ Array indexing methods... +\ Usage examples: +\ 10 object-array --> index +\ obj --> next +\ +: index ( n instance class -- instance[n] class ) + locals| class inst | + inst class + object => class + metaclass => get-size * ( n*size ) + inst + class ; + +: next ( instance[n] class -- instance[n+1] class ) + locals| class inst | + inst class + object => class + metaclass => get-size + inst + + class ; + +: prev ( instance[n] class -- instance[n-1] class ) + locals| class inst | + inst class + object => class + metaclass => get-size + inst swap - + class ; + +: debug ( 2this -- ?? ) + find-method-xt debug-xt ; + +previous set-current +\ E N D O B J E C T + +\ reset to default search order +only definitions + +\ redefine oop in default search order to put OOP words in the search order and make them +\ the compiling wordlist... + +: oo only also oop definitions ; + +[endif] |