\ ================================================
\ ANSI-CLASS minimum system
\ Version 0.7 - 30/01/1999
\ Author: Charles Melice
\ MAIL: mail_at_forthcad.com
\ WEB: www.forthcad.com
\ ================================================

ONLY FORTH ALSO DEFINITIONS

EMPTY

\ ------------------------------------------------
\ TO DEFINE IF MISSING
\ ------------------------------------------------

\ : @REL POSTPONE @ ; IMMEDIATE
\ : !REL POSTPONE ! ; IMMEDIATE
\ : ,REL POSTPONE , ; IMMEDIATE

\ ------------------------------------------------
\ WORDLISTS ENCAPSULATION
\ ------------------------------------------------

WORDLIST CONSTANT CLASS-WORDLIST

CLASS-WORDLIST SET-CURRENT

WORDLIST DUP CONSTANT PRIVATE-WORDLIST

FORTH-WORDLIST SWAP CLASS-WORDLIST 3 SET-ORDER

PRIVATE-WORDLIST SET-CURRENT

\ ------------------------------------------------
\ INTERNAL IMPLEMENTATION WORDSET
\ ------------------------------------------------

PRIVATE-WORDLIST SET-CURRENT

0 VALUE ^CLASS
0 VALUE THIS

CREATE ^PREV-ORDER 33 CELLS ALLOT
0 VALUE PREV-CURRENT

\ used later to define VIRTUAL:
DEFER attach-class-vtable
DEFER inherit-to-vtemp

: WID> ( class -- addr ) ; IMMEDIATE
: PARENT> ( class -- addr ) CELL+ ;
: SIZE> ( class -- addr ) CELL+ CELL+ ;
: VTABLE> ( class -- addr ) [ 3 CELLS ] LITERAL + ;

: ^SIZE ( -- addr ) ^CLASS SIZE> ;
: ^VTABLE ( -- addr ) ^CLASS VTABLE> ;
: ^PARENT ( -- addr ) ^CLASS CELL+ ;

: SaveSearchOrder ( -- )
    get-order dup \ s: widn .. wid1 n n
    ^prev-order ! \ s: widn .. wid1 n
    ^prev-order over cells + \ s: widn .. wid1 n addrmax
    swap 0 \ s: widn .. wid1 addrmax n 0
    ?DO dup >r ! r> cell- LOOP
    drop ;

: RestoreSearchOrder ( -- )
    only
    ^prev-order @ 1+ 1 \ s: n 0
    ?DO \ s: -
        i cells ^prev-order +
        @ context ! also
    LOOP
    previous ;

: AlsoClassSearchOrder ( ^class -- )
    dup parent> @rel ?dup \ have a parent ?
    IF RECURSE THEN \ yes -> SetParentClassSearchOrder
    also @ context ! ;

: SetClassSearchOrder ( -- )
    only forth
    also class-wordlist context !
    ^class AlsoClassSearchOrder ;

: ClassView ( ^CLASS -- )
    to ^class SetClassSearchOrder ;

\ ------------------------------------------------
\ CLASS DEFINITION
\ ------------------------------------------------

FORTH-WORDLIST SET-CURRENT

: SUBCLASS ( <<name>> ^parent -- ) \ replace VOCABULARY
    wordlist
    create here to ^class \ S: ^parent ^wid
    , \ S: ^parent
    dup ,rel \ S: ^parent
    dup IF size> @ THEN , \ S: - PFA: <wid><parent><size>
    0 ,REL \ vtable^
    SaveSearchOrder
    get-current to prev-current
    SetClassSearchOrder
    ^class wid> @ set-current \ definitions
    inherit-to-vtemp
    DOES> ; ( -- ^CLASS )

: CLASS ( <<name>> -- )
    0 SUBCLASS ;

\ ------------------------------------------------
\ DATA DEFINITION
\ ------------------------------------------------

FORTH-WORDLIST SET-CURRENT

CLASS-WORDLIST SET-CURRENT

: BUFFER: ( <<name>> size -- )
    create
    ^size @ ,
    ^size +!
    DOES> ( body -- offset+THIS )
        @ this + ;

: VARIABLE ( <<name>> -- ) cell BUFFER: ;

: SIZEOF ( -- size ) ^size @ ;

\ ------------------------------------------------
\ SPECIAL WORDLIST LOOKUP
\ ------------------------------------------------

CLASS-WORDLIST SET-CURRENT

: SUPER ( <<name>> -- )
    ^class cell+ @rel
    dup 0= abort" class have no parent"
    ^class >r to ^class
    previous
    '
    state @
    IF compile, ELSE execute THEN
    r> to ^class
    also ^class wid> @rel context ! ;
                                IMMEDIATE

: COMMON ( <<name>> -- )
    RestoreSearchOrder
    '
    state @
    IF compile, ELSE execute THEN
    SetClassSearchOrder ;
                         IMMEDIATE

\ ------------------------------------------------
\ END OF CLASS DEFINITION
\ ------------------------------------------------

: END ( -- )
    attach-class-vtable
    RestoreSearchOrder
    prev-current set-current ;

\ ------------------------------------------------
\ OOF Extentions
\ ------------------------------------------------

PRIVATE-WORDLIST SET-CURRENT

: EXECUTE-IVAR ( XT OFFSET CLASS -- )
    this >r +to this execute r> to this ;

: to-this-to-class ( class obj -- )
    to this to ^class ;

CLASS-WORDLIST SET-CURRENT

: BUILD ( <<objname>> ^CLASS -- )
    ^class >r ClassView \ set new class context
    ^size @ ^CLASS \ S: SIZE CLASS
    R> ClassView \ set original class context
    create
    ,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
    ^size +! \ S: -
    IMMEDIATE
    DOES>
        ^class >r \ save prev context
        dup cell+ @ \ S: OFFSET
        swap @REL \ S: OFFSET CLASS
        ClassView \ S: OFFSET \ inside new class context
        ' swap \ S: XT OFFSET
        state @
        IF
            ?dup
            IF
                postpone 2literal
                postpone execute-ivar
            ELSE
                compile,
            THEN
        ELSE
            execute-ivar
        THEN
        R> ClassView ;

FORTH-WORDLIST SET-CURRENT

: BUILD ( <<objname>> ^class -- )
    create
    dup ,rel
    size> @
    allot \ PFA: <CLASS><..DATA..>
    IMMEDIATE
    DOES>
        SaveSearchOrder
        ^class >r
        dup @REL ClassView
        cell+
        ' swap \ S: XT THIS
        STATE @
        IF
            ^class swap
            postpone 2literal
            postpone to-this-to-class
            compile,
        ELSE
            to this
            execute
        THEN
        RestoreSearchOrder
        r> to ^class ;

\ ------------------------------------------------
\ (optional) class tools
\ ------------------------------------------------

: [CLASS ( CLASS -- )
    SaveSearchOrder
    ClassView ;
    IMMEDIATE

: CLASS] ( -- )
    RestoreSearchOrder ;
    IMMEDIATE

: >THIS ( ^object -- ^membase ) \ usage ' obj >this
>body cell+ ;

\ ------------------------------------------------
\ (optional) VIRTUAL: ( <<name>> -- )
\ define a virtual method
\ ------------------------------------------------

PRIVATE-WORDLIST SET-CURRENT

100 constant MAX-VIRTUAL

create vTblTemp 0 , MAX-VIRTUAL 2* cells allot

: virt-count ( -- addr )
    ^VTABLE @REL ;

: vtable[] ( n -- addr )
    2* 1+ cells virt-count + ;

:noname [ IS inherit-to-vtemp ] ( -- )
    0 vTblTemp !
    ^parent @REL
    IF
        ^class >r
        ^parent @REL to ^class
        ^vtable @REL
        IF
            virt-count @ vTblTemp !
            vTblTemp cell+
            virt-count @ 0
            ?DO
                i vtable[] @REL over !REL
                cell+
                i vtable[] cell+ @REL over !REL
                cell+
            LOOP
            drop
         THEN
         r> to ^class
    THEN
    vTblTemp ^vtable !REL ;

:noname [ IS attach-class-vtable ] ( -- )
    virt-count @
    IF
        here
        virt-count dup @ \ S: body addr count
        dup , 0 \ S: body addr count 0
        ?DO \ S: body addr
            cell+ dup @REL ,REL
            cell+ dup @REL ,REL
        LOOP
        drop
        ^vtable !REL
     ELSE
        0 ^vtable !REL
     THEN ;

: in-vtable ( body^ -- pos true | false )
    virt-count @ 0
    ?DO
        i vtable[] cell+ @REL over =
        IF drop i TRUE unloop EXIT THEN
    LOOP
    drop FALSE ;

: append-to-vtable ( body^ -- n )
    \ later, we should use allocate/resize
    virt-count @
    dup MAX-VIRTUAL >= abort" virtual table overflow - see MAX-VIRTUAL"

    vtable[] cell+ !REL
    virt-count @
    dup 1+ virt-count ! ;

: CreateVirtual: ( <<method>> -- vn )
    Create here \ S: bod
    append-to-vtable \ S: vn
    dup 2* 1+ cells , \ S: byte-offset
                            \ offset in bytes to speed-up
    DOES>
        @ ^vtable @REL + \ this is the virtual overhead
        @REL execute ;

\ ------------------------------------------------
\ Extra words - not defined in ANSI proposal
\ ------------------------------------------------

CLASS-WORDLIST SET-CURRENT

: VIRTUAL: ( <<name>> -- )
>IN @
    bl word find
    IF \ S: in^ xt
>body in-vtable
        IF
            nip \ S: vn
        ELSE
>IN !
            CreateVirtual: \ S: vn
        THEN
    ELSE \ S: in^ cstr
        drop >IN ! \ S: -
        CreateVirtual: \ S: vn
    THEN
    :noname swap \ S: xt vn
    vtable[] !REL ;

ONLY FORTH ALSO DEFINITIONS

\ ------------------------------------------------
\ THE END
\ ------------------------------------------------
{

Class Object

    VIRTUAL: NameOf C" Object" ;

    : .Name NameOf count type ;

End

Object SubClass Var

    variable addr

    VIRTUAL: NameOf C" Var" ;

    : @ ( -- val ) addr @ ;
    : ! ( val -- ) addr ! ;
    : ? ( -- ) addr ? ;
    : +! ( val -- ) addr +! ;
    : inc ( -- ) 1 +! ;
    : dec ( -- ) -1 +! ;
    : neg ( -- ) @ negate ! ;
End

Object build oo
Var build vv
}

Bureau d'Etudes Informatique MELICE SPRL
Zoning Industriel
B-5650 CHASTRES
Belgium

.
Received on Sat Jan 30 1999 - 05:16:45 PST