\ ================================================
\ ANSCLASS module
\ Version 0.2 - 24/01/1999
\ Charles Melice
\ MAIL: mail_at_forthcad.com
\
\ Version Status
\ ------- --------------------------------------
\ 0.1 Creation
\ 0.2 Fixed non-relocatable by using ,REL...
\ Better wordlist management.
\ ================================================

EMPTY
DECIMAL

\ ------------------------------------------------
\ Words to uncomment if missing
\ ------------------------------------------------

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

\ ------------------------------------------------
\ Implementation word lists -encapsulation-
\ ------------------------------------------------

ONLY FORTH ALSO DEFINITIONS

wordlist constant CLASS-WORDLIST

wordlist dup set-current dup also context !
constant class-private-wordlist

: class-private
    forth-wordlist
    class-private-wordlist
    class-wordlist
    3 set-order
    class-private-wordlist
    set-current ;

: class-public
    forth-wordlist
    class-private-wordlist
    class-wordlist
    3 set-order
    class-wordlist
    set-current ;

: class-end
    only forth also definitions ;

\ ------------------------------------------------
\ TODO: -> version 1.0
\ ------------------------------------------------

class-public

\ PRIVATE and PUBLIC probably...
\
\ Private --> also another wordlist
\ definitions
\
\ Public --> previous ...
\ ^class @ SetCurrent
\
\
: PUBLIC NOOP ;
: PRIVATE NOOP ;

\ ------------------------------------------------
\ Declaration
\ ------------------------------------------------

class-private

0 value ^class
0 value ^obj
0 value ^base

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

\ ------------------------------------------------
\ Error msg - restore a min. search-order on error
\ ------------------------------------------------

class-public

: abort ( -- )
    only forth also definitions
    0 to ^class
    abort ;

class-private

: do-abort" ( flag c-str -- )
    swap 0= IF drop EXIT THEN
    count type 2 spaces
    abort ;

class-public

: abort" ( i*x flag -- )
    postpone c"
    postpone do-abort" ; IMMEDIATE

class-private

: ?abort-mem-error ( ior -- )
    abort" memory allocation/free error" ;

: ?abort-method-not-found ( flag -- )
    abort" method not found" ;

\ ------------------------------------------------
\ m' is ' with wordlist restoration
\ ------------------------------------------------

: m' ( <<name>> -- xt )
    bl word find 0= ?abort-method-not-found ;

\ ------------------------------------------------
\ Class definition
\ ------------------------------------------------

class-private

: ^wordlist ( -- addr ) ^class ;
: ^parent ( -- addr ) ^class cell+ ;
: ^size ( -- addr ) ^class cell+ cell+ ;
: ^vtable ( -- addr ) ^class 3 cells + ;
: ^user ( -- addr ) ^class 4 cells + ;

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

: SetClassSearchOrder ( ^class -- )
    forth-wordlist class-wordlist 2 set-order
    AlsoClassSearchOrder ;

: ResetClassSearchOrder ( ^class -- )
    drop only forth also ;

class-public forth-wordlist set-current

: CLASS ( <<name>> -- )
    wordlist
    Create
    here to ^class
    , \ wordlist
    0 ,REL \ parent
    0 , \ size
    0 ,REL \ vtable^
    ^class SetClassSearchOrder
    definitions
    inherit-to-vtemp
    IMMEDIATE
    does> ;

: SUBCLASS ( <<name>> ^class -- )
    CLASS previous
    dup ^parent !REL
    cell+ cell+ @ ^size !
    inherit-to-vtemp
    ^class SetClassSearchOrder ;

: CLASSDUMP ( body-class -- )
    ^class >r to ^class
    cr cr
    ^class body> >name count dup >r type cr
    r> 0 do [char] - emit loop cr
    ." parent : " ^parent @REL ?dup
    IF body> >name count type ELSE ." none" THEN cr
    ." mem allocation : " ^size ? cr
    ." virtual count : " ^vtable @REL dup IF ? ELSE . THEN cr
    ." user data : " ^user ? cr
    ." methods : "
    get-order
    only ^class SetClassSearchOrder
    words cr
    set-order
    r> to ^class ;

: SIZEOF ( ^class -- N )
    ^class >r to ^class
    ^size @
    r> to ^class ;

