\ 10/11/10 dbh

\ object-message syntax
\ linked lists are used for method binding
\ All messages to SELF are early-bound, use [SELF] for late

\ The method compiler is gone.  Wordlists are used instead.

\ message names must end with colon

\ This extension has an environmental dependency in that it requires
\ more than eight wordlists:  one wordlist for each class

DECIMAL

0 [IF]
\ for gforth and vfx, do a copy/paste
\ your drive letter may be different
include e:\fms+30dLinked.f


[THEN]

DECIMAL


FORTH-WORDLIST  SET-CURRENT


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


WORDLIST  CONSTANT  nclass               \ create separate wordlist ***
nclass SET-CURRENT                       \ for class def'ns
GET-ORDER  nclass  SWAP 1+  SET-ORDER    \ make nclass findable

\ set errorCheck to FALSE after program is debugged
TRUE CONSTANT errorCheck

[UNDEFINED] CELL [IF] 1 CELLS CONSTANT CELL [THEN]
[UNDEFINED] BOUNDS [IF] : BOUNDS  ( a n -- limit index )  OVER + SWAP ; [THEN]

: RESERVE  ( n -- )  HERE OVER ERASE ALLOT ;

\ Build link to list head at addr
: LINK  ( addr -- )   HERE  OVER @ ,  SWAP ! ;

: lowerCase? ( char -- flag ) \ flag is true if char is lower case
  [CHAR] a [ CHAR z 1+ ] LITERAL WITHIN ;

\ Converts lower-case characters to upper case, modifying the contents
\ starting at addr for cnt chars
: to-upper   ( addr cnt -- )
 OVER \ addr cnt addr
 + SWAP  \ cnt+addr addr
 ?DO I C@ DUP
  lowerCase?
  IF 32 - I C!
  ELSE DROP
  THEN
 LOOP ;

: ?MEMERR  ( ior -- )  ABORT" Memory allocation error" ;

40 CONSTANT maxnameSize \ ( in aus) set this to a large enough size for your Forth

: PL POSTPONE LITERAL ;

0 VALUE [SELF]

0 VALUE store-order

: n>s ( xn ... x1 n -- ) \  store GET-ORDER results
   DUP 1+ CELLS ALIGN ALLOCATE ?MEMERR TO store-order
   DUP 1+ 0 ?DO store-order I CELLS + ! LOOP ;

: ns> ( -- xn ... x1 n ) \  prepare for a SET-ORDER call
   store-order DUP  @ CELLS  OVER +      
   ?DO I @ 0 CELL - +LOOP store-order FREE ?MEMERR ;

\ =====================================================================
\ Class Structure.

0 VALUE ^class  \ pointer to class being defined
0 VALUE newObject \ object being created

: IFA  8 CELLS + ; \ ivar dict Latest field
: DFA  9 CELLS + ; \ datalen of named ivars
: XFA 10 CELLS + ; \  elem width for indexed area, <= 0 if not indexe
: SFA 11 CELLS + ; \ superclass ptr field
: WIDA  12 CELLS + ; \ wid field
: TAG ( ^class -- addr_tag ) 13 CELLS + ; \ class tag field
: ClassName  ( ^class -- $ptr ) 14 CELLS + ; \ class name (all uc)

15 CELLS maxnameSize + CONSTANT classSize  \ size of class pfa

CREATE classTag  \ contents of tag field for valid class

: ?isClass  ( pfa -- f )  \ is this a valid class?
 TAG @ classTag = ;

\ The runtime action of an object is to return the address of its data,
\ which is one cell in front of the PFA. The PFA contains the address of the
\ first cell of the method dispatch table for the class of that object.
: (Obj) \ Compile time ( "spaces<name>" -- )
          CREATE
        \ Run time ( -- ^obj )
          DOES> CELL+ ;  

: classAllot  ( n -- )  \ Allot space in the current class
 ^Class DFA +! ;

: classAlign  ( -- )  \ Align class data size (optional)
 ^Class DFA @  ALIGNED  ^Class DFA ! ;

: @width  ( ^class -- elWidth )  \ return the indexed element width for a class
  XFA @ ; 

