oop.sf

strongForth: a strongly typed dialect of Forth implemented in ANS Forth.

\ Copyright (C) 2008 Stephan Becher
\
\ This file is part of StrongForth.f.
\
\ StrongForth.f is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ StrongForth.f is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with StrongForth.f; if not, write to the Free Software
\ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
\
\ Contact: [e-mail]

DT UNSIGNED PROCREATES STRUCT-SIZE
DT UNSIGNED PROCREATES VTABLE-SIZE
DT STRUCT-SIZE PROCREATES OBJ-SIZE

DT SINGLE PROCREATES STRUCTURE
0 CELLS        , \ member variables in bytes

DT SINGLE PROCREATES OBJECT
0  ,         0 , \ WID
HERE 2 CELLS + , \ VTable
0              , \ Friends
1 CELLS        , \ member variables in bytes
3 CELLS        , \ virtual member functions
' NOOP >TOKEN  , \ destructor token

DT OBJECT VALUE THIS-CLASS

VOCABULARY AUTOTHIS
' AUTOTHIS >BODY CAST WID CONSTANT AUTOTHIS-WORDLIST
' AUTOTHIS >BODY -> ADDRESS CONSTANT AUTOTHIS-LAST

VOCABULARY PROTECTED
' PROTECTED >BODY CAST WID CONSTANT PROTECTED-WORDLIST
' PROTECTED >BODY -> ADDRESS CONSTANT PROTECTED-LAST

VOCABULARY PRIVATE
' PRIVATE >BODY CAST WID CONSTANT PRIVATE-WORDLIST
' PRIVATE >BODY -> ADDRESS CONSTANT PRIVATE-LAST

: THIS-PARENT ( -- DATA-TYPE )
  THIS-CLASS PARENT ;

: APPEND-WORDLIST ( WID -- )
  #ORDER @ #VOCS <
  IF CONTEXT #ORDER @ + ! 1 #ORDER +! ELSE DROP -49 THROW THEN ;

: STRIP-WORDLIST ( -- )
  #ORDER @
  IF -1 #ORDER +! ELSE -50 THROW THEN ;

AUTOTHIS-WORDLIST APPEND-WORDLIST

: PARENT? ( DATA-TYPE DATA-TYPE -- ADDRESS )
  OVER
  BEGIN OVER OVER <>
  WHILE DUP NULL? INVERT
  WHILE PARENT
  REPEAT DROP DROP DROP NULL ADDRESS
  ELSE DROP DROP SPLIT NIP CAST ADDRESS
  THEN ;

: STRUCTURE? ( DATA-TYPE -- ADDRESS )
  [DT] STRUCTURE PARENT? DUP IF 2 CELLS + THEN ;

: OBJECT? ( DATA-TYPE -- ADDRESS )
  [DT] OBJECT PARENT? ;

: ?STRUCTURE ( DATA-TYPE -- ADDRESS )
  STRUCTURE? DUP 0= IF -276 THROW THEN ;

: ?OBJECT ( DATA-TYPE -- ADDRESS )
  OBJECT? DUP 0= IF -287 THROW THEN ;

: >LAST ( DATA-TYPE -- ADDRESS -> ADDRESS )
  ?OBJECT -> ADDRESS 2 + ;

: >VTABLE ( DATA-TYPE -- ADDRESS -> ADDRESS )
  ?OBJECT -> ADDRESS 4 + ;

: THIS-VTABLE ( -- ADDRESS )
  THIS-CLASS >VTABLE @ ;

: SIZE-STRUCTURE ( ADDRESS -- UNSIGNED )
  -> UNSIGNED @ ;

: SIZE-STRUCTURE ( DATA-TYPE -- UNSIGNED )
  ?STRUCTURE SIZE-STRUCTURE ;

: SIZE-OBJECT ( ADDRESS -- UNSIGNED )
  -> UNSIGNED @ ;

: SIZE-OBJECT ( DATA-TYPE -- UNSIGNED )
  >VTABLE @ SIZE-OBJECT ;

