\ ############################################################################ \ ### small oops. binds (late) pretty fast, but classes use much memory. ### \ ### would need work to name instance variables. currently, instance data ### \ ### is referred by address of first byte of instance data ### \ ############################################################################ \ \ this code has been placed and released under the LGPL by its author. \ \ --- version history --- \ 2004Dec16 ls v0.03 ported to bashforth. Requires BashForth 0.53 or more recent. \ 2004Dec09 ls v0.02c method search slightly speeded up \ 2004Dec07 ls v0.02b added method finalize to superclass \ 2004Dec07 ls v0.02a link through all classes added, allowing .classes \ 2004Dec07 ls v0.02 instances of one class are linked to each other, anchor is in class \ this allows for method "alike" or forth word "instances" \ 2004Dec06 ls v0.01c improved examples \ 2004Dec06 ls v0.01b improved examples \ 2004Dec05 ls v0.01a improved examples \ 2004Dec05 ls v0.01 initial version. functional. \ \ how to crash (or at least confuse) this (conditions not tested for): \ \ subclass or instantiate a class, then add instance data to class (grow), \ and add methods to class, writing to added instance data. \ Reason: new methods are inherited to subclass, but changes \ to the amount of instance data aren't. \ \ ---------------------------------------------------------------------------- \ --- general purpose --- \ ---------------------------------------------------------------------------- : erase ( a n -- ) 0 fill ; : allot0 ( n -- ) here swap dup allot erase ; : name>string ( a1 -- a2 n ) name ; : .header ( a -- ) body> >name .name space ; : peek ( c -- a n ) >in @ >r stream r> >in ! ; : pluck ( x1 x2 x3 -- x1 x2 x3 x1 ) 2 pick ; : compile r> dup @ , cell+ >r ; : [compile] ( -- ) ' , ; immediate : postpone [compile] [compile] ; immediate : value ( x -- ) create , does> @ ; : to compiling if ' >body [compile] literal compile ! else ' >body ! then ; immediate \ ---------------------------------------------------------------------------- \ --- access, helpers, glue --- \ ---------------------------------------------------------------------------- 256 constant maxmethods 0 value activeclass 0 value self 0 value #methods create classlink 0 , create methodnames maxmethods cells allot0 : >instancelink ( a1 -- a2 ) cell+ ; \ class: instance link anchor \ object: link to sibling : >classlink ( a1 -- a2 ) [ 2 cells ] literal + ; \ class: subclass link anchor \ object: unused : >instancedata ( a1 -- a2 ) [ 3 cells ] liteal + ; \ class: address of instance data size \ object: instance data : >methods ( class -- methods ) [ 4 cells ] literal + ; \ class to method table : instancedata ( -- a ) self >instancedata ; \ instance data of self : method ( class n -- method ) cells + >methods ; \ address of nth method in class : .class ( class -- ) ?dup if .header then ; \ output class name : .object ( object -- ) .header ; \ output object/instance name : methodname ( n -- a n ) \ method number to method name cells methodnames + @ ?dup if name>string else s" " then ; : .method ( n -- ) methodname type space ; \ output method name from message token : nomethod ( a n -- f ) \ string search method, true if non-existent true #methods 0 ?do drop 2dup i methodname compare dup 0= ?leave loop nip nip ; \ ---------------------------------------------------------------------------- \ --- oo core --- \ ---------------------------------------------------------------------------- : class: create ( -- ) activeclass here dup to activeclass over , \ pointer to parent class (or 0) 0 , \ anchor of link through instances classlink exchange , >instancedata @ , \ instance data size maxmethods cells allot0 \ method table does> to activeclass ; : new: create ( -- ) activeclass here dup to self over , \ pointer to class over >instancelink exchange , \ link through instances 0 , \ unused (for similiar object- and class layout) >instancedata @ allot0 \ allocate instance data does> to self ; : newmethod create ( -- ) last @ >name \ method name #methods dup 1+ to #methods cells dup , \ method token (offset into method table) methodnames + ! \ put method name in table of method names does> ( -- ) @ >methods self \ msg obj begin @ dup while \ while parent class 2dup + @ ?dup if \ method available ? nip nip execute exit \ yes, execute and be done then repeat -21 throw ; \ "unsupported operation" = no method found : { ( -- a1 a2 ) \ start defining a method bl peek nomethod if \ new method name: >in @ >r newmethod \ create new method name r> >in ! then activeclass >methods ' >body @ + \ pointer to method code :noname ; \ start compilation : } ( a1 a2 -- ) postpone ; swap ! ; immediate \ end compilation, store method address : grow ( bytes -- ) activeclass >instancedata +! ; \ allocate additional instance data \ ----------------- create the superclass ---------------------------- \ ( create the superclass ) pad to activeclass \ create a temporary class lookalike activeclass 4 cells erase \ serving as superclass parent class class: superclass \ the mother of all classes 0 activeclass ! \ zero out parent class pointer of superclass \ superclass is now the active class \ ---------------------------------------------------------------------------- \ --- demo + test --- \ ---------------------------------------------------------------------------- \ ------------------------- syntax ------------------------- \ creating classes/subclasses: \ parentclass class: newclass \ parent class is optional, if not specified, the "active class" is used as parent class. \ upon creation of a new class, the new class becomes "active class" \ creating instances: \ parentclass new: instance \ parent class is optional, if not specified, the "active class" is used as parent class. \ adding methods: \ parentclass { methodname code } \ parent class is optional, if not specified, method is added to "active class" \ method invocation: \ instance method \ instance is optional, if omitted, the "self" object is used, which is the most recently invoked object \ -------------------------- example ----------------------- superclass class: model \ model is subclass of superclass class: vehicle \ vehicle is subclass of model, cell grow \ one cell is alloted for instance data \ --- methods to vehicle class { speed ( -- a ) instancedata @ } \ method "speed" returns instance data { accelerate ( n -- ) instancedata +! } \ method for speed change { stop ( -- ) speed negate accelerate } \ method to zero speed { show ( -- ) ." km/h: " speed . } \ method for speed output class: car { dynamic ( -- n ) 10 } \ class "car is a subclass of vehicle, \ the method dynamic returns the acceleration rate new: ford \ ford is an instance of class car \ active class is still car, but the next \ methods should be introduced to vehicle: vehicle { faster dynamic accelerate show } \ vehicle method to increase speed { slower dynamic negate accelerate show } \ vehicle method to reduce speed \ try: \ ford faster faster \ slower \ show \ speed . vehicle class: boat class: yacht { dynamic ( -- n ) 5 } \ boat is subclass of vehicle, \ yacht is subclass of boat, boat class: trawler { dynamic ( -- n ) 2 } \ trawler is a subclass of "boat" yacht new: akira \ create an instance of "yacht" trawler new: hermes \ create an instance of "trawler" \ --------------------------------------------------------------- \ --- add some debug- and diagnostic methods to superclass --- \ --- these methods will be available to all objects --- \ --------------------------------------------------------------- superclass { class ( -- a ) self @ } \ returns object's class { objectsize ( -- n ) \ return size of instance data class \ object's class >instancedata \ point to size of instance data @ \ read size of instance data } { hierarchy ( -- ) \ outputs class hierarchy of object self begin @ \ read parent class (superclass returns 0) ?dup while dup .class \ output parent class repeat } { provider ( method -- class ) \ which class provides method to object ? >r \ method false \ assume no provider self \ object begin @ \ get parent class (superclass returns 0) 2dup 0= or 0= \ loop as long as method not found and parent class exists while dup r@ method @ \ read method address if or dup then \ indicate "method found", by returning class repeat r> 2drop } { examine ( -- ) \ diagnostic aid: show information about object cr cr ." --- OVERVIEW ---" cr ." object " self .object ." is instance of class " class .class ." with " objectsize . ." increments of instance data" cr cr ." --- CLASS HIERARCHY ---" cr hierarchy cr cr ." --- METHOD PROVIDERS ---" #methods 0 do i provider ?dup if cr i .method ." provided by " .class then loop \ cr cr ." --- INSTANCE DATA ---" \ instancedata objectsize dump ( there's no dump in bashforth yet ) cr cr ." --- OBJECT DATA ---" cr show } { methods ( -- ) #methods 0 do i provider if i .method then loop } \ outputs all methods available to object { alike ( -- ) class begin >instancelink @ ?dup while dup .object repeat } \ use: object alike { finalize ( -- ) \ finalizing a class involves collecting class \ all methods provided by parent classes, #methods 0 do \ and introduce them into object's class i provider \ resulting in quicker binding. Inheriting ?dup if \ new methods from parent classes still works, 2dup <> if \ but replaced methods won't get inherited. 2dup i method @ swap i method ! then drop then loop drop } \ ------------------------------------------------------------------------------------------- \ additional diagnostics \ ------------------------------------------------------------------------------------------- : .methods ( -- ) #methods 0 ?do cr i dup . .method loop ; : .instances ( -- ) activeclass begin >instancelink @ ?dup while dup .object repeat ; : .classes ( -- ) classlink begin @ ?dup while cr dup .class dup begin >instancelink @ ?dup while cr 3 spaces dup .object repeat >classlink repeat ;