\ ========== begin code unique to linked list methods search ===========

\ =====================================================================
\ Methods are stored in an 8-way linked-list.
\ Each method is identified by a 32-bit selector which is the parameter
\ field of the selector. Offsets are in cells.
\
\ Method Structure:
\ 0   link to next method
\ 1   SelID
\ 2   method execution token (called mcfa below)
\
\ =====================================================================


: _MFA  ( SelID -- MFA-offset )
  dup >r
  2/ 2/ r@ xor
  2/ 2/ r> xor 7 AND CELLS  ;

\ compute this at compile time for runtime speed,
\ it is purely a function of SelID            
: MFA-offset ( SelID -- MFA-offset SelID ) DUP _MFA SWAP ; IMMEDIATE


\ Find the top of the method link for a given selector.
\ The "2/ 2/" below is to get a better distribution if the selectors
\ are aligned values.
: MFA  ( SelID ^Class -- SelID MFA )
  OVER _MFA + ;

\ Search through a linked-list of methods for the given selector.
\ Also used to find an ivar record in vfind.
: ((FINDM))  \ ( SelID MFA -- mcfa true | false )
             \ or ( ivarID IFA -- addr true | false )
 BEGIN @ DUP
 WHILE 2DUP CELL+ @ = IF [ 2 CELLS ] LITERAL + ( mfca )  NIP TRUE  EXIT THEN
 REPEAT NIP ;

: (FINDM)   ( SelID ^Class -- xt ) \ find method in a class
 MFA ((FINDM)) IF  @ EXIT  THEN
 TRUE ABORT" Message not understood by class" ;

\ ========== end code unique to linked list methods search ===========


: FIND-IVAR  ( ivarID ^class -- addr true | false )
  IFA \ convert ^class to ivar linked list address
  ((FINDM)) ;
  
\ key = ivar-hashed-name   
: FIND-IVAR-OFFSET  ( key ^class -- ivar-offset )
   FIND-IVAR \ addr true | false
   IF CELL+ @ ( ivar-offset )
   ELSE TRUE ABORT" Ivar Name not Found"
   THEN ;


\ =====================================================================
\ Method execution. The current object address is stored in the value [self].
\ The object is only valid inside of a method definition. When we call a
\ method, we save the old object pointer and set it to the current object.
\ When the method returns, we restore the object pointer.

: EXECUTE-METHOD  ( ^obj xt -- ) \ execute method, saving object pointer
 [self] >R   SWAP TO [self]   EXECUTE   R> TO [self] ;

\ Wrap catch so that it preserves the current object
[DEFINED] CATCH [IF]
: CATCH  ( -- n )  [self] >R   CATCH   R> TO [self] ;
[THEN]

\ =====================================================================
\ Hash function for instance variable names. The "32 OR" is for
\ case-insensitive names. The compiler will warn you if you have
\ a hash collision.

: HASH  ( addr len -- n ) 
 TUCK BOUNDS ?DO  6 LSHIFT  I C@ 32 OR XOR  LOOP
 DUP 0< IF EXIT THEN  INVERT ;

: hash>  ( -- n )  BL WORD COUNT HASH ;

\ =====================================================================
\ An instance variable record consists of four cell-sized fields.
\ 
\     Offset   Name      Description
\     ------   ----      ---------------------------------------
\        0     link      points to link of next ivar in chain
\        1     name      32-bit hash value of ivar name
\        2     ^class     pointer to class
\        3     offset    offset in object to start of ivar data
\        4     #elems    number of indexed elements if indexed
\        5     rec?      is this ivar a record?
\
\ In the stack diagrams, "ivar" refers to the starting address of this
\ structure.  The IFA field of a class points to the first ivar.
\ =====================================================================