class-public

: END ( -- )
    attach-class-vtable
    only forth also definitions
    0 to ^class ;

: SUPER ( <<name>> -- ) \ compile only
    ^parent @REL 0= abort" class have no parent"
    ^class >r ^parent to ^class
    context @ previous
    m' compile,
    r> to ^class
    also context ! ;
                    IMMEDIATE

: COMMON ( <<name>> -- ) \ compile only
    ^class ResetClassSearchOrder
    m' compile,
    ^class SetClassSearchOrder ;
                                IMMEDIATE

class-private

: to^class-to^base ( ^class ^base -- )
    to ^class to ^base ;

: ^base+ ( offset -- addr )
    ^base + ;

: Interpret-Method ( obj^ -- )
    dup
    cell+ to ^base
    @REL to ^class \ S: --
    ^class SetClassSearchOrder
    state @
    IF
        ^base ^class \ because possible late binding
        postpone 2literal \ we save the ^class value....
        postpone to^class-to^base \ todo: detect no virtual, then...
        m' compile,
    ELSE
        m' execute
    THEN
    ^class ResetClassSearchOrder ;

class-public forth-wordlist set-current

: BUILD ( <<name>> ^class -- )
    to ^class
    Create
    ^class ,REL
    ^size @ allot
    0 to ^class
    IMMEDIATE
    does>
        Interpret-Method ;

class-private

: execute-ivar ( xt offset ) \ very classical one...
    ^base dup >r
    + to ^base
    execute
    r> to ^base ;

class-public

: BUILD ( <<name>> ^class -- )
    ^size @
    ^class >r
    swap dup to ^class \ S: offset ^class
    ^size @ \ S: offset ^class size
    r> to ^class \ S: offset ^class size
    ^size +! \ S: offset ^class
    create ,REL , \ S: --
    IMMEDIATE
    does>
        ^class >r
        dup @REL \ S: body^ ^newclass
        SetClassSearchOrder \ S: body^
        m' \ S: body^ xt
        r> \ S: body^ xt ^prevclass
        SetClassSearchOrder \ S: body^ xt
        swap cell+ @ \ S: xt offset
        state @
        IF
            ?dup \ Optimize the 0 offset case
            IF
                postpone 2literal
                postpone execute-ivar
            ELSE
                compile,
            THEN
        ELSE
            execute-ivar
        THEN ;

\ ------------------------------------------------
\ Class data
\ ------------------------------------------------

class-public

: BUFFER: ( size -- )
    Create
    ^size @ ,
    ^size +!
    IMMEDIATE
    does>
        @
        state @
        IF
            ?dup \ Optimize the 0 offset case
            IF
                postpone literal
                postpone ^base+
            ELSE
                postpone ^base
            THEN
        ELSE
            ^base+
        THEN ;

: VARIABLE ( <<name>> -- ) 1 cells buffer: ;

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

class-private

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 \ 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 ;
                           IS inherit-to-vtemp

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

: 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-public

: 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 ;

forth-wordlist set-current

: NEW ( ^class -- ^obj )
    ^class >r to ^class
    ^size @ cell+ allocate ?abort-mem-error
    ^class over !REL
    r> to ^class
    cell+ ;

: RELEASE ( ^obj -- )
    cell - free ?abort-mem-error ;

class-private

Create wordbuf 81 allot

: Exe-Method ( objmem^ c-strmethod count -- )
    wordbuf place
    dup to ^base
    1 cells - @REL to ^class \ S: c-strmethod
    ^class SetClassSearchOrder
    wordbuf find 0=
    IF
        pad count type 3 spaces
        TRUE ?abort-method-not-found
    THEN
    execute
    ^class ResetClassSearchOrder ;

: str>buffer ( <<name>> -- )
    bl word count wordbuf place ;

class-public forth-wordlist set-current

: --> ( ^obj c-str -- ) \ BIND AT RUNTIME
    state @
    IF
        str>buffer
        wordbuf count postpone sliteral
        postpone Exe-Method
    ELSE
        1 cells -
        Interpret-Method
    THEN ;
          IMMEDIATE

    CLASS-END

\ ================================================

.
Received on Mon Jan 25 1999 - 19:22:55 PST