\ 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: OBJECTS.FS \ \ Last change: KS 01.07.2009 14:55:32 \ \ The Initial Developer of the Original Code is Klaus.Schleisiek AT hamburg.de. \ \ To use this code, OOP.FS must have been loaded before. \ Definitions in this file will create code in the target system. \ \ **************************************************************** \ Reference \ **************************************************************** Target definitions : @reference ( addr -- ) @ ?dup ?EXIT #unassigned_reference message ; Host Variable (doRef : doRef ( -- xt ) (doRef @ ; @Class definitions : Reference ( -- ) @Class Current ?unsealed @Class Create Current c.size H @ here 3 cells - ! @Class 1 Current c.size +! \ | Offset | Varlink | class | DOES> ( object1 -- object2 ) [ here (doRef ! ] @Class >object comp? IF ?dup IF lit, T + H THEN [ T h' @reference H ] Literal execute EXIT THEN ?dbg t> + t_@ ?dup 0= ABORT" unassigned Reference" >t ; ClassRoot definitions : IS ( obj1 -- ) \ Syntax: becomes LastClass @ >r \ class of object to be assigned H ' execute \ object containing reference BEGIN @class h' dup cell+ @ doAttr = WHILE execute REPEAT dup cell+ @ doRef - ABORT" not a reference" >body dup cell+ cell+ @ r> - ABORT" reference class mismatch" Method @ comp? IF ?dup IF lit, T + H THEN T ! H EXIT THEN ?dbg t> + t> swap t_! ; immediate \ **************************************************************** \ Array \ **************************************************************** \ \ In jeder Instanz eines Array werden folgende Parameter abgelegt, \ die zur Laufzeit ausgewertet werden: \ \ | pointer | total-size | Dimensions | dim_N-1 | ... | dim_1 | element-size | \ \ Zur Laufzeit wird diese Struktur mit folgender Routine abgearbeitet: Target definitions : indexed ( dim_1 .. dim_N addr -- element-addr ) ld swap >r r@ 0= IF #unassigned_array message THEN 1 + ld swap >r ( total-size ) 1 + ld swap ( dimensions ) 1- ?FOR 1 + ld >r * + r> NEXT 1 + @ * r> over u< IF #array_overflow message THEN r> + ; Host @Class definitions : Array ( dim_1 .. dim_N dimensions -- ) @Class Create dbg? IF t> THEN dup 0= ABORT" array dimension must be greater zero" dup 4 + Tdp +! dbg? IF dup , 0 ?DO t> , LOOP ELSE dup , 0 ?DO , LOOP THEN \ | Tdp | varlink | class | Dimensions | dim_N | ... | dim_1 | DOES> ( -- obj ) @Class >object comp? IF lit, [ T h' indexed H ] Literal execute EXIT THEN ?dbg >t [t'] indexed t_execute ; T definitions Forth \ Diese Struktur wird in der Boot-Routine mit folgender Syntax initialisiert: \ init-array' : array-init' ( -- ) ?comp h' >body >r r@ 2 cells + @Class c.size H @ dup lit, ( element-size ) r@ 3 cells + @ tuck ( dimensions size i ) BEGIN 1- ?dup WHILE dup 4 + cells r@ + @ dup lit, ( dimensions size i' dim_i ) rot * swap ( dimensions size' i' ) REPEAT ( dimensions size' ) over lit, ( dimensions size' ) r@ 4 cells + @ * 1- lit, ( dimensions ) r> @ lit, 2 + 0 ?DO 1 lit, T + st H LOOP T drop H ; ClassRoot definitions Forth : [] ( -- ) Method @Class Reference ; : Array ( dim_n .. dim_1 N -- ) Method @Class Array ; \ **************************************************************** \ Basic Objects: Cell and Buffer \ **************************************************************** Target definitions Class Cell \ **************************************************** Cell definitions 1 Self allot Self seal M: @ ( obj -- n ) @ ; M: ! ( n obj -- ) ! ; M: +! ( n obj -- ) +! ; M: on ( obj -- ) on ; M: off ( obj -- ) off ; Host: ? ( obj -- ) Method ?dbg t> t_@ dup 0< IF dup . THEN u. ; Target definitions have here [IF] [ELSE] : here ( -- addr ) Dp @ ; : allot ( n -- ) Dp +! ; [THEN] Class Buffer \ **************************************************** Buffer definitions Cell :: Ptr Cell :: Len Self seal M: size ( obj -- +n ) Self Len addr @ ; M: addr ( obj -- buf.addr ) @ ?dup ?EXIT #uninitialized_buffer message ; M: allot ( +n obj -- ) ld swap IF Self Len addr @ u> IF #buffer_too_small message THEN EXIT THEN here over ! under Self Len addr ! allot ; M: update ( addr +n obj -- ) 1 + st 1 - ! ; M: reset ( obj -- ) >r 0 0 r> Self update ; Host: ? ( obj -- ) Method ?dbg t> dup t_@ ." addr " u. 1+ t_@ ." length " u. ; Target definitions \\ : type ( addr +n -- ) ?FOR dup @ . 1+ NEXT drop ; class String \ **************************************************** String definitions Buffer :: Puffer Self seal M: size ( obj -- +n ) Self Puffer size 1- ; M: ?size ( +n obj -- +n | buflength ) Self size 2dup > IF #string_overflow message THEN umin ; M: @ ( obj -- c-addr +n ) Self Puffer @ count ; M: chars ( obj -- +n ) Self @ nip ; M: ! ( c-addr +n obj -- ) >r r@ Self ?size r> Self Puffer @ place ; M: ? ( obj -- ) Self @ type ; M: init ( +n obj -- ) >r &255 umin 1+ r@ Self Puffer allot r> Self Puffer @ off ; M: +! ( c-addr +n obj -- ) >r r@ Self chars 2dup + r@ Self ?size ( addr +n chars newsize ) dup >r swap - umin ( addr +n' ) r> r@ Self @ + ( addr +n' newsize addr+ ) swap r> Self Puffer @ ! \ set new length ( addr +n' addr+ ) swap move \ append string ; Target definitions