\ Object Oriented extensions--comments vandys
\ Creating a new class:
\ <superclass> -> subclass: <new-class>
\ or... <superclass> -> subclassVars: <new-class>
\ int8/int16/int32/intcell <name> ... endcvars
\ Define new class's instance variables:
\ ivars: int8/int16/int32/intcell <name> ... endivars
\ Define a method:
\ <class> -> :method <method-name> { arg1 ... argn self -- result... }
\ .... method;
\ Creating an instance:
\ <class> -> new ( -> <ob> )
\ Invoking a method:
\ <ob-on-stack> -> <method-name>
\ Invoking method in superclass:
\ <ob-on-stack> super-> <method-name>
\ 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;
vandys
Maximum number of distinct selectors
Magic number for a class data structure
Description of a given class
Class of a class--this is actually Object>class, defined later
Magic number tag for proper Class data structure
Our superclass
Linked list of classes sharing a common superclass
Allocation size (includes size from superclass)
Pointer to counted string for name of class
Pointer to #sels array of vectors for all system selectors
Pointer to first of subclasses (enumerated thereon via "sibs")
Calculate offsets needed by assembly code
vandys
: $strcdup Take pointer & count, carve counted string out of heap,
make it hold a copy of the indicated contents
: defClass: The "banging two rocks together" way we build the bootstrap
classes
The intial set of classes; built manually to break circularity of definitions
; noMethod abort when invoked
The innermost array of method vectors; initially they all point to an
abort.
vandys
Each instance of an Object (i.e., any object in the system) will have
an initial cell which points to the class of the object
Manually wire Object, instance of MetaObject, null superclass
: cloneMethods Make a copy of the provided methods table
: cloneRoot Clone the root methods table
Now wire up Class, instance of MetaClass, Object superclass
...wire up MetaObject, instance of Class, Class is also the superclass
...and finally, MetaClass, instance of Class, MetaObject is the superclass
MetaClass and MetaObject are on a sibling chain under Class
Most recently defined class
: ivars: Define some instance variables for the class. We leverage
the "struct" support in defining these fields.
: endivars All done with defining instance vars, record new size
Maximum size of selector name (+1... it's a counted string)
# currently allocated selector names
Array of selector names
: selalloc Allocate a new selector
This internal API will be hidden after system build, thus we
create an alias accessing it when building "oo" as debug on built system
: >sel Given string name of selector, return unique selector index
vandys
Current class receiving a method, and the methods selector index
Definition vocab before starting a method definition
The "oo" vocabulary holds entries for all OO methods defined
Constructed name for an OO method; <class>:<method>
: class? Enforce class magic number
: def>name Create a definition name of <class>.<method> in defName
Not used for invocation, but gives a name for the code for the debugger
: (:method) Compile a new method for the named class. It has a constructed
name in the "oo" vocabulary. (This code gets attached to "-> :method")
vandys
: setMethod If we inherited our method from the parent, update our
notion of the code for that method, and then notify all our subclasses
: method; Finish defining a method. Update our method table to point at
this code using setMethod, which will also handle subclasses. Leverage
";" to handle code postlog.
: trapSemi Catch closing a :method with a ; rather than method;
We use defClass as our flag to indicate a :method is active
Make counted string available to assembly code
code (->) Runtime for compiled message invocation
Get ob pointer from stack, get selector index, get class from ob
Enforce sanity check on class pointer
Get method table for class
Index for given selector, and invoke method
Throw an error for an "object" who isn't formatted correctly
: -> Send a message to object pointer on top of stack. Compiles code
to do this if we're compiling?, otherwise just executes directly. Yes,
this is state sensitive, and no, I don't care about all the reasons I
shouldn't do this.
code (super->) Runtime for super->. During compile time we grabbed the
superclass method table and indexed to the routine pointer. All we do
here is verify a proper object and then fetch the vector and jump.
: super-> Call routine in superclass context. This is a compile-only
operation which forces a call via our superclass method table.
Vector to which type of allocation to use
Bucket and heap allocator hooks
Switch to heap memory or bucket allocator
:method new Basic primitive to create new storage.
:method class Fetch class for this instance
: initClass Initialize basic fields of a Class instance, inherit size
Initialize magic #, record superclass
Thread onto subclass list of superclass
Clone method table
The chars "Meta" at a named storage location
: tagMeta Given a name string "FOO", return "MetaFOO" in allocated memory
Name of class & meta
Superclass' meta, and generated metaclass
: mkMeta Create metaclass of the class "self"... parse name from input
Mint Meta<name> Parent (self) metaclass
Create new MetaClass, initialize common fields
Stamp name onto metaclass
: mkClass Now that any class variables are defined, instantiate meta -> class
Instantiate class from metaclass, initialize common fields
Fill in name, and make class known under this name in Forth
Record this most recently defined class
vandys
:method subclass: Simplest creation of a subclass, new class with no
new class variables.
selfClass Superclass, so we can reference it in endcvars
:method subclassVars: Create new class with class variables. We hook out
to our instance variable support.
: endcvars At the end of the class variable definitions, we update the
metaclass, then let the regular code instantiate the single instance
of the metaclass (the class) and we're done.
Memory cleanup handler when using bucket memory
:method .class Display our class
Default print handler; just say what class the instance is
Abstract class for objects which hold objects
:method empty? Tell if there is contents
:method in? Tell if the given value is present
: (.) Default iterator, just show element in Collection
:method .elems Default display of elements; use -> do to iterate
:method . Default print; show class, then elements inside braces
:method first Return lowest indexed member in collection
:method last Return highest indexed member in collection