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]