: iclass     ( ivar -- ^class )  [ 2 CELLS ] LITERAL + ;
: @IvarOffs  ( ivar -- offset ) [ 3 CELLS ] LITERAL + @ ;  
: @IvarElems ( ivar -- #elems ) [ 4 CELLS ] LITERAL + @ ;
: @IvarRec? ( ivar -- rec? ) [ 5 CELLS ] LITERAL + @ ;

CREATE ^Self 0 ,  \ link addr will always be zero

\ Create a dummy class that "object" inherits from.

CREATE Meta classSize RESERVE
0  ' Meta >BODY  WIDA ! 
^Self   Meta IFA ! \ latest ivar
classTag Meta TAG ! \ class tag

\ **** begin init: code

: sel\obj->xt  ( SelId ^obj -- xt )
 CELL - @ (FINDM) ;

0 VALUE (init:)

\ send init: message to ivar on stack
: InitIvar  ( ivar offset -- )
 OVER @IvarOffs + newObject +   ( ivar addr )
 (init:)  \ ivar addr SelID
 ROT      \ addr SelID ivar
 iclass @ \ addr SelID ^class
 (FINDM)  \ addr xt   
 EXECUTE-METHOD ;

: Init  ( -- )  \ send init: to newObject
 newObject (init:) \ ^obj SelID
 OVER              \ ^obj SelID ^obj
 sel\obj->xt            \ ^obj xt
 EXECUTE-METHOD ;

0 VALUE rec?
: rec{ TRUE TO rec? ;
: }rec FALSE TO rec? ;



\ ITRAV recursively visits each ivar and stores its ^class
\  "header" and sends the init: message.
\ rec{ ... }rec ivars do *not* get a ^dispatchTable but still
\ are sent the init: message.

0 VALUE ^objectClass  \ will contain ^class for class object

: >class  ( ^obj -- ^class )  \ get the class of an object
  CELL - @ \ ^class
  ;

: ITRAV   ( ivar offset -- )
 >R  ( ivar -- )
 BEGIN
   DUP ^Self <>
 WHILE \ ivar
   DUP iclass @
   DUP ^objectClass <> \  don't store headers for class object
   2 PICK @IvarRec? 0= AND \ only store headers if ivar is not part of a record
   IF
     IFA @
      OVER @IvarOffs R@ + RECURSE  ( initialize ivar's ivars )
      DUP iclass @     \ ivar-link-addr ^class
      OVER @IvarOffs R@ + newObject +
       ( ivar ^Class ivarAddr -- )
    2DUP  \ ivar ^Class ivarAddr ^Class ivarAddr
        CELL -  \ ivar ^Class ivarAddr ^Class ivarAddr-4
          !     \ ivar ^Class ivarAddr   ( store ^class )
     OVER \ ivar ^Class ivarAddr ^Class
     @width \ ivar ^Class ivarAddr elemWidth
     IF
       ( yes, this is an indexed ivar )
       \ ivar ^Class ivarAddr
       SWAP \ ivar ivarAddr ^Class
       DFA @ +
       OVER
       @IvarElems
       SWAP
       !  \ ivar  ( store indexed-upper-limit )
     ELSE
       2DROP \ ivar
     THEN
    ELSE DROP
    THEN
  DUP R@ InitIvar  \ send init: 
   @   ( next ivar in chain ) \ ivar(i+1)
 REPEAT R> 2DROP ;

\ **** end init: code

create scan$ maxnameSize ALLOT
0 VALUE ivar-def

: move$ ( src$ptr\dest$ptr --) \ copy src to dest, dest must be long enough
  OVER C@ 1+ MOVE ;

: add$ ( src$ptr\dest$ptr --) \ adds src$ to the end of dest$.  src$ is unchanged.
 LOCALS| $2 $1 |
 $1 1+ ( src)
 $2 DUP C@ + 1+ ( dest)
 $1 C@ ( count)
 CMOVE
 $1 C@  $2 C@ + $2 C! ;

: set-search-order  \ build a new search order
  ^class >R
  GET-ORDER  \ widn ... wid1 n   \ start with the current search order
  nclass SWAP 1+ \ add nclass to the search order build \ ***
  BEGIN
    R@ wida @ \ get the wid
    swap 1+ \ add it to the search order build
    R> sfa @ >R  \ get the superclass
    R@ ^objectClass =  \ stop when you hit class object
  UNTIL
  R> DROP
  SET-ORDER \ finally, set the new search order
  ;


\ =====================================================================
\ Compile an instance variable dictionary entry.

: <Var ( #elems ^Class | ^Class -- )
 BL WORD scan$  move$
 scan$ COUNT HASH     \ get hash value of name
 ALIGN ^Class IFA LINK ,   \ link & name
 DUP ,     \ class
  rec? 0= IF
     CELL classAllot \ allow for dispatch table ptr only if not a RECORD
  THEN
 ^Class DFA @ ,    \ offset to ivar data
      DUP @width DUP
      IF  ROT DUP ,  * CELL+  \ #elems, cell for idx-hdr
      ELSE 0 ,  \ #elems = 0
      THEN
      rec? ,  \ store RECORD status
  SWAP DFA @ + classAllot   \ Account for named ivar lengths

 C" : "    ivar-def   move$    \ : 
 scan$     ivar-def   add$     \ : ivar-name
 C"  i> "  ivar-def   add$     \ : ivar-name i>
 scan$     ivar-def   add$     \ : ivar-name i> ivar-name
 C"  ;"    ivar-def   add$     \ : ivar-name i> ivar-name ; 
 ^class wida @ SET-CURRENT
   ivar-def COUNT EVALUATE  \ compile a private wordlist definition
 FORTH-WORDLIST SET-CURRENT ;


\ =====================================================================
\ Build an instance of a class. If we are inside a class definition, 
\ build an instance variable. Otherwise build a global object.

\ Compile the indexed data header into an object
: IDX-HDR   ( #elems ^Class | ^Class -- indlen )
  @width DUP IF  OVER , ( limit )  *   THEN ;

: InitObject ( ^class -- )
   IFA @ 0 ITRAV \ initialize instance variables by storing headers
                 \ the headers are the ^class for each ivar class type
   Init \ send INIT: message implicitly
   ;

: Build   ( ^Class -- )      \ if compiling an ivar
\      or ( limit ^Class | ^Class -- ) \ if instantiating an object
 ^Class
  IF <Var \ yes, so this must be an embedded object-as-ivar declaration
  ELSE    \ no, so we must instantiate a new named dictionary object
    (Obj)
     DUP >R ,  \ store class pointer
     R@ XFA @ IF depth 1 < ABORT" Indexed object missing Limit"
              THEN
     HERE TO newObject  \ remember current ^object: used in ITRAV  
     R@ DFA @ RESERVE   \ allot space for ivars
     R@ IDX-HDR RESERVE \ allot space for indexed data
     R> InitObject
\     newObject
 THEN ;

: next-word ( -- addr str ) >IN @ BL WORD ;

: pre-scan ( -- addr len )
 next-word scan$ move$
 scan$ COUNT to-upper
 scan$ COUNT ;

CREATE classname$ maxnameSize ALLOT

: scanForClassName
 next-word classname$ move$
 classname$ COUNT to-upper
 >IN ! ;

\ allows for abbreviated :class <name> syntax.  Default superclass is Object
: scanForSuper
 pre-scan S" <SUPER" COMPARE
 IF \ we did not find <super, so invoke default
  S" <super object" EVALUATE
 THEN >IN ! ; \ restore this from pre-scan

\ =====================================================================
\ Build a class header with its superclass pointer.

FORTH-WORDLIST   SET-CURRENT

: :CLASS ( "spaces<name>" -- ) \ name of the new class being defined
    FALSE TO rec?
    scanForClassName
    CREATE
    scanForSuper
    DOES>  Build ;

: <Super  ( "spaces<name>" -- ) \ name of the superclass
  HERE TO ^class   \ save current class
  classSize ALLOT   \ reserve rest of class data
  ' >BODY    \ pfa of superclass
  DUP ^Class classSize MOVE \ copy class data
  ( ^super ) ^Class SFA !  \ store pointer to superclass
  ^Class ^Self iclass !  \ store my class in SELF

  GET-ORDER n>s  \ save prior search order for later restore
  ^objectClass \ will be zero until after we define class object below
  IF
  \ create a wordlist for the current class
  WORDLIST ^class wida ! \ store in wida field
  set-search-order
  THEN
  classname$  ^class ClassName move$ \ save class name
  100 allocate ?memErr TO ivar-def
  ;

nclass SET-CURRENT \ ***

: ;Class  ( -- )
  classAlign  \ align class data size (optional)
  ivar-def FREE DROP
  ns> SET-ORDER  \ restore original search order
  FORTH-WORDLIST  SET-CURRENT 
  0 ^Self  iclass !
  0 TO ^Class ;  \ clear class compiling flag


\ given an object and a selectorID, send the corresponding message
\ to the object
: Send ( ^obj SelID -- )
   OVER \ ^obj SelID ^obj
   CELL -  @ \ ^obj SelID ^class
   (FINDM) \ ^obj xt
   EXECUTE-METHOD ; 

\ =====================================================================
\ Selectors are immediate words that send a message to the object
\ it follows. The requirement that selectors end in ":" is
\ enforced here but not otherwise required by the implementation.

\ Message is state smart.  This could be changed but it would be cumbersome.
errorCheck
[IF]

: message   ( ^obj SelID -- )
 STATE @
 IF  
    PL  POSTPONE Send
 ELSE Send  \ run state
 THEN ;

[ELSE]

: FINDM  ( SelID MFA -- ^xt )
 BEGIN @ DUP
 WHILE 2DUP CELL+ @ = IF [ 2 CELLS ] LITERAL + ( ^xt ) NIP EXIT THEN
 REPEAT ( should never get here ) -1 ABORT" Message Not Found!" ;

: message   ( ^obj SelID -- )
 STATE @
 IF  \ compile time: ( SelID -- )  run time: ( ^obj SelID MFA-offset -- )
   POSTPONE MFA-offset PL PL \ here we compute MFA-offset at compile time
   2 PL POSTPONE pick POSTPONE cell POSTPONE - POSTPONE @ POSTPONE +
   POSTPONE FINDM POSTPONE @ POSTPONE EXECUTE-METHOD
 ELSE Send  \ run state
 THEN ;

[THEN]


: no-colon  ( str -- flag )  \ true if selector at addr does *not* end in colon
  DUP DUP C@ CHARS +  C@ [CHAR] :  =  SWAP C@ 1 > AND 0= ;

\ un-comment the following line if you do not want to enforce the message name convention
\ : no-colon ( str -- false ) DROP FALSE ;

create selectorTag  \ for marking words as selectors

: ?isSel  ( str -- flag )  \ true if word at addr is a selector
   FIND
   IF
    ( xt ) >BODY ( pfa )
    DUP 0= IF DROP FALSE EXIT THEN
    ( CELL+ ) @ selectorTag = \ 10/01/10 dbh  remove cell+
   ELSE
     ( str ) DROP FALSE
   THEN ;

: Selector  ( <name:> -- )
  CREATE IMMEDIATE
  selectorTag ,   \  mark this word as a selector
  DOES> ( pfa )  message ;

: defineSel ( in pfa -- SelID )
   DROP >IN !
   Selector
   HERE CELL - ( pfa ) ;


\ If the selector already exists, just return the existing selector,
\ otherwise create a new selector.
: getSelect  ( "spaces<name:>" -- SelID )  
   next-word DUP LOCALS| str |
   FIND
  IF ( xt ) >BODY \ pfa 
    DUP 0= IF ( not found so define new selector )
              str no-colon abort" Message name must end in colon!"
              defineSel EXIT THEN  
    DUP  \ pfa pfa
    @ selectorTag <> IF ( found, but redefine word as a selector )
                        str no-colon abort" Message name must end in colon!"
                        defineSel EXIT THEN
    NIP  \ already defined as a selector so don't redefine, NIP drops >IN
  ELSE
   \ not defined yet, so define it now
    defineSel
  THEN ;

FORTH-WORDLIST  SET-CURRENT 

: makeSelect ( "spaces<name:>"-- )
   getSelect DROP ;

nclass SET-CURRENT \ ***

0 VALUE compilingClassinit?

: scanForClassinit
 next-word scan$ move$
 scan$ COUNT to-upper
 scan$ COUNT S" INIT:" COMPARE 0=
 IF \ we have classinit:
   -1 TO compilingClassinit? \ set flag so we compile "init: super" in :M below
 THEN
 >IN ! ;


\ =====================================================================
\ Build a methods dictionary entry. :M starts a method definition
\ by adding to the class method list and starting the compiler with
\ :NONAME. ;M ends a method and saves the method xt.

: :M ( -- )
  0 TO compilingClassinit?
  FORTH-WORDLIST  SET-CURRENT  
 getSelect
 ALIGN   \ align method
 ^Class MFA LINK  \ link into method chain
 ( SelID ) ,   \ name is selector's hashed value
 HERE 0 ,  \ save location for method xt
 :NONAME    \ compile nameless definition
   ^objectClass compilingClassinit? AND
   IF S" SUPER init: " EVALUATE THEN
  ;

: ;M ( methodXT -- )  \ end a method definition
   POSTPONE ;  SWAP ! ( save xt )  ; IMMEDIATE

: finishScan
 BL WORD scan$ move$
 scan$ ?isSel  \ the message name MUST end with ":"
 SWAP
 >IN ! ; 

: scanForMessage ( -- flag ) \ true if a message follows ivar name
 next-word ( ivar$ ) drop \ skip over the ivar
 finishScan ; 


: (i>) \ compile time: ( -- ivar-^class )
    \ run time:  ( -- ^ivar )
   POSTPONE [SELF] ^class
   hash> SWAP FIND-IVAR-OFFSET
   PL POSTPONE + ( ^ivar ) ;

\ i> is ONLY used by the method compiler.
\ Early bind the following ivar to the following message
\ OR just provide the ivar address if there is no message.
\ i> is ONLY to be used in a method definition.
: i> ( "spaces<ivarname>" "spaces<messagename>" --  )
\ or ( "spaces<ivarname>" "spaces<non-messagename>" -- ivar-address )
  scanForMessage
  IF
      (i>)
      POSTPONE DUP POSTPONE CELL POSTPONE - POSTPONE @ ( ^ivar ^ivar-class )
      POSTPONE ['] POSTPONE >BODY POSTPONE @ ( ^ivar ^ivar-class SelID )
      POSTPONE SWAP POSTPONE (FINDM)
      ( ^ivar xt )  POSTPONE EXECUTE-METHOD
  ELSE
      (i>)
  THEN
  ; IMMEDIATE

nclass SET-CURRENT \ ***

: (IV) ( ^obj -- ^obj ^class )
    DUP CELL - @ ;

: ((IV)) ( ^obj ^class ivarname-hash -- ivar-addr )
    SWAP FIND-IVAR-OFFSET ( ^obj offset ) + ;

: >SelID \ input stream: ( "spaces<messagename>" -- SelID )
  ' >BODY ;

: scanForMessage2 ( -- flag ) \ true if a message follows SELF
 next-word scan$ move$
 scan$ ?isSel  \ the message name MUST end with ":"
 SWAP
 >IN ! ; 

: allocObj  ( size ^class -- )  \ allocate object and store in newObject
 OVER CELL+  \ allow for ^class
 ALLOCATE ?MEMERR \ ( size ^class addr -- )
 DUP CELL+ TO newObject  \ object address
 !   \ store the ^class
 newObject SWAP ERASE ; \ clear to zero

: (heapObj)  ( #elems class | class -- ^obj )
 >R  ( save class on return stack )
 R@ DFA @  ( ivar data size )
 R@ @width ?DUP
 IF \ indexed object, add size of indexed area
  \ ( #elems size width -- )
  2 PICK * + ( indexed data )  CELL+ ( idxHdr )
  R@ allocObj
  newObject R@ DFA @ + !  ( store #elems in idxHdr )
 ELSE
  R@ allocObj \ non-indexed object
 THEN
 R> InitObject \ initialize instance variables
 newObject  ;  \ return object address

\ FORTH-WORDLIST   SET-CURRENT

: idxBase  ( -- addr )  \ get base address of idx data area
 [self]  DUP >class DFA @ +  CELL+ ;

: ?idx  ( index -- index )  \ range check
 DUP idxBase CELL - @ ( index #elems )  0 SWAP  WITHIN IF EXIT THEN
 TRUE ABORT" Index out of range" ;

\ support for indexed objects
\ Set a class and its subclasses to indexed
: <Indexed  ( width -- )   ^Class XFA !  ;

: limit    ( -- max#elems )  \ get idx limit (#elems)
 [self]  DUP >class DFA @ +  @ ;

: width    ( -- n )  \ width of an idx element
 [self] >class XFA @ ;

errorCheck
[IF]
: ^elem   ( index -- addr ) \ get addr of idx element
 ?idx
 width *  idxBase + ;
[ELSE]
: ^elem   ( index -- addr ) \ get addr of idx element
 width *  idxBase + ;
[THEN]

\ =======================================================
\ Methodless ivar access *outside* of a class definition only.
\ Except if using on an object from a different class.
\ Form:  <object> IV <ivarname>    if interpreting
\   or:  <object> [IV] <ivarname>  if compiling

FORTH-WORDLIST  SET-CURRENT

\ interpret only, cannot be compiled
: IV ( ^obj -- ivar-addr ) \ input stream: "spaces<ivarname>"
    (IV) \ ^obj ^class
    hash> ( ^obj ^class ivarname-hash )
    ((IV)) ;

\ compile only
: [IV] ( ^obj -- ivar-addr )
  POSTPONE (IV) ( ^obj ^class )
  hash> PL  ( ^obj ^class ivarname-hash )
  POSTPONE ((IV)) ; IMMEDIATE

nclass SET-CURRENT \ ***

: SUPER \ input stream: ( "spaces<messagename>" --  )
  POSTPONE [SELF] >SelID ( ^obj selID )
  ^Class SFA @   ( ^obj selID ^superclass ) (FINDM)
  ( ^obj xt ) PL POSTPONE EXECUTE-METHOD ; IMMEDIATE

: SUPER> \ input stream: ( "spaces<classname>" "spaces<messagename>" -- )
   POSTPONE [SELF] ' >BODY ( ^obj ^super-class ) >SelID ( ^obj ^super-class selID )
   SWAP (FINDM) ( ^obj xt ) PL POSTPONE EXECUTE-METHOD ; IMMEDIATE

: SELF \ input stream: ( "spaces<messagename>" -- ) \ early bind to following message
       ( -- ^obj )  \ or just leave ^object if next word in input
                     \ stream is not a message
  scanForMessage2
  IF \ early bind to following message
       >SelID ( selID )
      ^class (FINDM) ( ^obj xt ) DUP 0= IF true abort" message not found"
                             THEN  PL POSTPONE EXECUTE 
  ELSE \ just leave ^obj => [self] if not followed by message
     POSTPONE [self]
  THEN
     ; IMMEDIATE


\ Compute total length of an object.   
\ The length does not include the dispatch table pointer.
: objlen  ( -- objlen )
 [self] >class DUP DFA @  ( non-indexed data )
 SWAP @width ?DUP
 IF  idxBase CELL - @ ( #elems ) * +  CELL+  THEN
 ;

FORTH-WORDLIST  SET-CURRENT

:class object  <super Meta
  :m classname: ( -- addr len ) self >class ClassName COUNT ;m
  :m heap: ( -- ^obj ) self >class (heapObj) ;m
  :m len: ( -- n ) objlen ;m
  :m free: ;m
  :m init: ;m 
;class

nclass SET-CURRENT \ ***

\    info. needed by ITRAV
' object >BODY to ^objectClass 

getselect init: to (init:)  

\ Bytes is used as the allocation primitive for basic classes
\ It creates an embeded ivar object of class Object that is n bytes long.

: BYTES  ( n "spaces<name>" -- )
   ['] object >BODY
   rec? 0= IF  CELL NEGATE classAllot THEN
    <Var  classAllot ;

\ ------- begin objArray() code

: (doObjArray) \ ( idx addr -- ^obj(idx) )
   dup >r \ idx addr
   cell+ @  cell+ \ idx objWidth
   *  \ offset
   r> + 3 cells + \ ^obj(idx)
;

errorcheck [IF]

: doObjArray \ ( idx addr -- ^obj(idx) )
   2dup \ idx addr idx addr
   @    \ idx addr idx #objects 
   0 swap \ idx addr idx 0 #objects
   within 0= ABORT" Invalid index for objArray()"
   (doObjArray) ;

[ELSE]

: doObjArray \ ( idx addr -- ^obj(idx) )
   (doObjArray) ;
   
[THEN]

FORTH-WORDLIST  SET-CURRENT

: objArray() \ instantiation time: ( #objects -- )
            \ or if indexed: ( #objects #elems -- )
            \ input stream: "<spaces>className" "<spaces>name()"
             \ run time execution of name()  ( idx -- ^obj(idx) )
   ' >BODY
   align create
   ( ^class) dup  \ #objects ^clss ^clss | #objects #elems ^clss ^clss
   xfa @   \ #objects ^clss xfa@ | #objects #elems ^clss xfa@
   swap    \ #objects xfa@ ^clss | #objects #elems xfa@ ^clss
   dup dfa @ \ #objects xfa@ ^clss dfa@ | #objects #elems xfa@ ^clss dfa@
   0 0         \ #objects xfa@ ^clss dfa@ 0 0 | #objects #elems xfa@ ^clss dfa@ 0 0
   locals| #elems addr0 objWidth ^clss xfa@ #objects |
   xfa@
   IF \ we have an indexed class of objects
    #objects to #elems
    to #objects
    #elems xfa@ * cell+ objWidth + to objWidth
   THEN
   #objects , objWidth ,
   here to addr0
   #objects objWidth cell+ * RESERVE
 \  | #objects | objWidth | addr0 ...
    addr0 #objects objWidth cell+ *  + addr0
    DO  ^clss i ! \ store ^class header
        i cell+ to newobject \ set up newobject so init routines will work
        xfa@ IF #elems  i  ^clss dfa @ cell+ + ( addr for #elems ) ! THEN \ store #elems if indexed
        ^clss InitObject \ perform init routines
        objWidth cell+ +LOOP \ +loop to next object in objectArray()
   
   DOES> ( idx addr )
   doObjArray
   ;

\ ------- end objArray() code

\ heap> must only be executed at run time (used in a definition).
: HEAP>   ( "spaces<classname>" -- ^obj )
  STATE @ 0= ABORT" HEAP> is a compile-only word"
 ' >BODY DUP ?isClass 0= ABORT" Not a class"
 PL  POSTPONE (heapObj)
 ; IMMEDIATE

: <FREE  ( ^obj -- )  \ free a heap object
 DUP free:
 CELL - FREE ?MEMERR ;

GET-ORDER  NIP  1-  SET-ORDER     \ hide nclass definitions ***

cr .( FMS+30dLinked extension is Loaded )


[DEFINED] no-interpretation-does-code [IF]  \ gforth
include e:\fms+30dlib.f
include e:\fms+30dtester.f  [THEN]


[DEFINED] OVI.MAGIC      [IF] \ VFX Forth
include e:\fms+30dlib.f
include e:\fms+30dtester.f  [THEN]

[DEFINED] macforth.picture      [IF] \ Carbon MacForth
myfolder.include" fms+30dlib.mf"
myfolder.include" fms+30dtester.mf"
 [THEN]



0 [IF]  \ optional tool
0 value n
0 value start 
: >CD  ( xt -- ) \ check distribution of selectors in 8 linked list "buckets"
    >BODY to start 0 to n
    8 0 DO
        0 to n
        start I cells +
        begin @ ?dup while
            n 1+ to n
        repeat
        cr i . ." ->" n .
    LOOP ;
    
\ usage:

' var >CD

0 ->1 
1 ->1 
2 ->1 
3 ->0 
4 ->1 
5 ->1 
6 ->2 
7 ->2 



[THEN]

0 [IF]
words
<FREE           HEAP>           OBJARRAY()      INIT:           FREE:           LEN:            
HEAP:           CLASSNAME:      OBJECT          [IV]            IV              MAKESELECT      
<SUPER          :CLASS          NCLASS
 
[THEN]