\ BINDING for Object Oriented Development Environment
\
\ This code provides words for binding a message to the appropriate
\ method for an object.  Binding can occur at compile time ( "EARLY" ),
\ or at run time, ( "LATE" )
\ 
\ Author: Phil Burk
\ Copyright 1986 Phil Burk
\
\ MOD: PLB 11/29/86 Added MAC RO calls.
\   For relocating systems, like on the MAC, relocatable tokens
\   are stored in the dictionary, and absolute addresses are used at
\   run time (when possible ).  The object stack contains absolute
\   addresses.  The CFAs for methods are stored as relocatable tokens.
\ MOD: PLB 5/13/87 Change OS-STACK-PTR to OSSTACKPTR for Mac
\ MOD: PLB 5/24/87 Compile time check for Illegal Method.
\ MOD: PLB 9/6/87 Add binding for Instance Objects.
\ MOD: PLB 9/8/87 Preshift late bound offset in OB.LATE.BIND
\      mdh 7/2/88 changed appropriate 'literal's to 'aliterals's
\ MOD: PLB 7/25/88 USE OB.OBJ->CFA_BASE in OB.BIND.RUN

ANEW TASK-OBJ_BINDING

( Bind a method found in a CFA array. )
( Object base holds a pointer to an array of method CFAS )
: OB.OBJ->CFA_BASE  ( abs_obj_base -- abs_cfa_base )
     @  rel->use  ( relocate rel_cfa_base %R )
;

: OB.OBJ->CLASS  ( abs_obj_base -- abs_class_base )
     ob.obj->cfa_base ob_cfas -
;

: OB.CFA@ ( abs_obj_base method_index -- rel_method_cfa , CFA for method )
    cell* swap    ob.obj->cfa_base
    + @
;

\ Error Checking for binding --------------------------------------
: OB.CHECK.CLASS  ( abs_class_base -- , abort if not a class )
    ob_valid_key + @ ob_valid.key = NOT
    IF   " OB.CHECK.CLASS" " CLASS KEY not found! Not a REAL object!"
         er_fatal er.report
    THEN
;

: OB.CHECK.METHOD  ( method_index abs_class_base -- , abort if bad method )
    ob_#methods + @ >
    IF   " OB.CHECK.METHOD" " Method not supported for that object!"
         er_fatal er.report
    THEN
;

: OB.CHECK.BIND ( abs_obj_base method_index -- , abort if bad )
    swap ob.obj->class
    dup ob.check.class
    ob.check.method
;

\ DO compile time checking for illegal methods.
: OB.CHECK.ILLEGAL ( rel_method_cfa -- )
    rel->use 'c ob.bad.method =
    IF " OB.CHECK.ILLEGAL" " Method not defined for this class."
       er_fatal er.report
    THEN
;

\ Compile code to execute method for an object. ---------------
#HOST_AMIGA_JFORTH .IF
: OB.BIND.CFA  ( abs_obj_base rel_method_cfa -- , binds method to object )
    dup ob.check.illegal swap
    STATE @ IF
        [compile] aliteral
        compile os.push
        calladr,
        compile os.drop
    ELSE
        os.push
        execute  os.drop
    THEN
;

: OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- )
    dup ob.check.illegal swap
    state @
    IF  [compile] literal
        compile os+
        compile os.push
        calladr,
        compile os.drop
    ELSE
        os+ os.push
        execute os.drop
    THEN
;
    
.THEN

#HOST_MAC_MACH2 .IF
: (OB.EXEC.METHOD)  ( rel_method_cfa rel_obj_base -- )
    rel->use os.push ro.execute os.drop
;

: OB.BIND.CFA  ( abs_obj_base rel_method_cfa -- , binds method to object )
    dup ob.check.illegal
    STATE @ IF
        [compile] aliteral  ( cfa )
        use->rel [compile] aliteral    ( rel_obj )
        compile (ob.exec.method)
    ELSE
        swap os.push ro.execute os.drop
    THEN
;

: (OB.EXEC.METHOD.I)  ( rel_method_cfa offset -- )
    os+ os.push ro.execute os.drop
;

: OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- )
    dup ob.check.illegal
    state @
    IF 
        [compile] aliteral  ( cfa )
        [compile]  literal  ( offset )
        compile (ob.exec.method.i)
    ELSE
        swap os+ os.push
        ro.execute os.drop
    THEN
;
.THEN

V: OB-IF-CHECK-BIND

max-inline @ 200 max-inline ! ( optimize !! )

: OB.BIND.RUN  ( rel_obj_base method_index*4 -- , run time binding act)
    >r rel->use
    ob-if-check-bind @
    IF dup r@ cell/ ob.check.bind
    THEN
    dup os.push   ( push object onto object stack )
\    @ ( get base of cfas ) r> +  ( index to method cfa )
    @ rel->use r> +  ( index to method cfa )
    @ rel->use execute   ( Perform method on object. )
    os.drop
;
max-inline !

: OB.LATE.BIND  ( [rel_obj_base] method_index -- , do late binding of method )
\  rel_obj_base not present at compile time.
    STATE @ IF
        cell* ( preshift for faster run time )
        [compile] literal  ( save method index for late binding )
        compile ob.bind.run
    ELSE  cell* ob.bind.run
    THEN
;

: SELF ( -- rel_obj_base, of_self ) 
    os.copy  use->rel ( %R )
;

EXISTS? [] NOT .IF
: []   ( -- , use late binding if 'method: []' )
     " OBJECT USE" " '[]' CAN ONLY BE AFTER A METHOD"
      er_fatal  er.report
;
.THEN

: SUPER ( --- , stub for superbinding )
     " OBJECT USE" " 'SUPER' can only be used inside a METHOD definition"
     er_fatal  er.report
;

\ Binding with super-dooper uses the method defined in a superclasses'
\ superclass.
: SUPER-DOOPER ( --- , stub for superbinding with skip )
     " OBJECT USE"
     " 'SUPER-DOOPER' can only be used inside a METHOD definition"
     er_fatal  er.report
;


#HOST_AMIGA_JFORTH .IF
: OB.BIND.'BASE ( CFA -- , bind CFA to current object )
     ?comp calladr,
;
.THEN

#HOST_MAC_MACH2 .IF
: OB.BIND.'BASE  ( rel_CFA -- , bind CFA to current object )
     ?comp [compile] aliteral   compile ro.execute
;
.THEN

\ These words work off of a variable that contains an abs_cfa_base.
: OB.BIND.VAR ( method_index cfa_base_variable -- , bind from that variable )
    @ swap cell* + @  ( -- method_cfa )
    dup ob.check.illegal
    ob.bind.'base  ( %? )
;

: OB.BIND.INSTANCE ( method_index pfa_object_def -- )
    dup ..@ obi_offset ( get offset )
    -rot  ..@ obi_rel_class rel->use .. ob_cfas ( -- off mi acfas )
    swap cell* + @ 
    ob.bind.instance.cfa
;

: OB.BIND.NORMAL  ( method_index pfa_object -- )
    dup rot 2dup ob.check.bind
    ob.cfa@ ob.bind.cfa
;

: OB.EARLY.BIND  ( method_index cfa_object -- )
    cfa->pfa
    ob-state @ ob_def_class =
    IF  dup ob-current-class @
        ob.is.instance? ( Check to see if this is an Instance Object.)
        IF ob.bind.instance
        ELSE ob.bind.normal
        THEN
    ELSE ob.bind.normal
    THEN
;

: OB.BIND   ( method_index <object> -- , bind )
    ho.find.cfa NOT IF
       " OB.BIND" " Object not found!"
       er_fatal  er.report
    THEN  ( -- mi cfa )
    CASE  ( Different types of binding. )
\ Assume rel_obj_base also on stack at runtime for late binding.
        'c []           OF ob.late.bind
                        ENDOF
        'c SELF         OF ob-self-cfas ob.bind.var
                        ENDOF
        'c SUPER        OF ob-super-cfas ob.bind.var
                        ENDOF
        'c SUPER-DOOPER OF ob-dooper-cfas ob.bind.var
                        ENDOF
\ Bind named object.
        ob.early.bind 0   ( needs zero for dropping )
    ENDCASE
;