\ Do not use this file except in compliance with the License. You may \ obtain a copy of the License at http://www.microcore.org/License/ \ Software distributed under the License is distributed on an "AS IS" basis, \ WITHOUT WARRANTY OF ANY KIND, either express or implied. \ See the License for the specific language governing rights and limitations \ under the License. \ \ The Original Code is: OOP.FS \ \ Last change: KS 20.08.2015 15:01:39 \ \ The Initial Developer of the Original Code is Klaus.Schleisiek AT hamburg.de. \ \ Early binding Class mechanisms with inheritance. \ This file defines the basic cross-compiler functionality without creating \ code in the target system. Later on, after starting target compilation, \ OBJECTS.FS has to be loaded to complete the OOP layer. Forth definitions Variable LastClass LastClass off Variable ClassContext ClassContext off \ Current class context \ debugging aid: \ : ??? ." Classcontext: " Classcontext @ ?dup IF body> >name .name EXIT THEN ." none" cr ; : set-class ( class -- ) dup LastClass ! ClassContext ! ; : classorder ( -- ) \ put into normal search order for this :-definition r> context save >r LastClass @ ?dup 0= ABORT" Class context undefined" context ! ; : Method ( -- ) ClassContext off ; Variable (doClass : doClass ( -- xt ) (doClass @ ; Variable (doObj : doObj ( -- xt ) (doObj @ ; Variable (doAttr : doAttr ( -- xt ) (doAttr @ ; Variable 'classroot 'classroot off : Class ( -- ) Vocabulary 0 , 0 , 'classroot @ , \ | search-xt | wordlist | Voclink | ext || attr | size | parent | DOES> ( -- ) [ here (doClass ! ] set-class ; \ ------------------------------------------------------------------------- \ ClassRoot and initial methods \ ------------------------------------------------------------------------- Class ClassRoot ' ClassRoot >body 'classroot ! \ every class inherits ClassRoot ' ClassRoot >body set-current \ ClassRoot definitions : .. ( -- ) Method ; immediate : definitions ( -- ) Method LastClass @ Current ! ; \ ------------------------------------------------------------------------- \ @Class word set \ ------------------------------------------------------------------------- Forth definitions Vocabulary @Class immediate @Class definitions : h' ( -- ) Method classorder ' ; : Context ( -- cpa ) LastClass ; : Current ( -- cpa ) Current @ cell- @ doClass - ABORT" No Class compilation context defined" Current ; : c.last ( cpa -- addr ) @ cell+ ; : c.attr ( cpa -- addr ) @ [ 4 cells ] Literal + ; 1 Constant #sealed \ attribute bit : ?unsealed ( cpa -- ) @Class c.attr @ #sealed and ABORT" Class is sealed" ; : c.size ( cpa -- addr ) @ [ 5 cells ] Literal + ; : c.parent ( cpa -- addr ) @ [ 6 cells ] Literal + ; : Create ( -- ) \ | (create | class wordlist anchor | T Create @Class LastClass @ , ; : >object ( addr -- obj ) dup @ swap cell+ cell+ @ set-class ; : (object ( bytes addr -- ) dup >r @ Constant here Variables @ , Variables ! @Class LastClass dup @ , c.size @ + r> +! \ | Tdp | varlink | class | DOES> ( -- obj ) [ here (doObj ! ] @Class >object comp? IF lit, EXIT THEN dbg? IF >t THEN ; : Object ( bytes -- ) Tdp @Class (object ; : Attribute ( bytes -- ) @Class Current ?unsealed @Class Create Current c.size @ here 3 cells - ! LastClass c.size @ + Current c.size +! \ | offset | Varlink | class | DOES> ( object1 -- object2 ) [ here (doAttr ! ] @Class >object comp? IF ?dup 0= ?EXIT lit, T + H EXIT THEN dbg? IF t> + >t EXIT THEN + ; Forth Root definitions Forth : Self ( -- ) @Class Current @ set-class ; immediate : classes ( -- ) space Voclink BEGIN @ ?dup WHILE dup cell- cell- dup body> cell+ @ doClass = IF ?cr dup @Class .wordname THEN drop REPEAT ; : methods ( -- ) [ Forth ] context save LastClass @ context ! words ; Target definitions Forth ' Class Alias Class ' ClassRoot Alias ClassRoot ' Method Alias Method \ ------------------------------------------------------------------------- \ Class interpreter/compiler \ ------------------------------------------------------------------------- Forth definitions : search-classes ( addr len -- xt | 0 ) LastClass >r BEGIN r@ @ WHILE 2dup r@ @ (search-wordlist) ?dup IF nip nip rdrop EXIT THEN r> @Class c.parent >r REPEAT rdrop 2drop false ; : host-compiler ( addr len -- ) ClassContext @ IF 2dup search-classes ?dup IF nip nip comp? IF name>comp ELSE name>int THEN execute EXIT THEN ELSE 2dup find-name ?dup IF nip nip comp? IF name>comp ELSE name>int THEN execute EXIT THEN THEN 2dup 2>r snumber? 0 case? IF 2r> interpreter-notfound EXIT THEN 2rdrop comp? IF 0> IF swap postpone Literal THEN postpone Literal EXIT THEN drop ; gforth_062 [IF] ' host-compiler 'interpreter ! ' host-compiler 'compiler ! ' host-compiler IS parser [THEN] gforth_070 [IF] : host-compiler1 ( addr len -- xt ) host-compiler ['] noop ; ' host-compiler1 'interpreter ! ' host-compiler1 'compiler ! ' host-compiler1 IS parser1 [THEN] \ ------------------------------------------------------------------------- \ More ClassRoot Definitions \ ------------------------------------------------------------------------- ClassRoot definitions : ' ( -- ) T Method classorder ' H ; : h' ( -- ) Method classorder ' ; : New ( -- ) Method 0 @Class Object ; : :: ( -- ) Method 0 @Class Attribute ; : allot ( u -- ) Method @Class Current c.size +! ; : seal ( -- ) Method @Class Current c.attr dup @ #sealed or swap ! ; : units ( u -- ) Method @Class Context c.size @ * ; : inherit ( -- ) Method @Class Current c.last @ Current c.size @ or ABORT" inherit only once" LastClass c.size @ Current c.size ! LastClass @ Current c.parent ! ; : size ( -- bytes ) Method ?exec LastClass c.size @ ; : addr ( obj -- addr ) Method ; immediate : words ( -- ) Method methods ; : order ( -- ) Method LastClass >r BEGIN r@ @ ?dup WHILE .voc r> @Class c.parent >r REPEAT rdrop ." " H Current @ .voc ; : see ( -- ) Method classorder see ; Forth definitions