Here is my class system cersion 0.1, that I expose as it is today. I do it myself because I cannot wait for the year 2004 to have a ANSI OOF system.

My goals:

    1. Simple, short, clear, minimum overhead.

    2. Wil Baden proposal compatible with a minimum of extensions
       -today its the only proposed model, but I cannot accept the
        uppercase/lowercase usage to hide private methods.

    3. ANSI compatible, with a minimum usage of extention-wordets
       -no usage of ,REL @REL !REL +TO... if possible

\ >>>>>>>CUT FROM HERE TO THE END<<<<<<<

\ ================================================
\ ANSI CLASS module a la Wil Baden
\ Version 0.1 - 22/01/1999
\ Charles Melice
\ MAIL: mail_at_forthcad.com
\ ================================================

EMPTY

DECIMAL

\ ------------------------------------------------
\ Implementation worlist
\ ------------------------------------------------

ONLY FORTH ALSO DEFINITIONS

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

: class-private
    class-worlist set-current ;

: class-public
    forth-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
0 value ClassDefinition?

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

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

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

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

: check-inclass ( -- )
    ClassDefinition? 0=
    abort" in a class definition only" ;

: check-outclass ( -- )
    ClassDefinition?
    abort" outside a class definition only" ;

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

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

\ ------------------------------------------------
\ m' is ' with worlist restoration
\ ------------------------------------------------

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

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

class-public

: CLASS ( <<name>> -- )
    TRUE to ClassDefinition?
    wordlist
    Create
    here to ^class
    dup , \ wordlist
    0 , \ parent
    0 , \ size
    0 , \ vtable^
    0 , \ user data
    also context !
    definitions
    inherit-to-vtemp
    IMMEDIATE
    does> ;

class-private

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

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

: ResetClassSearchOrder ( ^class -- )
    BEGIN
        previous
        cell+ @ ?dup 0=
    UNTIL ;

: ChangeClassContext ( ^old ^new -- )
    swap ResetClassSearchOrder
    dup to ^class
    SetClassSearchOrder ;

class-public

: SUBCLASS ( <<name>> ^class -- )
    CLASS previous
    dup ^parent !
    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 @ ?dup
    IF body> >name count type ELSE ." none" THEN cr
    ." mem allocation : " ^size ? cr
    ." virtual count : " ^vtable @ dup IF ? ELSE . THEN cr
    ." user data : " ^user ? cr
    ." methods : "
    get-order
    only ^class @ context !
    words
    set-order
    r> to ^class cr ;

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

: END ( -- )
    check-inclass
    attach-class-vtable
    ^class ResetClassSearchOrder
    definitions
    0 to ClassDefinition?
    0 to ^class ;

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

: COMMON ( <<name>> -- ) \ compile only
    check-inclass
    also forth
    m' compile,
    previous ;
              IMMEDIATE

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

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

: Interpret-Method ( obj^ -- )
    dup
    cell+ to ^base
    @ 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-private

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

: execute-ivar ( xt offset ) \ very classical one...
    ^base >r
    +to ^base \ NB: "+ TO" if you don't have +TO
    execute
    r> to ^base ;

: build-ivar ( <<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 , , \ S: --
    IMMEDIATE
    does>
        ^class >r
        ^class over @ \ S: body^ ^oldclass ^newclass
        ChangeClassContext \ S: body^
        m' \ S: body^ xt
        over @ r> \ S: body^ xt ^newclass ^curclass
        ChangeClassContext \ 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

: BUILD ( <<name>> ^class -- )
    ClassDefinition?
    IF build-ivar ELSE build-obj THEN ;

: BUFFER: ( size -- )
    check-inclass
    state @ abort" interpret only"
    Create
    ^size @ ,
    ^size +!
    IMMEDIATE
    does>
        @
        state @
        IF
            ?dup
            IF
                postpone literal
                postpone ^base+
            ELSE
                postpone ^base
            THEN
        ELSE
            ^base+
        THEN ;

: VARIABLE ( <<name>> -- )
    ClassDefinition?
    IF 1 cells buffer: ELSE variable THEN ;

\ ------------------------------------------------
\ VIRTUAL: ( <<name>> -- ) define a virtual method
\ ------------------------------------------------
\ TODO: @REL !REL REL usage ... but not ANSI

class-private

100 constant MAX-VIRTUAL

create vTblTemp 0 , MAX-VIRTUAL 2* cells allot

: virt-count ( addr -- )
    ^vtable @ ;

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

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

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

: update-vtable ( body^ -- n )
    virt-count @ 0
    ?DO
        i vtable[] cell+ @ over =
        IF drop i unloop EXIT THEN
    LOOP
    \ 'vtable-append' would be better
    virt-count @ vtable[] cell+ !
    virt-count @ dup
    \ later, we should use allocate/resize
    dup MAX-VIRTUAL >= abort" virtual table overflow - see MAX-VIRTUAL"
    1+ virt-count ! ;

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

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

class-public

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

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

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

class-private

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

: str>buffer ( <<name>> -- )
    bl word count vTblTemp PLACE ;

class-public

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

  class-end
\ =======================================

\ ============================================================================
\ Class examples
\ ============================================================================

1 [IF]

Class Point

    variable x
    variable y

    VIRTUAL: NameOf ( -- ) ." Point" ;

    : @ ( -- x y ) x COMMON @ y COMMON @ ;
    : ! ( x y -- ) y COMMON ! x COMMON ! ;
    : ? ( -- ) x COMMON ? y COMMON ? ;
    : .N ( -- ) NameOf ;
End

Point SubClass Vertex

    variable status

    VIRTUAL: NameOf ( -- ) ." Vertex" ;

    : @ ( - x y s ) super @ status COMMON @ ;
    : ! ( x y s - ) status COMMON ! super ! ;
    : ? ( -- ) super ? status COMMON ? ;
End

Class Line

    Point build p1
    Point build p2

    VIRTUAL: NameOf ( -- ) ." Line" ;

    : ! ( x1 y2 x2 y2 -- ) p2 ! p1 ! ;
    : @ ( x1 y2 x2 y2 -- ) p1 @ p2 @ ;
    : ? ( -- ) p1 ? [char] - emit bl emit p2 ? ;
End

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

cr .( verify sizeof Line/Point )

CR Line SIZEOF .
CR Point SIZEOF .

cr
cr .( Objects test )

Point build P
1 2 P !
cr P ?

Vertex build V
8 9 987 V !
cr V ?

Line build L
1 2 3 4 L !
cr L ?

cr
cr .( late binding test )

cr V .N
cr P .N

cr
cr .( compilation test )

: test
    1 2 999 V !
    CR V ?

    8 9 P !
    CR P ?

    CR V .N
    CR P .N ;

test

cr
cr .( heap allocation test )

Point NEW value ^P

55 66 ^P --> !
cr ^P --> ?

cr
cr .( dynamic binding example )

: test1
    1999 2000 ^P --> !
    cr ^P --> ? ;

test1

cr
cr .( dynamic binding of virtual test )

: test2
    ^P --> .N ;

cr test2
^P release
Vertex NEW to ^P
cr test2
^P release
cr

[THEN]

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

.
Received on Sun Jan 24 1999 - 09:50:16 PST