\ Реализация классов для InfoForth'a
\ File: CLASS.SCR                                    4.Dec.96 
\  Written by Nicholas Nemtsev, 1996
\
\  Object programming
\  Usage: 1 LOAD
\
\ Definition:                        Usage class:
\  CLASS <class-name>                 <class-name> <instance>
\    [DERIVE <base-class-name>]        <instance> <method>
\    [<num-virtual-methods> VIRTUAL]   <instance> <v.m.>
\    {<size-item> ITEM <item-name>}    <instance> <item>
\    {::CONSTR <constr-name> ... ;}    NEW <class-name>
\    {::DESTR  <destr-name> ... ;}     <adr-class> (NEW)
\    {::VIRTUAL <v.m.-name> ... ;}     <adr-inst> DELETE
\    {:: <method-name> ... ;}          SEE <class-name>
\  END <class-name>
\ Useful words                                        20/Aug/97
    : VFIND ( Voc Word -> CFA LenNameByte /0)
         -1 -rot dup ?upper (find) dup
         IF 64 AND IF 1 ELSE -1 THEN THEN ;
    : V' ( "word" \ Voc -> CFA)
         bl word VFIND  0= 0 ?error ;
    label do-does
        BP, SP XCHG  SI PUSH  BP, SP XCHG
        SI POP  ( SI INC )  BX INC  BX INC  BX PUSH next;
    ( DOES: - def. of a programm for CFA. See 8,10,14-th blocks)
    : DOES: create [ hex ] 0E8 [ decimal ] c,
        do-does here 2+ - , smudge !CSP ] ;
    ( SEE - setting context of a class)
    : SEE ( "class-name" \ ->) ' >VOC context ! ; immediate
decimal 2 15 thru decimal

( SUPERCLASS                                        10.Dec.96 )

    vocabulary SUPERCLASS  immediate

    0 , ( address of constructor of class)
    0 , ( address of destructor)
    0 , ( size of instance)
    0 , ( free-list)
    0 , ( current size of table of virtual methods)
    0 , ( max size of table of virtual methods)
    SUPERCLASS definitions





\ FIELDS                                              27/Aug/97
    VARIABLE OFFS  4 OFFS !
    : SIZE-DEF OFFS @ 4 - ;
    : FIELD CREATE OFFS DUP @ c, +!
        DOES> c@ context @ + ;

    2 FIELD CONSTR    ( 1st CFA of constructor)
    2 FIELD DESTR     ( 1st CFA of destructor)
    2 FIELD #INSTANCE ( Size of instance)
    2 FIELD FREE-LIST ( wordless ...)
    2 FIELD #VIRTUAL  ( current size of virtual table)
    2 FIELD <VIRTUAL> ( Max size of virtual table)
    0 FIELD $VIRTUAL  ( Virtual table)



( DERIVE                                             9.Dec.96 )
( Derive current class from specified, it need to do before)
( some definitions)
    : (DERIVE) ( context ->)
        dup context ! 2-
        current @ ! ( Link with a base class)
        CONSTR @ DESTR @  #INSTANCE @
        #VIRTUAL @ >R
        $VIRTUAL here R@ allot R@ cmove ( Virtual table)
        current @ context !  ( Returning context)
        R@ #VIRTUAL ! R> <VIRTUAL> !
        #INSTANCE !  DESTR !  CONSTR ! ;

    : DERIVE ( "base-class" \ -> ) ' >VOC (DERIVE) ;


( VIRTUAL                                            9.Dec.96 )

    ( Creation of virtual table)

    : VIRTUAL ( Number-of-virtual-methods ->)
        2* here over allot over erase
        <VIRTUAL> +! ;


    2 XUSER INSTANCE   ( Pointer to current INSTANCE)

    : this INSTANCE @ ;  ( Address of current INSTANCE)

    : ?comp/exec if , else execute then ;


( ITEM                                               5.Dec.96 )
    ( Definition of item of current class)
    does: (AF) ( AdrOfInstance -> AdrOfField)   @ + ;
    : ITEM ( Size-of-item ->)
        sp@ csp @ < 0= 57 ?error
        #INSTANCE @
        create  (AF) , ( 2nd CFA) , ( offset)
        #INSTANCE +!
    does>
        2+ @ this + ; ( for using inside class)

    ( 2nd CFA services for using outside class)

    -2 ITEM itself      ( address of instance)
     2 ITEM parent      ( reference to parent class)

