\ 10/11/10 dbh \ object-message syntax \ dispatch tables 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 0 [IF] \ for gforth and vfx, do a copy/paste \ your drive letter may be different include e:\fms+30dDispatch.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] : 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 ; : HASH-IVAR ( addr len -- n ) TUCK OVER + SWAP ?DO 6 LSHIFT I C@ 32 OR XOR LOOP DUP 0< IF EXIT THEN INVERT ; \ ===================================================================== \ Class Structure. 0 VALUE ^class \ pointer to class being defined 0 VALUE newObject \ object being created : IFA ( ^class -- addr_ifa ) CELL + ; \ ivar dict Latest field : DFA ( ^class -- addr_dfa ) 2 CELLS + ; \ datalen of named ivars : XFA ( ^class -- addr_xfa ) 3 CELLS + ; \ elem width for indexed area, <= 0 if not indexed : SFA ( ^class -- addr_sfa ) 4 CELLS + ; \ superclass ptr field : WIDA ( ^class -- addr_wid ) 5 CELLS + ; \ wid field : TAG ( ^class -- addr_tag ) 6 CELLS + ; \ class tag field : ClassName ( ^class -- $ptr ) 7 CELLS + ; \ class name (all uc) 8 CELLS maxnameSize + CONSTANT classSize : badMessage TRUE ABORT" message not understood" THROW ; : notUnderStood 0 TO ^class badMessage ; 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" -- ) CREATE \ Run time ( -- ^obj ) DOES> CELL+ ; \ ========================= begin code unique to dispatch table =============== \ ***** heap table accessing \ the heap heap table is a temporary table that only exists during the \ definition of a new class. At the end of the class definition the \ contents of the heap table are combined with the superclass table \ to construct the final dispatch table that is allotted in the dictionary. 0 VALUE heapTable \ will be an allocated pointer 0 VALUE heapTableSize \ size in bytes : initHeapTable ( n -- ) \ n is number of cells CELLS DUP ALLOCATE ?MEMERR TO heapTable TO heapTableSize heapTable heapTableSize ERASE ; \ initialize all cells to zero : freeHeapTable heapTable FREE ?MEMERR ; : hTableSize ( -- cells) heapTableSize CELL / ; : resizeHeapTable ( n -- ) \ n is number of cells CELLS DUP heapTable SWAP RESIZE ?MEMERR TO heapTable TO heapTableSize ; : hElemAddr ( Idx -- addr) CELLS heapTable + ; \ Idx is cell# : toHeapTable ( n Idx -- ) hElemAddr ! ; : atHeapTable ( Idx -- n ) hElemAddr @ ; : incrHeapTable ( -- ) \ increase size by 1 cell hTableSize 1+ resizeHeapTable 0 hTableSize 1- toHeapTable ; \ zero the slot \ ***** superclass table accessing : supTable ( -- addr) \ address of first cell of table, which will be the size ^class SFA @ @ ; : supTableSize ( -- cells) supTable @ CELL / ; : atSupTable ( Idx -- n ) CELLS supTable + @ ; \ ***** dispatch table accessing : disTable ( -- addr) \ address of first cell of table, which will be the size ^class @ ; : toDisTable ( n Idx -- ) CELLS disTable + ! ; : transferMethodXTs \ transfer from heap table to newly allotted table hTableSize 1 \ for cells# 1 through heap table size DO I atHeapTable ( xt) DUP 0= IF DROP ['] notUnderStood THEN I toDisTable LOOP hTableSize 1- CELL * ( aus ) 0 toDisTable ; \ store table max offset ( aus ) in cell zero : AdvanceSuperclMethodXTs \ from supTable to heapTable hTableSize 1 DO I atHeapTable 0= IF \ we have an open slot, so check superclass I supTableSize 1+ < \ make sure superclass table is within bounds IF \ transfer xt(i) from superclass table to heap table I atSupTable ( xt) I toHeapTable THEN THEN LOOP ; \ ========================= end code unique to dispatch table =============== : 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 @ ; : FIND-IVAR ( ivarID ^class -- addr true | false ) IFA \ convert ^class to ivar linked list address BEGIN @ DUP WHILE 2DUP CELL+ @ = IF 2 CELLS + NIP TRUE EXIT THEN REPEAT NIP ; \ 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 ; : EXECUTE-METHOD ( ^obj xt -- ) [SELF] >R SWAP ( xt ^obj ) TO [SELF] EXECUTE R> TO [SELF] ; [DEFINED] CATCH [IF] : CATCH ( -- n ) [SELF] >R CATCH R> TO [SELF] ; [THEN] errorCheck [IF] : >xt ( SelId ^dispatchTable -- xt ) \ error check 2DUP @ ( SelId ^dispatchTable SelId maxSelID ) > IF badMessage THEN + @ ; [ELSE] : >xt ( SelId ^dispatchTable -- xt ) \ no error check + @ ; [THEN] : hash> ( -- n ) BL WORD COUNT HASH-IVAR ; \ ===================================================================== \ An instance variable record consists of six 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 - @ >xt ; 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 @ \ addr SelID ^dispatchTable >xt \ 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 traverses the tree of nested ivar definitions in a class, \ building necessary dispatch table pointers. 0 VALUE ^objectClass \ will contain ^class for class object : >class ( ^obj -- ^class ) \ get the class of an object CELL - @ \ ^dispatchTable CELL - @ \ ^class ; \ ITRAV recursively visits each ivar and stores its ^dispatchTable \ "header" and sends the init: message. \ rec{ ... }rec ivars do *not* get a ^dispatchTable but still \ are sent the init: message. : ITRAV ( ivar offset -- ) \ ivar is a link addr in the linked list >R ( ivar -- ) BEGIN DUP ^Self <> WHILE \ ivar DUP iclass @ DUP ^objectClass <> \ only store headers if not 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 SWAP \ ivar ^Class ivarAddr ivarAddr-4 ^Class @ \ ivar ^Class ivarAddr ivarAddr-4 ^dispatchTable SWAP \ ivar ^Class ivarAddr ^dispatchTable ivarAddr-4 ! \ ivar ^Class ivarAddr ( store ^dispatchTable ) 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 link 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 ; : " 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 ^dispatchTables for each ivar class type Init \ send INIT: message implicitly ; \ ===================================================================== \ Build an instance of a class. If we are inside a class definition, \ build an instance variable. Otherwise build a global object. : Build ( ^Class -- ) \ if compiling an ivar \ or ( limit ^Class | ^Class -- ) \ if instantiating an object ^Class IF R @ , \ store dispatch table 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 syntax. Default superclass is Object : scanForSuper pre-scan S" IN ! ; \ restore this from pre-scan FORTH-WORDLIST SET-CURRENT : :CLASS ( "spaces" -- ) \ name of the new class being defined FALSE TO rec? scanForClassName CREATE scanForSuper DOES> Build ; : " -- ) \ 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 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 ^class ^Self iclass ! classname$ ^class ClassName move$ \ save class name 100 allocate ?memErr TO ivar-def ^class SFA @ Meta = \ will be true only when compiling class OBJECT IF \ compiling class object, so there is no superclass dispatch table, \ therefore we must start a new heap table from scratch. 1 initHeapTable \ cell 0 will be the #ofXTs for this class ELSE \ get initial size from superclass supTableSize ( size of superclass dispatch table in cells) 1+ initHeapTable \ start with a heap table of same size as superclass THEN ; nclass SET-CURRENT \ *** : ;CLASS classAlign \ align class data size (optional) ^class , \ store ^class at one cell before the dispatch table HERE ^class ! \ now make ^class point to the first cell of the dispatch table hTableSize CELLS ALLOT \ allot the dictionary dispatch table AdvanceSuperclMethodXTs \ move XTs from superclass table to empty cells in heap table transferMethodXTs \ from the heap table to the dispatch table freeHeapTable 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 ^dispatchTable >xt \ ^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 -- ) \ at runtime \ or ( SelID -- ) if compiling STATE @ IF \ compiling PL POSTPONE Send ELSE \ interpreting Send THEN ; [ELSE] \ no error check : message ( ^obj SelID -- ) \ at runtime \ or ( SelID -- ) if compiling STATE @ IF \ compiling => postpone literal postpone Send PL POSTPONE OVER POSTPONE CELL POSTPONE - POSTPONE @ POSTPONE + POSTPONE @ POSTPONE EXECUTE-METHOD ELSE \ interpreting Send THEN ; [THEN] 0 VALUE lastSelectorIndex : 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 ; 0 VALUE curSelIdx 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 = ELSE ( str ) DROP FALSE THEN ; : Selector ( "spaces" -- ) CREATE IMMEDIATE lastSelectorIndex CELL+ DUP TO lastSelectorIndex , selectorTag , \ mark this word as a selector DOES> ( pfa ) @ Message ; : defineSel ( in pfa -- SelID ) DROP >IN ! Selector HERE [ 2 CELLS ] LITERAL - ( pfa ) @ ; : getSelect ( "spaces" -- 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 CELL+ @ 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"-- ) 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 dispatch table entry. :M starts a method definition \ and starting the compiler with \ :NONAME. ;M ends a method and saves the method xt in the table. : :M ( "spaces" -- methodXT ) 0 TO compilingClassinit? FORTH-WORDLIST SET-CURRENT ^objectClass IF scanForClassinit THEN getSelect ALIGN CELL / TO curSelIdx :NONAME ^objectClass compilingClassinit? AND IF S" SUPER init: " EVALUATE THEN ; : ;M ( methodXT -- ) POSTPONE ; \ the methodXT from above :NONAME will be on the stack ( methodXT ) \ save on stack, to be consumed after REPEAT BEGIN hTableSize 1- curSelIdx < WHILE incrHeapTable \ increase table size by one cell REPEAT ( methodXT ) curSelIdx toHeapTable \ store xt in proper cell in dispatch table ; 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" "spaces" -- ) \ or ( "spaces" "spaces" -- ivar-address ) scanForMessage IF (i>) POSTPONE DUP POSTPONE CELL POSTPONE - POSTPONE @ ( ^ivar ^ivar-disptch ) POSTPONE ['] POSTPONE >BODY ( ^ivar ^ivar-disptch selID ) POSTPONE @ POSTPONE SWAP POSTPONE >xt ( ^ivar xt ) POSTPONE EXECUTE-METHOD ELSE (i>) THEN ; IMMEDIATE nclass SET-CURRENT \ *** : (IV) ( ^obj -- ^obj ^class ) DUP CELL - @ ( ^obj ^dispatchTable ) CELL - @ ; : ((IV)) ( ^obj ^class ivarname-hash -- ivar-addr ) SWAP FIND-IVAR-OFFSET ( ^obj offset ) + ; : >SelID \ input stream: ( "spaces" -- 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 ^dispatchTable -- ) \ allocate object and store in newObject OVER CELL+ \ allow for ^dispatchTable ALLOCATE ?MEMERR \ ( size ^dispatchTable addr -- ) DUP CELL+ TO newObject \ object address ! \ store the ^dispatchTable 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 : 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 : 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: