\ Object Oriented extensions--comments vandys \ Creating a new class: \ -> subclass: \ or... -> subclassVars: \ int8/int16/int32/intcell ... endcvars \ Define new class's instance variables: \ ivars: int8/int16/int32/intcell ... endivars \ Define a method: \ -> :method { arg1 ... argn self -- result... } \ .... method; \ Creating an instance: \ -> new ( -> ) \ Invoking a method: \ -> \ Invoking method in superclass: \ super-> \ Object Oriented extensions--comments vandys \ Note that initially all storage is from the heap (allot), but this may be \ switched on the fly to the bucket allocator. Care must be taken if you \ intend to unexec the image... only extensions definitions also forth \ Object Oriented extensions--basic defines vandys 64 constant #sels Local #sels cells constant #selsSize Local 1234321 constant #classMagic Local struct Class \ Break circular dependency by building ivars directly intcell class intcell magic intcell super intcell sibs intcell size intcell name intcell methods intcell subclasses endstruct 0 Class>magic constant offMagic Local 0 Class>methods constant offMethods Local \ OO--define initial classes, build initial method vector array vandys \ Object, root of type hierarchy, created here manually : $strcdup ( str cnt -- str' ) here over c, -rot dup 1+ allot align ( mem str cnt ) 2 pick 1+ swap move ; : defClass: ( -- ) create here Class.size zallot ( classmem ) last @ count $1F and $strcdup over Class>name ! #classMagic swap Class>magic ! ; scrLocal defClass: Object defClass: Class defClass: MetaObject defClass: MetaClass : noMethod ( -- ) 1 abort" No method" ; Local here #selsSize allot constant (rootMethods) Local (rootMethods) #sels ' noMethod wfill \ OO--manually wire initial set of classes vandys struct Object intcell class endstruct MetaObject Object Object>class ! \ 0 Object Class>super ! (rootMethods) Object Class>methods ! Object.size Object Class>size ! Class Object Class>subclasses ! : cloneMethods ( a -- a' ) here #selsSize allot tuck #selsSize move ; Local : cloneRoot ( -- a' ) (rootMethods) cloneMethods ; scrLocal MetaClass Class Object>class ! Object Class Class>super ! cloneRoot Class Class>methods ! Class.size Class Class>size ! MetaObject Class Class>subclasses ! Class MetaObject Object>class ! Class MetaObject Class>super ! cloneRoot MetaObject Class>methods ! Class.size MetaObject Class>size ! MetaClass MetaObject Class>subclasses ! Class MetaClass Object>class ! MetaObject MetaClass Class>super ! cloneRoot MetaClass Class>methods ! Class.size MetaClass Class>size ! MetaClass MetaObject Class>sibs ! \ OO--instance variables vandys variable lastClass Local : ivars: ( -- ) lastClass @ dup Class>size @ (struct_idx) ! Class>name @ count (struct_prefix!) ; : endivars ( -- ) (struct_idx) @ lastClass @ Class>size ! ; \ OO-method selectors vandys 32 constant selnameSize Local variable nsel Local create selNames #sels selnameSize * allot align Local : selalloc ( a-str u-len -- ) nsel @ dup #sels >= abort" Out of selectors" selnameSize * selNames + $strconv nsel @ nsel inc ; scrLocal [ifndef] ($cstreq?) : ($cstreq?) (locals).($cstreq?) ; [then] : >sel ( a u -- u' ) selNames nsel @ 0 ?do 3dup count ($cstreq?) if 3drop i unloop exit then selnameSize + loop drop selalloc ; Local \ OO-methods vandys variable defClass Local variable defIdx Local variable oldDef Local vocabulary oo ' oo cell+ cell+ cell+ constant oo-addr create defName 32 allot Local : class? ( class -- ) Class>magic @ #classMagic - abort" Bad class magic" ; Local : def>name { str len -- } defClass @ Class>name @ { cname } cname c@ len + 30 > abort" Name too long" defName cname $strcpy defName [char] : $ccat str len defName $strccat ; Local : (:method) ( class -- ??? ) dup class? defClass ! current @ oldDef ! oo-addr current ! bl parse 2dup def>name >sel defIdx ! defName (:) ; Local \ OO-methods vandys : setMethod { class idx old-ca new-ca -- } idx cells class Class>methods @ + dup @ old-ca <> if drop exit then ( a-method ) new-ca swap ! class Class>subclasses begin @ ?dup while dup idx old-ca new-ca recurse Class>sibs repeat ; scrLocal : method; ( ??? -- ) defClass @ dup { def } 0= abort" Not in :method" defClass off defIdx @ { idx } [compile] ; oldDef @ current ! last @ nfa>cfa @ { ca } def Class>methods @ idx cells + @ { old-ca } def idx old-ca ca setMethod ; immediate compile-only : trapSemi ( -- ) defClass @ defClass off abort" missing method;" ; scrLocal [ifndef] 'semiHook : 'semiHook (locals).'semiHook ; [then] ' trapSemi 'semiHook ! \ Now bind (:method) to Class -> :method :noname c" :method" ; execute constant ":method" scrLocal Class ":method" count >sel ' noMethod ' (:method) setMethod \ OO-invocation vandys :noname c" Bad class magic" ; execute constant "badMagic Local code (->) ( ob -- ob ) 0 [esp] ecx mov lods 0 [ecx] ecx mov offMagic [ecx] ebx mov #classMagic # ebx cmp 1 $ jne offMethods [ecx] ebx mov ebx eax add 0 [eax] eax mov eax jmp 1 $: "badMagic push# ' (abort) # eax mov eax jmp c; scrLocal : -> ( runtime: ob -- ) bl parse >sel cells compiling? if (genhook) compile (->) , exit then ( ob idx ) over Object>class @ dup class? ( ob idx class ) Class>methods @ + @execute ; immediate \ OO-superclass invocation vandys code (super->) 0 [esp] ecx mov lods 0 [ecx] ecx mov 0 [eax] eax mov offMagic [ecx] ebx mov #classMagic # ebx cmp 1 $ jne eax jmp 1 $: "badMagic push# ' throw # eax mov eax jmp c; scrLocal : super-> ( runtime: ob -- ) bl parse >sel cells (genhook) compile (super->) defClass @ dup class? Class>super @ Class>methods @ + , ; immediate compile-only \ OO-instance creation vandys variable 'allocator scrLocal : allocHeap ( size -- a ) here swap zallot ; scrLocal : allocBk ( size -- a ) bkzalloc ; scrLocal : oo-heapmem ( -- ) ['] allocHeap 'allocator ! ; : oo-bkmem ( -- ) ['] allocBk 'allocator ! ; oo-heapmem \ Default, start from heap memory Class -> :method new { self -- obj } self Class>size @ aligned 'allocator @execute ( obj ) self over Object>class ! method; Object -> :method class ( self -- class ) Object>class @ method; : initClass { super class -- } super Class>size @ class Class>size ! #classMagic class Class>magic ! super class Class>super ! super Class>subclasses @ class Class>sibs ! class super Class>subclasses ! super Class>methods @ cloneMethods class Class>methods ! ; Local \ OO-supporting methods for class definition vandys create "Meta" scrLocal char M c, char e c, char t c, char a c, : tagMeta ( a -- a' ) 6 $strdup+ { str } str count over 4 + swap move "Meta" str 1+ 4 move 4 str c+! align str ; scrLocal variable name Local variable metaname Local variable selfmeta Local variable metaclass Local : mkMeta { self -- } align here bl ($,c) dup name ! ( name ) tagMeta metaname ! self Class>class @ selfmeta ! Class -> new dup metaclass ! selfmeta @ swap initClass metaname @ metaclass @ Class>name ! ; Local : mkClass { self -- } metaclass @ -> new { class } self class initClass class name @ (constant) name @ class Class>name ! class lastClass ! ; Local \ OO-building subclasses vandys Class -> :method subclass: ( self -- ) dup mkMeta mkClass method; variable selfClass scrLocal Class -> :method subclassVars: ( self -- ) dup selfClass ! mkMeta metaclass @ lastClass ! ivars: method; : endcvars ( -- ) endivars selfClass @ mkClass ; \ OO-instances and basic classes vandys Object -> :method free ( self -- ) bkfree method; Object -> :method .class ( self -- ) Object>class @ Class>name @ .id method; Object -> :method . ( self -- ) ." A " -> .class method; Object -> subclass: Collection Collection -> :method empty? { self -- ? } self -> size 0= method; Collection -> :method in? { self -- ? } self -> indexOf dup if nip then method; : (.) ( 0 elem -- ) nip . ; scrLocal Collection -> :method .elems ( self -- ) 0 ['] (.) rot -> do method; Collection -> :method . ( self -- ) dup -> .class ." {" -> .elems ." }" cr method; Collection -> :method first ( self -- elem ) 0 swap -> @ method; Collection -> :method last ( self -- elem ) dup -> size 1- swap -> @ method;