( INVOKE ext-ret ext-call-v.m.                       9.Dec.96 )

    ( Exit from method)
    create ext-ret ] R> INSTANCE ! exit [

    create INVOKE ( Instance Body-of-method ->...)
        ]  this >R swap INSTANCE !
           ext-ret >R >R exit [

    does: ext-call-v.m. ( instance abody)
        @ ( offset) over 2- @ ( parent)
        [ ' $VIRTUAL >body c@ ] literal
        + + @  ( instance body) INVOKE >R ;



( ::VIRTUAL                                          9.Dec.96 )
    ( Creation of a virtual method)
        0 ( dummy)
    : ::VIRTUAL ( "name of v.m." \ ->)
        #VIRTUAL @ <VIRTUAL> @ = 56 ?error
        : ext-call-v.m. , #VIRTUAL @ dup ,
        dup $VIRTUAL + here swap !
        2+ #VIRTUAL !
      DOES> [ here 3 - nip ]
        2+ @ ( offset)  this 2- @ ( parent)
        [ ' $VIRTUAL >body c@ ] literal
        + + @ >R ;

    constant is-v.m.


( ::                                                 9.Dec.96 )
    ( Creation of a class's method)
     QUAN VM   does: ext-call  INVOKE >R ;
     : :: ( "name of method" \ ->)
        >in @ context @ bl word vfind
        if dup @ is-v.m. =
          if -1 IS VM 4 + @ $VIRTUAL + here swap !
             drop ( >in) !csp ]  exit then
          drop then
        >in ! : ext-call ,
      does>  2+ >R ;
     WARNING @ WARNING 0!
     : ; VM IF 0 IS VM ?COMP ?CSP COMPILE EXIT [COMPILE] [
            ELSE [COMPILE] ; THEN ; IMMEDIATE WARNING !
     : ::CONSTR :: LATEST NAME> CONSTR ! ;
     : ::DESTR  :: LATEST NAME> DESTR ! ;
( ::code ->                                          6.Dec.96 )

    : ::CODE CODE here 2+ ,
        ;code
            di, f-data mov ' INSTANCE >body @ [di] push
            bx, # 4 add bx jmp end-code

    forth definitions

    ( forced invocation of method in external manner)
    ( Usage: <address> -> <method>)

    : -> ' 2+ state @ superclass ?comp/exec ;
     immediate


( (NEW                                               9.Dec.96 )

    superclass definitions
    ( Creation of an instance)

    : (NEW) ( Adr-of-class -> Adr-of-instance)
        context @ >R dup context !
        FREE-LIST @ ?dup
        if      dup @ FREE-LIST ! tuck ! 2+
        else    , ( parent)  here ( instance)
                #INSTANCE @ allot   then
        dup #INSTANCE @ erase
        >R CONSTR @ ?dup if R@ swap 2+ execute then R>
        R> context ! ;


\ NEW DELETE                                           12/01/98

    forth definitions

    : NEW ( "name-of-class") [ superclass ]
        ' >VOC [compile] literal
        state @ if compile (NEW) else (NEW) then
    ; immediate

    : DELETE ( adr-of-instance ->) [ superclass ]
        context @ >R
        dup 2- dup @ ( parent) context ! >R
        DESTR @ ?dup if 2+ execute else drop then
        R> FREE-LIST @ over !  FREE-LIST !
        R> context ! ;

( CLASS                                             11.Dec.96 )

    superclass definitions
    does: do-inst 2+ ;
    ( Part 'does' for a class)
    does: do-class
        >IN @ BL WORD C@ 1+ 1 AND HERE 1 AND XOR IF 0 C, THEN
        >IN ! CREATE IMMEDIATE do-inst , 2+ (NEW) drop
        does> ( for instance)
          >R R@ state @ ?comp/exec
          R> 2+ @ bl word vfind dup 0= 0 ?error
          swap 2+ swap 0< state @ and
          ?comp/exec ;
    : >CFA 2- 2- BODY> ;
    :: INST-NAME THIS 2- 2- BODY> >NAME ;
    :: .INSTANCE INST-NAME .NAME ;
( CLASS                                             10.Dec.96 )
    forth definitions

    ( Creation of a class)
    : CLASS [ superclass ]
        context @ current @ warning @ 3 !CSP
        vocabulary latest name> dup >VOC dup
        context ! current !  do-class swap !
        SIZE-DEF allot 0 FREE-LIST !
        [ ' SUPERCLASS >VOC ] literal (DERIVE) 0 warning ! ;
    : SEE-> context @ >R [compile] SEE [compile] ->
            R> context ! ;
        immediate



( END                                                6.Dec.96 )

    superclass definitions
    ( Copletion of definition of a class)
    : END ( "class-name"\ ->)
        current @ >R
        3 ?pairs warning ! current ! context !
        ' >VOC R> - 7 ?error ;
    : OFFSET ( "item"\ -> N) ' 4 + @ [COMPILE] literal ;
                                                    immediate
    forth definitions
    ( Size of instance of class)
    : SIZEOF ' >VOC [ SUPERCLASS ' #INSTANCE >BODY C@ ]
        LITERAL + @
        [COMPILE] LITERAL ; IMMEDIATE FORTH

( Example                                            6.Dec.96 )
class BODY  1 VIRTUAL
    2 item Density
    2 item Volume

   ::CONSTR BODY ( Den Vol ->) Volume ! Density ! ;
   :: Mass  Density @  Volume @ * ;
   ::VIRTUAL name cr ." BODY" ;
end body

class CUBE derive BODY
    2 item Edge
    ::CONSTR CUBE ( Den Edge) dup Edge ! dup dup * * BODY ;
    :: name cr ." CUBE" ;
end cube
-->
( Example                                            6.Dec.96 )

2 1  BODY stone
2 10 BODY rock
2  3 CUBE blok

5 6 new CUBE variable c1 C1 !
7 8 new BODY variable c2 C2 !

c1 @ see-> body name
c2 @ see-> body name
c1 @ delete c2 @ delete


( See also: QUEUE.SCR)

( Test for aligning                                 24.Jul.97 )

    class tclass
      2 item x
      2 item y
    end tclass

    align 1 allot tclass t1 t1 itself .
    align         tclass t2 t2 itself .
    align 1 allot tclass t11 t11 itself .
    align         tclass t22 t22 itself .

    cr .( Numbers must be even) cr