: SIZE ( OBJECT -- UNSIGNED )
  CAST ADDRESS -> ADDRESS -> UNSIGNED @ @ [ 1 CELLS ] LITERAL / 1- ;

: PROCREATES ( DATA-TYPE -- )
  DUP PROCREATES DUP STRUCTURE?
  IF DROP 0 , \ Structure size
  ELSE OBJECT?
     IF 0 , \ WID
        0 ,
        0 , \ VTable
        0 , \ Friends
     THEN
  THEN ;

: PURE-VIRTUAL ( OBJECT -- )
  DROP -293 THROW ;

: BITS/AU ( -- UNSIGNED )
  " ADDRESS-UNIT-BITS" ENVIRONMENT?
  IF -> UNSIGNED @ 
  ELSE DROP 8 
  THEN ;
  
BITS/AU CONSTANT BITS/AU

: ALIGNED ( STRUCT-SIZE -- 1ST )
  BITS/AU CELLS OVER OVER MOD DUP IF - + ELSE DROP DROP THEN ;

: CALIGNED ( STRUCT-SIZE -- 1ST )
  BITS/AU CHARS OVER OVER MOD DUP IF - + ELSE DROP DROP THEN ;

: STRUCT ( -- STRUCT-SIZE )
  DT DUP ?STRUCTURE DROP DUP TO THIS-CLASS
  PARENT SIZE-STRUCTURE BITS/AU * CAST STRUCT-SIZE ;

: ENDSTRUCT ( STRUCT-SIZE -- )
  ALIGNED BITS/AU / THIS-CLASS ?STRUCTURE -> STRUCT-SIZE ! ;

: CLASS ( -- WID TUPLE -> WID VTABLE-SIZE )
  DT DUP ?OBJECT DROP DUP TO THIS-CLASS
  PARENT >LAST
  DUP @ AUTOTHIS-LAST !
  1+ @ PROTECTED-LAST !
  NULL ADDRESS PRIVATE-LAST !
  GET-CURRENT GET-ORDER AUTOTHIS-WORDLIST APPEND-WORDLIST
  THIS-PARENT >VTABLE -> VTABLE-SIZE @ DUP
  IF 1+ @
  ELSE DROP -294 THROW NULL VTABLE-SIZE
  THEN ;

: ENCLOSE-VTABLE ( ADDRESS -- VTABLE-SIZE ADDRESS -> TOKEN ADDRESS -> TOKEN )
  DUP -> VTABLE-SIZE 1+ @
  OVER OVER + -> TOKEN ROT 2 CELLS + -> TOKEN ;

: BODY ( VTABLE-SIZE -- OBJ-SIZE )
  HERE THIS-CLASS >VTABLE !
  THIS-PARENT >VTABLE -> OBJ-SIZE @ @
  TUCK , \ OBJ-SIZE \ DUP , \ VTABLE-SIZE \
  THIS-PARENT >VTABLE @ ENCLOSE-VTABLE
  ?DO I @ , LOOP - 1 CELLS / NULL VTABLE-SIZE
  ?DO [ ' PURE-VIRTUAL >TOKEN ] LITERAL , LOOP BITS/AU * ;

: ENDCLASS ( WID TUPLE -> WID OBJ-SIZE -- )
  ALIGNED BITS/AU / THIS-VTABLE -> OBJ-SIZE !
  AUTOTHIS-LAST @ THIS-CLASS >LAST !
  PROTECTED-LAST @ THIS-CLASS >LAST 1+ !
  THIS-CLASS >VTABLE 1+ @ DUP \ has friends?
  IF PRIVATE-LAST @ \ has private members?
     IF PRIVATE-WORDLIST FIRST CAST ADDRESS -> ADDRESS 1-
        PROTECTED-LAST @ SWAP !
        PRIVATE-LAST @
     ELSE PROTECTED-LAST @
     THEN SWAP -> ADDRESS -> ADDRESS @ !
  ELSE DROP
  THEN SET-ORDER SET-CURRENT ;

: >THIS ( -- )
  ?COMPILE " LOCALS| THIS |" EVALUATE ; IMMEDIATE

: AUTOTHIS ( -- )
  PREVIEW-WORD [ 13 BIT ] LITERAL
  [ ' ATTRIBUTE-FIELD >TOKEN CAST SEARCH-CRITERION ] LITERAL 
  AUTOTHIS-WORDLIST SEARCH NIP IF EXIT THEN
  SAVE-INPUT GET-CURRENT AUTOTHIS-WORDLIST SET-CURRENT
  CREATE LATEST , IMMEDIATE 
  SET-CURRENT RESTORE-INPUT DROP
  DOES> ( ADDRESS -> DEFINITION -- )
  >R " THIS" EVALUATE R> @ NAME STRIP-WORDLIST EVALUATE 
  AUTOTHIS-WORDLIST APPEND-WORDLIST ;

: VIRTUAL ( VTABLE-SIZE -- 1ST )
  AUTOTHIS CREATE DUP , 1 CELLS + 13 BIT +ATTRIBUTE
  NO-PARAMS-DOES> ( OBJECT ADDRESS -> UNSIGNED -- 1ST )
  OVER CAST ADDRESS -> ADDRESS @ SWAP @ + -> TOKEN @ (EXECUTE) ;

2 CELLS CAST VTABLE-SIZE
VIRTUAL DESTRUCTOR ( OBJECT -- 1ST )
DROP

: ?AUTOTHIS ( -- )
  THIS-CLASS OBJECT? IF AUTOTHIS THEN ;

: (MEMBER) ( STRUCT-SIZE UNSIGNED -- 1ST )
  ?AUTOTHIS SWAP ALIGNED TUCK BITS/AU /
  CREATE NULL STACK-DIAGRAM 
  THIS-CLASS DT-INPUT OR PARAM, (VARIABLE) 
  SWAP , END-DIAGRAM BITS/AU * + 
  DOES> ( ADDRESS ADDRESS -> UNSIGNED -- 1ST ) @ + ;

: MEMBERS ( STRUCT-SIZE SINGLE UNSIGNED -- 1ST )
  NIP CELLS (MEMBER) ;

: MEMBERS ( STRUCT-SIZE DOUBLE UNSIGNED -- 1ST )
  NIP 2* CELLS (MEMBER) ;

: MEMBER ( STRUCT-SIZE SINGLE -- 1ST )
  1 MEMBERS ;

: MEMBER ( STRUCT-SIZE DOUBLE -- 1ST )
  1 MEMBERS ;

: (CVARIABLE) ( STACK-DIAGRAM -- 1ST )
  [ DT CADDRESS DT-OUTPUT DT-PREFIX OR OR ] LITERAL PARAM,
  (CONSTANT) ;

: CMEMBERS ( STRUCT-SIZE SINGLE UNSIGNED -- 1ST )
  NIP CHARS ?AUTOTHIS SWAP CALIGNED TUCK BITS/AU /
  CREATE NULL STACK-DIAGRAM 
  THIS-CLASS DT-INPUT OR PARAM, (CVARIABLE)
  SWAP , END-DIAGRAM BITS/AU * + 
  DOES> ( CADDRESS ADDRESS -> UNSIGNED -- 1ST ) @ + ;

: CMEMBER ( STRUCT-SIZE SINGLE -- 1ST )
  1 CMEMBERS ;

: :MEMBER ( OBJ-SIZE -- 1ST COLON-SYS )
  AUTOTHIS : ;

: FRIENDS( ( OBJ-SIZE -- 1ST )
  WORDLIST
  HERE THIS-CLASS >VTABLE 1+ DUP @ IF -291 THROW THEN !
  , HERE -> UNSIGNED 0 DUP ,
  BEGIN PARSE-WORD OVER OVER " )" COMPARE
  WHILE [ 8 BIT ] LITERAL 
     [ ' ATTRIBUTE-FIELD >TOKEN CAST SEARCH-CRITERION ] LITERAL 
     SEARCH-ALL
     IF ?DATA-TYPE ?OBJECT , 1+
     ELSE DROP -260 THROW
     THEN
  REPEAT DROP DROP SWAP ! ;

: ACCESS ( OBJ-SIZE -- 1ST )
  DT >VTABLE 1+ @ THIS-CLASS OBJECT? LOCALS| TC FR | FR
  IF FR -> UNSIGNED 1+ DUP 1+ CAST ADDRESS -> ADDRESS 
     DUP ROT @ + SWAP
     ?DO I @ TC = IF FR -> WID @ CONTEXT ! UNLOOP EXIT THEN
     LOOP
  THEN -292 THROW ;

: ISVIRTUAL ( SIGNED DEFINITION SINGLE -- 1ST )
  CAST DEFINITION LOCALS| THAT THIS | \ THIS is in the dictionary
  THIS 13 BIT ATTRIBUTE-FIELD DUP
  IF THIS #PARAMS THAT #PARAMS =
     IF THAT #PARAMS 0
        ?DO THIS I PARAM@ SPLIT DROP THAT I PARAM@ SPLIT DROP <>
           IF UNLOOP DROP -0 EXIT
           THEN
           THAT I PARAM@ DT-INPUT ATTRIBUTE?
           IF THAT #PARAMS I 1+ =
              IF TRUE
              ELSE THAT I 1+ PARAM@ DT-OUTPUT ATTRIBUTE?
              THEN
           ELSE FALSE
           THEN
           IF THIS I PARAM@ NULL DATA-TYPE AND
              THAT I PARAM@ NULL DATA-TYPE AND
              BEGIN OVER OVER <>
              WHILE PARENT DUP NULL?
                 IF DROP DROP UNLOOP DROP -0 EXIT
                 THEN
              REPEAT DROP DROP
           ELSE THAT I PARAM@ DT-OFFSET ATTRIBUTE?
              IF FALSE
              ELSE THIS I PARAM@ THAT I PARAM@ <>
              THEN
              IF UNLOOP DROP -0 EXIT 
              THEN
           THEN
        LOOP
     ELSE DROP -0
     THEN
  THEN ;

: IS ( OBJ-SIZE DEFINITION -- 1ST )
  DUP PARSE-WORD ROT 
  [ ' ISVIRTUAL >TOKEN CAST SEARCH-CRITERION ] LITERAL SEARCH-ALL
  IF >BODY -> UNSIGNED @ SWAP >TOKEN THIS-VTABLE ROT + -> TOKEN !
  ELSE DROP DROP -290 THROW
  THEN ;

: UNION ( STRUCT-SIZE -- 1ST 1ST 1ST )
  DUP DUP ;

: AND ( STRUCT-SIZE STRUCT-SIZE STRUCT-SIZE -- 1ST 2ND 3RD )
  MAX OVER ;

: ENDUNION ( STRUCT-SIZE STRUCT-SIZE STRUCT-SIZE -- 3RD )
  MAX NIP ;

: VIRTUAL-MATCH ( SIGNED DEFINITION SINGLE -- 1ST )
  OVER CAST ADDRESS -> DATA-TYPE @ SPLIT DROP 13 BIT AND
  IF MATCH
  ELSE DROP DROP DROP -0
  THEN ;

: (BIND) ( DATA-TYPE -- )
  ?COMPILE PARSE-WORD FALSE
  [ ' VIRTUAL-MATCH >TOKEN CAST SEARCH-CRITERION ] LITERAL SEARCH-ALL
  IF DUP >BODY -> UNSIGNED @ ROT >VTABLE @
     OVER OVER -> UNSIGNED 1+ @ <
     IF SWAP + -> TOKEN @
        SWAP TRUE DT>DT DROP (COMPILE,)
     ELSE DROP DROP DROP -289 THROW
     THEN
  ELSE DROP DROP -288 THROW
  THEN ;

: [BIND] ( -- )
  ?COMPILE DT (BIND) ; IMMEDIATE

: [PARENT] ( -- )
  ?COMPILE THIS-PARENT (BIND) ; IMMEDIATE

: (NEW) ( ADDRESS ADDRESS -> STRUCTURE -- 3RD )
  DROP CAST STRUCTURE ;

: (NEW) ( ADDRESS -> STRUCTURE -- 2ND )
  DUP SIZE-STRUCTURE ALLOCATE THROW SWAP (NEW) ;

LATEST PREV DUP
ALIAS (NEW) (  ADDRESS ADDRESS -> STRUCTURE -- 3RD )
ALIAS (NEW) ( CADDRESS ADDRESS -> STRUCTURE -- 3RD )

: (NEW) ( ADDRESS ADDRESS -> OBJECT -- 3RD )
  OVER -> ADDRESS -> OBJECT ! CAST OBJECT ;

: (NEW) ( ADDRESS -> OBJECT -- 2ND )
  DUP SIZE-OBJECT ALLOCATE THROW SWAP (NEW) ;

LATEST PREV DUP
ALIAS (NEW) (  ADDRESS ADDRESS -> OBJECT -- 3RD )
ALIAS (NEW) ( CADDRESS ADDRESS -> OBJECT -- 3RD )

: NEW ( -- )
  SAVE-INPUT DT DUP >R STRUCTURE?
  IF DROP R@ STRUCTURE?
  ELSE RESTORE-INPUT DROP R@ >VTABLE @
  THEN STATE @
  IF LITERAL,
  ELSE ( ADDRESS -- )CAST
  THEN [ DT ADDRESS DT-PREFIX OR ] LITERAL >DT R> >DT
  POSTPONE (NEW) ; IMMEDIATE

: (DELETE) ( OBJECT -- )
  CAST ADDRESS FREE THROW ;

: DELETE ( -- )
  " DESTRUCTOR" EVALUATE POSTPONE (DELETE) ; IMMEDIATE

' (DELETE) ALIAS DELETE ( STRUCTURE -- )

( CADDRESS -> CHARACTER UNSIGNED -- SIGNED )' DELETE
ALIAS DELETE ( CADDRESS -> CHARACTER UNSIGNED -- SIGNED )

: COPY ( OBJECT 1ST -- )
  OVER SIZE OVER SIZE MIN
  ROT CAST ADDRESS -> SINGLE 1+ ROT CAST ADDRESS -> SINGLE 1+
  ROT MOVE ;

: ERASE ( OBJECT -- )
  DUP CAST ADDRESS -> SINGLE 1+ SWAP SIZE ERASE ;

AUTOTHIS-LAST  @ THIS-CLASS >LAST    !
PROTECTED-LAST @ THIS-CLASS >LAST 1+ !

STRIP-WORDLIST

DT DOUBLE PROCREATES BADDRESS

: (@SIZE) ( BADDRESS -> SINGLE -- LOGICAL UNSIGNED )
  SPLIT CAST UNSIGNED 256 /MOD TUCK +
  [ BITS/AU CELLS ] LITERAL LOCALS| BITS HIGH+1 LENGTH |
  CAST ADDRESS -> LOGICAL HIGH+1 BITS >
  IF DUP @ HIGH+1 BITS - RSHIFT
     SWAP 1+ @ BITS 2* HIGH+1 - LSHIFT CAST LOGICAL OR
  ELSE @ BITS HIGH+1 - LSHIFT 
  THEN BITS LENGTH - RSHIFT LENGTH ;

: @ ( BADDRESS -> SINGLE -- 2ND )
  (@SIZE) DROP CAST SINGLE ;

: @ ( BADDRESS -> SIGNED -- 2ND )
  (@SIZE) OVER OVER 1- RSHIFT
  IF TRUE SWAP LSHIFT OR
  ELSE DROP
  THEN CAST SIGNED ;

LATEST ALIAS @ ( BADDRESS -> FLAG -- 2ND )

: ! ( SINGLE BADDRESS -> 1ST -- )
  SPLIT SWAP CAST ADDRESS -> LOGICAL SWAP
  CAST UNSIGNED 256 /MOD OVER OVER +
  [ BITS/AU CELLS ] LITERAL LOCALS| BITS HIGH+1 LENGTH LOW ADDR |
  CAST LOGICAL HIGH+1 BITS >
  IF DUP BITS LENGTH - LSHIFT BITS 2* LENGTH - LOW - RSHIFT 
     TRUE BITS 2* HIGH+1 - RSHIFT INVERT
     ADDR 1+ @ SWAP AND OR ADDR 1+ !
     LOW LSHIFT TRUE LOW LSHIFT 
  ELSE BITS LENGTH - LSHIFT BITS HIGH+1 - RSHIFT
     TRUE BITS LENGTH - LSHIFT BITS HIGH+1 - RSHIFT
  THEN INVERT ADDR @ AND OR ADDR ! ;

: + ( BADDRESS INTEGER -- 1ST )
  >R SPLIT CAST UNSIGNED 256 /MOD \ addr low size
  R> CAST SIGNED OVER CAST SIGNED M* ROT + 
  [ BITS/AU CELLS CAST SIGNED ] LITERAL FM/MOD \ addr size new-low offset
  >R SWAP 256 * + SWAP CAST ADDRESS -> SINGLE 
  R> + SWAP MERGE CAST BADDRESS ;

: - ( BADDRESS INTEGER -- 1ST )
  NEGATE + ;

: 1+ ( BADDRESS -- 1ST )
  1 + ;

: 1- ( BADDRESS -- 1ST )
  -1 + ;

: +! ( INTEGER BADDRESS -> INTEGER -- )
  DUP @ ROT + SWAP ! ;

: +! ( INTEGER ADDRESS -> BADDRESS -- )
  DUP @ ROT + SWAP ! ;

: FILL ( BADDRESS -> SINGLE UNSIGNED 2ND -- )
  ROT ROT 0 DO OVER OVER I + ! LOOP DROP DROP ;

: ERASE ( BADDRESS -> SINGLE UNSIGNED -- )
  NULL SINGLE FILL ;

: SIZE ( BADDRESS -- UNSIGNED )
  SPLIT NIP CAST UNSIGNED 256 / ;

: LSB ( BADDRESS -- UNSIGNED )
  SPLIT NIP CAST UNSIGNED 256 MOD ;

: MSB ( BADDRESS -- UNSIGNED )
  SPLIT NIP CAST UNSIGNED 256 /MOD + 1- ;

: BIT-FIELD ( ADDRESS -> SINGLE UNSIGNED UNSIGNED -- BADDRESS -> 2ND )
  OVER [ BITS/AU CELLS 1- ] LITERAL > 
  OVER [ BITS/AU CELLS    ] LITERAL > OR 
  IF DROP -286 THROW
  ELSE 256 * + 
  THEN MERGE CAST BADDRESS -> SINGLE ;

: (BVARIABLE) ( STACK-DIAGRAM -- 1ST )
  [ DT BADDRESS DT-OUTPUT DT-PREFIX OR OR ] LITERAL PARAM,
  (CONSTANT) ;

: BMEMBERS ( STRUCT-SIZE SINGLE UNSIGNED UNSIGNED -- 1ST )
  >R DUP [ BITS/AU CELLS ] LITERAL > IF -286 THROW THEN
  NIP ?AUTOTHIS \ struct-size length R: count
  OVER [ BITS/AU CELLS ] LITERAL /MOD CELLS >R 
  OVER 256 * +
  CREATE NULL STACK-DIAGRAM \ struct-size length 2bytes sd R: count au-offset
  THIS-CLASS DT-INPUT OR PARAM, (BVARIABLE)
  SWAP , R> , END-DIAGRAM R> * +
  DOES> ( ADDRESS ADDRESS -> BADDRESS -- BADDRESS )
  @ SPLIT ROT ROT CAST UNSIGNED + SWAP MERGE CAST BADDRESS ;

: BMEMBER ( STRUCT-SIZE SINGLE UNSIGNED -- 1ST )
  1 BMEMBERS ;

\ EOF