\ \ File name: OOP.FS loads on top of gforth \ \ Last_change: KS 19.02.2012 17:25:25 \ \ with polymorphism on demand and late binding Only Forth also definitions warnings off hex cr .( simpleOOP V_2.3 polymorphic late binding with single inheritance and proxies.) cr \ ----------------------------------------------------------------------------- \ gforth extensions \ ----------------------------------------------------------------------------- true Constant gforth_062 \ gforth_070 when false : cell- 1 cells - ; : ?comp state @ 0= Abort" compilation only" ; : ?exec state @ Abort" execution only" ; : case? ( n1 n2 -- n1 ff | tf ) over = dup IF nip THEN ; Create restore ] r> r> ! EXIT [ \ poor man's local variable mechanism : save ( var -- ) r> swap dup >r @ >r restore >r >r ; : becomes ( xt -- ) \ makes existing behave as xt here >r >r ' >body dp ! postpone ahead r> >body dp ! postpone THEN r> dp ! ; : new.voc ( wid -- ) dup >r wordlist-struct %size + dup head? -1 = IF ( wid nt ) dup name>int dup >code-address docon: = swap >body @ r@ = and IF id. rdrop EXIT THEN THEN drop r> body> >head-noprim id. ; ' new.voc becomes .voc : \\ ( -- ) SOURCE-ID 1+ 1 U> IF BEGIN REFILL 0= UNTIL THEN POSTPONE \ ; IMMEDIATE : set ( mask addr -- ) dup >r @ or r> ! ; : reset ( mask addr -- ) >r invert r@ @ and r> ! ; \ ----------------------------------------------------------------------------- \ OOP mechanisms on top of gforth \ ----------------------------------------------------------------------------- Vocabulary Oop Oop also definitions Variable (doClass : doClass ( -- xt ) (doClass @ ; Variable (doObj : doObj ( -- xt ) (doObj @ ; Variable (doAttr : doAttr ( -- xt ) (doAttr @ ; Variable (doProxy : doProxy ( -- xt ) (doProxy @ ; Variable (doPoly : doPoly ( -- xt ) (doPoly @ ; Variable LastClass LastClass off Variable ClassContext ClassContext off \ Current class context Variable (static (static off \ controls behaviour of subclass definition : Forth-context ( -- ) ClassContext off ; : set-class ( class -- ) LastClass ! ClassContext on ; Variable 'classroot 'classroot off \ serves as a forward reference Forth definitions : Class ( -- ) Vocabulary 0 , 0 , 'classroot @ , immediate \ | search-xt | wordlist | Voclink | ext || attr | size | parent | DOES> ( -- ) [ here (doClass ! ] set-class ; Oop definitions : classorder ( -- ) \ establish Forth search inside a :-definition r> context save >r LastClass @ ?dup 0= Abort" Class context undefined" context ! ; : CurrentClass ( -- cpa ) Current @ cell- @ doClass - Abort" No class compilation context set" Current ; : c.last ( cpa -- addr ) @ cell+ ; \ anchor of class wordlist : c.attr ( cpa -- addr ) @ [ 4 cells ] Literal + ; 1 Constant #sealed \ attribute bit 2 Constant #static : seal-lastclass ( -- ) #sealed LastClass c.attr set ; : ?unsealed ( -- ) CurrentClass c.attr @ #sealed and Abort" Class is sealed" ; : c.size ( cpa -- addr ) @ [ 5 cells ] Literal + ; : c.parent ( cpa -- addr ) @ [ 6 cells ] Literal + ; : search-methods ( addr len listaddr -- nfa | 0 ) BEGIN >r 2dup r@ @ (search-wordlist) ?dup IF nip nip rdrop EXIT THEN r> c.parent dup @ 0= UNTIL drop 2drop false ; : class' ( -- xt ) name LastClass search-methods dup 0= Abort" not found in class context" name>int ; : OopCreate ( -- ) Create LastClass @ , immediate ; : >object ( addr -- obj ) dup @ set-class cell+ ; : :cfa, ( -- ) docol: , 0 , ; : == ( xt u -- xt f ) over cell+ @ = ; : ?polymorphic ( xt1 -- xt2 ) dopoly == IF >body cell+ THEN ; \ ----------------------------------------------------------------------------- \ outer interpreter for gforth_0.62 \ ----------------------------------------------------------------------------- : redefine ( nfa -- ) name>int ?polymorphic >body cell+ @ body> compile, ; : oop-compiler ( c-addr u -- ) ClassContext @ Forth-context IF 2dup LastClass search-methods ?dup IF nip nip dup last @ = \ last was set in redefine-method IF redefine EXIT THEN name>comp execute EXIT THEN compiler-notfound EXIT THEN 2dup find-name ?dup IF nip nip name>comp execute EXIT THEN 2dup snumber? ?dup IF 0> IF swap postpone Literal THEN postpone Literal 2drop EXIT THEN compiler-notfound ; : oop-interpreter ( c-addr u -- ) ClassContext @ Forth-context IF 2dup LastClass search-methods ?dup IF nip nip name>int execute EXIT THEN 2drop interpreter-notfound EXIT THEN 2dup find-name ?dup IF nip nip name>int execute EXIT THEN 2dup 2>r snumber? IF 2rdrop EXIT THEN 2r> interpreter-notfound ; gforth_062 [IF] : new[ ( -- ) ['] oop-interpreter IS parser state off ; immediate : new] ( -- ) ['] oop-compiler IS parser state on ; ' new[ becomes [ ' new] becomes ] [ \ start the new interpreter [ELSE] cr .( this should hold code for gforth_071 but it doesn't !!! ) \ : host-compiler1 ( addr len -- xt ) host-compiler ['] noop ; \ ' host-compiler1 IS parser1 [THEN] \ ----------------------------------------------------------------------------- \ OOP support in the Root wordlist \ ----------------------------------------------------------------------------- Forth Root definitions Forth : classes ( -- ) space Voclink BEGIN @ ?dup WHILE dup 2 cells - dup body> cell+ @ doClass = IF dup body> >name .name THEN drop REPEAT ; : methods ( -- ) LastClass BEGIN dup c.parent @ WHILE dup @ dup cr .voc ." : " wordlist-id BEGIN @ ?dup WHILE dup .name REPEAT c.parent REPEAT drop ; \ ----------------------------------------------------------------------------- \ Polymorphism on demand \ ----------------------------------------------------------------------------- \ Polymorphic is a defining word, which reserves one field in each instantiated \ object that holds the xt of the actual method. Polymorphic can only be used \ as long as the class is not sealed. \ Immediately following the polymorphic data type is a branch to the latest \ code that will be used to initialize the object's associated xt-field. \ Initially, this branch points to code that will print an "uninitialized" error \ message. Later on, a :-definition of the same name will modify the branch, \ to point to it. \ See: set-polymorphics in "Object" for initializing the xt \ ----------------------------------------------------------------------------- Oop definitions : set-polymorphics ( obj -- ) \ initialize polymorphic xt's of an object >r LastClass BEGIN dup c.last BEGIN @ ?dup \ another word present? WHILE dup name>int cell+ @ dopoly = \ is it of type polymorphic? IF dup name>int >body \ addr of index field dup @ r@ + @ 0= \ is the xt for this index still uninitialized? IF dup cell+ over @ r@ + ! THEN \ then set it to the code starting after the polymorphic type drop THEN REPEAT c.parent \ go to next subclass dup c.parent @ 0= \ no need to search ClassRoot UNTIL drop rdrop ; \ : do-polymorphic ( obj offset -- ) over + @ ?dup 0= Abort" un-initialized poly-field in object" execute ; \ for debugging set-polymorphics : do-polymorphic ( obj offset -- ) over + @ execute ; : un-initialized true Abort" un-initialized message" ; Forth definitions : Polymorphic ( -- ) ?unsealed Create immediate CurrentClass c.size @ , \ offset into object's data field 1 cells CurrentClass c.size +! :cfa, postpone un-initialized postpone EXIT \ | offset | :-definition of actual method DOES> ( obj -- ) [ here (doPoly ! ] @ State @ IF postpone Literal postpone do-polymorphic EXIT THEN do-polymorphic ; \ ----------------------------------------------------------------------------- \ ClassRoot and initial methods \ ----------------------------------------------------------------------------- Oop definitions : copy-word ( nfa cells -- nfa ) >r dup dup cell+ @ $1F and over 2 cells + swap header, cfalign name>int here r> cells dup allot cmove reveal ; : branch, ( destination -- ) >r postpone AHEAD here r> dp ! >r postpone THEN r> dp ! ; : copy-method ( nfa -- ) dup name>int @ docol: = IF 2 copy-word name>int >body branch, EXIT THEN dup name>int cell+ @ doPoly = IF 5 copy-word name>int >body 3 cells + branch, EXIT THEN drop ; : copy-methods ( -- ) Current save Last @ name>int >body Current ! \ set definitions to new class 0 LastClass c.last BEGIN @ ?dup WHILE dup REPEAT BEGIN ?dup WHILE copy-method REPEAT ; Forth definitions Class ClassRoot \ Note: ClassRoot's parent field is set to 0 ' ClassRoot >body 'classroot ! \ every class inherits ClassRoot ' ClassRoot >body set-current ( ClassRoot definitions ) : definitions ( -- ) LastClass @ Current ! ; : ' ( -- ) class' ; : Class ( -- ) Class seal-lastclass LastClass c.size @ here 2 cells - ! \ inherits lastclass LastClass @ here cell- ! (static @ IF (static off #static here 3 cells - set EXIT THEN copy-methods ; : Object ( -- ) OopCreate seal-lastclass here LastClass c.size @ allot set-polymorphics DOES> ( -- obj ) [ here (doObj ! ] >object State @ IF postpone Literal THEN ; : Attribute ( -- ) ?unsealed OopCreate seal-lastclass \ seals the class of the newly created attribute CurrentClass c.size @ , LastClass c.size @ CurrentClass c.size +! \ make room for included object DOES> ( obj1 -- obj2 ) [ here (doAttr ! ] >object @ ?dup 0= ?EXIT \ don't do anything when the offset is 0 State @ IF postpone Literal postpone + EXIT THEN \ could be optimized by adding to preceeding Literal + ; Oop definitions : do-proxy ( obj offset -- ) + @ ?dup 0= Abort" un-initialized Proxy" execute ; ClassRoot definitions : Proxy ( -- ) ?unsealed OopCreate CurrentClass c.size @ , \ offset into the object. The cell holds an execution token 1 cells CurrentClass c.size +! DOES> ( obj1 -- obj2 ) [ here (doProxy ! ] >object @ State @ IF postpone Literal postpone do-proxy EXIT THEN \ could be optimized by adding to preceeding Literal do-proxy ; : allot ( u -- ) CurrentClass c.size +! ; : units ( u1 -- u2 ) LastClass c.size @ * ; : addr ( obj -- addr ) Forth-context ; immediate : .. ( -- ) Forth-context ; immediate : size ( -- bytes ) ?exec LastClass c.size @ ; : static ( -- ) (static on ClassContext on ; : words ( -- ) classorder words ; : methods ( -- ) methods ; : order ( -- ) LastClass >r BEGIN r@ @ ?dup WHILE .voc r> c.parent >r REPEAT rdrop ." " Current @ .voc ; : see ( -- ) classorder see ; \ ----------------------------------------------------------------------------- \ bind is used to initialize/modify the xt of a Proxy or Polymorphic method \ of a specific object. \ ----------------------------------------------------------------------------- Oop definitions : do-bind ( xt obj index -- ) + ! ; ClassRoot definitions : bind ( xt obj -- ) \ bind does not type check, so xt can be anything class' doProxy == IF >body cell+ ELSE doPoly == 0= Abort" no proxy nor method" >body THEN @ State @ IF postpone Literal postpone do-bind EXIT THEN do-bind ; immediate \ ----------------------------------------------------------------------------- \ intelligent : and ; to take care of re-defining methods and messages. \ When re-defining a method, the binding branch will be modified later by ; \ ----------------------------------------------------------------------------- Oop definitions 0 Constant #colon \ type digits to 1 Constant #method \ control ;'s behaviour : redefine-method ( addr len nfa -- sys # ) nip nip dup last ! \ remember nfa see: oop-compiler name>int ?polymorphic >body \ addr of branch to be rewritten align :cfa, here \ addr of definitions body defstart ] :-hook #method \ type digit ; : redefine-polymorphic? ( addr len nfa -- addr len ff | sys # tf ) name>int dopoly == IF >r ?unsealed \ xt of a polymorphic of the same name in a subclass header, dodoes: , dopoly , r> >body @ , \ lay down identical index as in the subclass :cfa, \ a :-definition following the index field is the current method postpone AHEAD :cfa, postpone THEN \ this branch binds the latest re-definition defstart ] :-hook #colon true EXIT \ compile the body of the :-definition THEN drop false ; : new-method ( addr len -- sys # ) \ Current c.attr @ #static and \ IF cr ." Method " 2dup type ." in static class." THEN header, (:noname) \ a new, non-polymorphic method postpone AHEAD :cfa, postpone THEN #colon \ this :-cf is needed to make embedding previous definition possible ; : forth-colon? ( -- f ) Current @ cell- @ doClass - \ not a class definition Current @ [ ' Classroot >body ] Literal = or \ perhaps a ClassRoot definition ; Forth definitions : : ( -- sys # ) forth-colon? IF : #colon EXIT THEN \ forth style colon definition name 2dup Current @ (search-wordlist) \ search current class ?dup IF redefine-method EXIT THEN 2dup CurrentClass search-methods \ search subclasses ?dup IF redefine-polymorphic? ?EXIT THEN new-method ; : ; ( sys # -- ) #colon case? IF postpone ; EXIT THEN #method case? IF postpone ; \ create a branch from the previously here >r \ defined non-polymorphic method >r dp ! postpone AHEAD \ to its new definition r> dp ! postpone THEN r> dp ! EXIT THEN Abort" unstructured!" [ drop ] ; immediate \ this ";" for the last time does not use a type digit : Does> ( # -- # ) >r postpone Does> r> ; immediate : :noname ( -- # ) :noname #colon ; Only Forth also definitions