\\ *** Object Oriented FORTH *** coded 06,07,21sep91,27jul97py Da mir Dick Pountains OOF zu frueh bindet, habe ich ein eigenesobjektorientiertes FORTH entwickelt, das auch schnelles "late binding" erlaubt und ausserdem einen vernuenftigen Browser ermoeglicht. Es gibt also eine richtige Klassenhierarchie, Wurzelobject ist das Object OBJECT. Ebenso gibt es sowohl statische Objekte (mit Namen), als auch dynamisch allokierte, die mit new erzeugt werden, mit dispose geloescht. Objekte koennen auch als Instanzvariablen fuer andere Objekte verwendet werden. \ Loadscreen 23jun01pyModule Objects \needs 2cell+ ' 8+ | alias 2cell+ \needs loffset Variable loffset Vocabulary types types also 3 cells | constant :var# 4 cells | constant :parent 5 cells | constant :child 6 cells | constant :next 7 cells | constant :iface 8 cells | constant :setup 9 cells | constant :init 0 cells | constant :inext 1 cells | constant :ilist 2 cells | constant :ilen 3 cells | constant :inum 1 $20 +thru objects definitions export: drop dynamic export ^ op! >o o> o@ dispose, static dynamic F link F bind object debugging chunks new, [], interface ; cold: $10 0 DO chunks I cells + off LOOP ; Module; \ object pointer manipulation 01jan98py Code (opush ( -- ) R: OP push Next end-code macro :r :r T&P Code (>o ( addr -- ) R: OP push AX OP mov lods Next end-code macro :r :r T&P restrict Code (o> R: OP pop Next end-code macro :r :r T&P restrict : opush cell loffset +! compile (opush ; immediate restrict : >o cell loffset +! compile (>o ; immediate restrict : o> -cell loffset +! compile (o> ; immediate restrict Code op! ( addr -- ) AX OP mov AX pop Next end-code macro 0 :ax T&P Code o@ AX push OP ) AX mov Next end-code macro :ax 0 T&P Code ^ AX push OP AX mov Next end-code macro :ax 0 T&P \ object pointer calculation 02jan98py| Code #>o ( -- ) R: 0 L# OP mov -4 allot Next end-code macro :r :r T&P | Code o+ ( -- ) R: 0 L# OP add -4 allot Next end-code macro :r :r T&P | Code #o* ( -- ) R: 0 AX *4 I#) OP mov lods Next end-code macro :r :r T&P | Code (var ( -- addr ) AX push 0 OP L) AX lea Next end-code macro :ax :ovar T&P Code r:drop R: DX pop Next end-code macro :r :r T&P | Code o+@ R: 0 OP L) OP mov -4 allot Next end-code macro :r :r T&P | Code #@>o ( -- ) R: 0 #) OP mov -4 allot Next end-code macro :r :r T&P | Code u@>o ( -- ) R: 0 UP L) OP mov -4 allot Next end-code macro :r :r T&P \ ^val ^exec ^var ^defer 02jan98py | : ^val ( -- addr ) o@ 00 + ; macro Code ^exec ( -- ) R: OP ) DX mov 0 DX L) call Next end-code macro :r :r T&P also Assembler also | : ^var ( offset -- ) [F] dup $80 u< >r Code [A] AX push OP D) AX lea Next end-code [F] macro :ax r> IF :svar ELSE :ovar THEN compile T&P ; | : ^defer ( offset -- ) Code [A] R: OP D) call Next end-code [F] macro :r :r compile T&P ; toss toss | : var, ( offset -- ) postpone (var here 6 - ! ; | Code o+@* ( i -- ) R: 0 OP L) OP mov OP AX *4 I) OP mov lods Next end-code macro :r :r T&P \ Coding 01jan98py : F ( "word" -- ) also Forth name parser previous ; immediate | : exec? ( addr -- addr flag ) dup $4 ['] ^exec -text 0= ; | : defer? ( addr -- flag ) w@ $FF57 over = swap $FF97 = or ; | false Value oset? | : opush, oset? 0= IF compile opush THEN ; | : o+, ( offset -- ) opush, compile o+ , ; | : #o*, ( addr -- ) opush, compile #o* here 5 - A! ; | : o+@, ( offset -- ) opush, compile o+@ , ; | : o+@*, ( offset -- ) opush, compile o+@* here $8 - ! ; \ variables / memory allocation 23jun01py | User lastob | User lastparent | User vars | User methods | User decl decl off | User 'setup 'setup off | User ob-interface ob-interface off | User 'link | User voc# | User old-current | : crash true abort" unbound method" ; Forward new[], Forward dispose, Forward new, Forward sub-setup Forward preserve Forward setup-object Defer alloc Defer ^! | : align here negate 3 and 0 ?DO 0 c, LOOP ; | : parent? dup 0= IF drop true EXIT THEN @ BEGIN 2dup = ?EXIT dup WHILE :parent + @ REPEAT ; \ type declaration 23jun01py | : vallot ( size -- offset ) vars @ >r vars +! r> ; | : mallot ( -- offset ) methods @ cell methods +! ; types definitions | : conf: ( cfa offset -- ) : -rot here + >r cfa, compile ; macro mallot r> ! types ; | : vars: ( size cfa -- ) swap vallot swap execute types ; : static ( -- ) ['] ^val $6 conf: ; : method ( -- ) ['] ^exec $4 conf: ; : early ( -- ) ['] crash alias ; : var ( size -- ) ['] ^var vars: ; : defer ( -- ) cell ['] ^defer vars: ; \ dealing with threads 16jul00py | Variable (public | Variable (private | : >public (public @ context ! ; | : >private (private @ context ! ; : public: (public @ set-current ; : private: (private @ set-current ; objects definitions | : (voc! ( parent -- ) dup IF @ THEN here swap voc, context ! definitions ; | : voc! ( parent -- ) current @ old-current ! also dup dup IF cell+ THEN (voc! context @ (private ! also (voc! context @ (public ! also types 3 voc# ! ; | : setvoc ( addr addr -- ) (public ! (private ! ; \ object compiling/executing 23jun01py| : o, ( cfa early? -- ) >r exec? r> and IF exec? IF $4 + @ o@ + @ ELSE $6 + @ o@ + compile ALiteral EXIT THEN THEN cfa, ; | false Value method? forward find-interface | : findo ( string -- cfa n ) 'prehash o@ @ (find 0= IF dup o@ :iface + @ find-interface dup 0= IF drop no.extensions THEN nip THEN found ; | : method, ( object early? -- ) true to method? swap >o >r name findo 0< state @ and IF r> o, ELSE rdrop execute THEN o> false to method? ; | : o>, state @ oset? and IF compile o> THEN false to oset? ; | : early, ( object -- ) true to oset? true method, o>, ; | : late, ( object -- ) true to oset? false method, o>, ; \ bind and relegates 11jul99py | AVariable lastbind :noname true abort" No bindable type" ; lastbind ! | : >bind DOES> 2dup cell+ @ = IF nip cell+ cell+ @ execute ELSE perform THEN ; | : bind: lastcfa @ >r :noname postpone recurse postpone [ drop >bind lastbind @ A, lastcfa @ lastbind ! r> A, here >r 0 A, :noname nip nip lastcfa @ r> ! ; | : (link dup >body swap cfa@ lastbind perform ; | : !, state @ IF postpone ! ELSE ! THEN ; : link ( "ptr" -- addr ) ' (link ; immediate : bind ( o "ptr" -- ) ' (link !, ; immediate \ instance creation 23jun01py 0 | Value ohere | : oallot & ohere +! ; | : instance, ( o -- ) preserve new, drop DOES> state @ IF opush, compile #>o dup A, THEN early, ; | : ptr, ( o -- ) 0 A, A, DOES> state @ IF opush, compile #@>o dup A, cell+ ELSE @ THEN late, ; bind: ?alit, ; | : uptr, ( o -- ) cell uallot dup up@ + off , A, DOES> state @ IF opush, compile u@>o dup @ , cell+ ELSE @ up@ + @ THEN late, ; bind: @ state @ IF postpone (User here 6 - ! ELSE up@ + THEN ; \ instance array creation 03dec04py| : calign 7 + -8 and ; hmacro | : size@ ( objc -- size ) :var# + @ calign ; : [], ( n -- addr addr' ) dup 1+ cells alloc 2dup ! cell+ swap cells over + cell- ; | : new[], ( n o -- addr ) swap [], over >r DO dup >r new, r> swap I A! -cell +LOOP drop r> ; | : array, ( n o -- ) preserve new[], drop DOES> ( n -- ) cell+ state @ IF dup #o*, @ ELSE swap cells + @ THEN late, ; bind: ( n -- ) cell+ state @ IF postpone cells postpone ALiteral postpone + ELSE swap cells + THEN ; | variable class-o \ class creation 23jun01py| : (class ( parent -- ) immediate here lastob ! decl on 0 A, dup voc! dup lastparent ! dup 0= IF ['] noop swap 0 ELSE dup :iface + @ ob-interface ! dup :setup + @ swap 2cell+ 2@ THEN methods ! vars ! 'setup ! DOES> class-o push ^ class-o ! 0 method, class-o @ op! ; | : (is ( xt -- ) name findo drop dup defer? abort" not deferred!" 1+ count $57 = IF c@ ELSE @ THEN state @ IF compile ^ compile Literal compile + compile ! ELSE ^ + ! THEN ; | : goto, ( o -- ) method? IF compile r:drop THEN false method, here 5 - dup c@ $92 case? IF $A2 ELSE $E8 = IF $E9 ELSE drop EXIT THEN THEN swap c! ; | : inherit ( -- ) name findo drop exec? IF $4 + w@ dup o@ + @ swap lastob @ + ! EXIT THEN abort" Not a polymorph method!" ; \ instance variables inside objects 23jun01py| : instvar> ( -- ) DOES> dup 2@ swap state @ IF o+, drop ELSE ^ + nip nip THEN early, ; | : instvar, ( addr -- ) dup >r A, r@ :var# + @ vallot dup >r , instvar> :noname r> o+, r> sub-setup postpone o> 'setup @ compile, postpone ; 'setup ! ; | : instptr> ( -- ) DOES> dup 2@ swap state @ IF o+@, drop ELSE ^ + @ nip nip THEN late, ; bind: cell+ @ state @ IF var, ELSE ^ + THEN ; | : instptr, A, cell vallot , instptr> ; | : instarray, ( addr -- ) A, cell vallot , DOES> dup 2@ swap state @ IF o+@*, drop ELSE ^ + @ nip nip swap cells + @ THEN late, ; bind: cell+ @ state @ IF postpone cells var, postpone @ postpone + ELSE ^ + @ swap cells + THEN ; \ method implementation 16jul00py | Variable last-interface last-interface off | : ob-interface' ( -- addr ) lastob @ :iface + ; | : interface, ( -- ) last-interface @ BEGIN dup WHILE dup A, @ REPEAT drop ; | : inter, ( iface -- iface' ) align here tuck over :inum + @ lastob @ + ! here over :ilen + @ dup 0 ?DO 0 A, cell +LOOP move ; | : inter+ ( iface -- ) :ilist + @ also context ! 1 voc# +! ; | : interfaces, ( -- ) ob-interface' @ BEGIN dup WHILE dup @ inter, over ! 2@ inter+ REPEAT drop ; | : find-interface ( string ifacelist -- nfa / 0 ) swap >r BEGIN dup WHILE 2@ r@ swap :ilist + @ (find 0<> and ?dup UNTIL nip THEN rdrop ; \ method implementation 06apr10pytypes definitions | : align here negate 3 and 0 ?DO bl c, LOOP ; | : lastob! ( -- ) align lastob @ dup BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop dup A, >o rdrop o@ lastob ! ; | : thread, ( -- ) (public @ A, (private @ A, methods @ , vars @ , ; | : thread! ( -- ) (private @ (public @ lastob @ 2! ; | : parent, ( -- o parent ) o@ lastparent @ 2dup dup A, 0 A, :child + dup @ A, ! ; | : cells, ( -- ) methods @ :init ?DO ['] crash A, cell +LOOP ; : ptr ( -- ) Create immediate lastob @ here lastob ! instptr, ; : asptr ( addr -- ) cell+ @ Create immediate lastob @ here lastob ! A, , instptr> ; \ method implementation 06aug10py: how: ( -- ) decl @ invert abort" not twice!" decl off private: align interface, lastob! thread, parent, ob-interface @ A, 'setup @ A, cells, dup 2cell+ @ >r :init + swap r> :init /string move previous interfaces, also types ; : class; ( -- ) decl @ IF how: THEN 'link off voc# @ 0 ?DO previous LOOP old-current @ set-current thread! 0 0 setvoc ; : :ooname ( in -- ) >in ! s" " pad place ^ body> >name count $1F and pad +place s" :" pad +place name count $1F and pad +place pad count $1F umin makeview w, -1 A, here last ! here place here c@ 1+ allot reveal :noname ; \ method implementation 06apr10py: ; ( 0 / -1 -- ) -1 case? IF swap ! 0 THEN compile ; ; immediate restrict : : ( -- ) decl @ abort" HOW: missing! " >in @ >r name 'prehash (public @ (find dup 0= IF drop (private @ (find THEN dup 0= IF drop ob-interface' @ find-interface dup IF name> dup cell+ @ lastob @ + @ swap &10 + @ + r> :ooname drop -1 EXIT THEN 0 THEN IF dup name> exec? IF nip $4 + w@ lastob @ + r> :ooname drop -1 EXIT THEN ['] crash = IF dup last ! (name> r> :ooname drop -1 EXIT THEN true abort" redefinition of early" THEN drop r> >in ! | : ; \ new, 02dec08pytoss Objects definitions also Memory Create chunks here $10 cells dup allot erase | : >chunk ( n -- root n ) 1- -8 and dup 2/ chunks + swap 8 + ; | : Dalloc ( size -- addr ) dup $80 > IF dup NewPtr tuck swap erase EXIT THEN >chunk $200 NewFix ; | : Salloc ( size -- addr ) ( align ) here swap allot ; : dispose, ( addr size -- ) dup $80 > IF drop DisposPtr EXIT THEN >chunk drop DelFix ; : new, ( o -- addr ) dup :var# + @ alloc dup >r setup-object r> ; | : S^! ( class -- ) ^ A! ; | : D^! ( class -- ) ^ ! ; : dynamic ['] Dalloc IS alloc ['] D^! IS ^! ; dynamic : static ['] Salloc IS alloc ['] S^! IS ^! ; toss | : preserve r> & alloc push & ^! push >r static ; \ object 23jun01py Create object 0 (class \ nicht als subclass erzeugen private: static public \ PUBLIC: thread static private \ PRIVATE: thread static method# \ number of methods (bytes) static sizeo \ number of variables (bytes) cell var oblink \ create offset for backlink public: static parento \ pointer to parent static childo \ ptr to first child static nexto \ ptr to next child of parent static ilist \ interface list \ object 23jun01py method setup \ setup must be first method init \ init must be second method dispose early class early new immediate early new[] immediate early : early [] early asptr early ptr early uptr early :: immediate early class? early goto immediate restrict early super immediate restrict \ object 02jan98py early self early bind immediate early link immediate early bind[] immediate early link[] immediate early dispose[] immediate early is immediate early seal early ' immediate early postpone immediate early send early with immediate early endwith immediate early implements align here cell+ lastparent ! \ set self as last parent \ base object class implementation part 13jan97pyhow: parento off childo off nexto off : class ( -- ) Create o@ (class ; : : ( -- ) Create immediate o@ decl @ IF instvar, ELSE instance, THEN ; : ptr ( -- ) Create immediate o@ decl @ IF instptr, ELSE ptr, THEN ; : asptr ( addr -- ) decl @ 0= abort" only in decl.!" Create immediate o@ A, cell+ @ , instptr> ; : [] ( n -- ) Create immediate o@ decl @ IF instarray, ELSE array, THEN ; : new ( -- o ) o@ state @ IF compile ALiteral compile new, ELSE new, THEN ; : new[] ( n -- o ) o@ state @ IF compile ALiteral compile new[], ELSE new[], THEN ; : dispose ( -- ) ^ sizeo @ dispose, ; \ base object class implementation part 11mar00py : ?nofound ( flag -- ) 0= abort" not found!" ; : uptr ( -- ) Create immediate o@ decl @ abort" only outside decl" uptr, ; : :: ( -- ) state @ IF ^ true method, ELSE inherit THEN ; : goto ( -- ) ^ goto, ; : super ( -- ) parento true method, ; : is ( cfa -- ) (is ; : self ( -- obj ) ^ ; macro : init ( -- ) ; : seal ( -- ) private off ; : (') ( -- xt ) name findo ?nofound ; : ' ( -- xt ) (') ?alit, ; : send ( xt -- ) >r ; : class? ( class -- flag ) ^ parent? nip 0<> ; \ base object class implementation part 25oct06py : postpone ( -- ) public 2@ setvoc also >public name find dup >r 0= no.extensions r> 0> IF ^ compile ALiteral compile >o cfa, compile o> ELSE compile (compile A, THEN previous ; : with ( -- ) state @ oset? 0= and IF compile >o THEN also public @ context ! false to oset? ; : endwith state @ IF compile o> THEN previous ; : implements ( -- ) public 2@ setvoc current @ context ! also >public also >private definitions also types o@ lastob ! false to oset? ^ class-o ! ; \ base object class implementation part 23jun01py : link ( -- o ) (') (link ; : bind ( addr -- ) (') (link !, ; : link[] ( -- addr ) (') >body cell+ @ state @ IF var, ELSE ^ + THEN ; : bind[] ( addr -- ) (') >body cell+ @ state @ IF var, !, ELSE ^ + ! THEN ; : del[] ( addr -- ) @ cell- dup @ 1+ cells 2dup cell /string bounds ?DO I @ >o ^ IF dispose THEN o> cell +LOOP dispose, ; : dispose[] ( addr -- ) (') >body cell+ @ state @ IF var, postpone del[] ELSE ^ + del[] THEN ; class; \ object \ forget classes 23mar95py| : remove? ( dic symb addr -- dic symb addr flag ) dup heap? IF 2dup u> ELSE dup 3 pick relinfo within THEN ; | : cell-@ dup IF cell- @ THEN ; | : (remove-classes ( dict sym class -- dict sym ) recursive BEGIN >o o@ remove o@ cell+ remove object childo @ cell-@ dup IF >r 2dup r> (remove-classes 2drop ELSE drop THEN object nexto @ cell-@ >r object childo BEGIN dup >r @ cell-@ dup WHILE remove? IF >o object nexto @ o> r@ ! r> ELSE rdrop >o object nexto o> THEN REPEAT rdrop drop r> o> dup 0= UNTIL drop ; : remove-classes ( dict sym -- dict sym ) defers custom-remove & object (remove-classes ; ' remove-classes IS custom-remove \ debugging 26sep99py tools also object class debugging private: early voc- public: early words early m' early see early view early trace' early debug early view! how: : voc+ public 2@ setvoc also types also >public also >private ; : voc- toss toss toss 0 0 setvoc ; : words voc+ cr ." Public: " >public F words cr ." Private: " >private F words voc- ; : m' voc+ F ' voc- exec? IF $4 + w@ o@ + @ THEN ; : see m' voc+ ((see voc- ; \ debugging 26sep99py : trace' m' voc+ also Tools dup >debug execute end-trace toss voc- ; : debug m' voc+ also Tools >debug ; | AVariable view-name : view ( -- ) voc+ >in @ m' swap >in ! dup >name dup IF dup c@ $20 and IF drop ELSE nip 2- THEN ELSE drop THEN 4- w@ name count voc- view-name perform ; : view! ( addr -- ) view-name ! ; class; toss objects \ interfaces 23jun01pyObjects definitions | : setup-object ( class object -- ) >o ^! object setup object init o> ; | : sub-setup ( c -- ) postpone Literal postpone ^! object postpone setup object postpone init ; | : implement ( interface -- ) \ oof-interface- oof align here ob-interface @ swap ob-interface ! swap A, A, ; | : inter-method, ( interface -- ) \ oof-interface- oof :ilist + @ bl word count 2dup s" '" compare 0= dup >r IF 2drop bl word count THEN rot search-wordlist dup 0= abort" Not an interface method!" r> IF drop state @ IF postpone ALiteral THEN EXIT THEN 0< state @ and IF compile, ELSE execute THEN ; \ interfaces 16jul00py | Variable inter-list | Variable lastif | Variable inter# | Vocabulary interfaces interfaces definitions Code ^iexec ( -- ) R: OP ) DX mov 0 DX L) DX mov 0 DX L) call Next end-code macro :r :r T&P : method : postpone ^iexec mallot here 4- ! inter# @ here &10 - ! postpone ; macro ; \ : method ( -- ) \ oof-interface- oof \ mallot Create , inter# @ , \ DOES> 2@ swap o@ + @ + @ execute ; \ interfaces 16jul00py : how: ( -- ) \ oof-interface- oof align here lastif @ ! decl off here last-interface @ A, last-interface ! inter-list @ A, methods @ , inter# @ , methods @ :inum cell+ ?DO ['] crash A, LOOP ; : interface; ( -- ) \ oof-interface- oof decl @ IF how: THEN old-current @ set-current previous previous ; \ interfaces 16jul00py : : ( -- ) \ oof-interface- oof colon decl @ abort" HOW: missing! " bl word count lastif @ @ :ilist + @ search-wordlist 0= abort" not found" dup 2@ [ ' ^iexec @ ] Literal <> swap 0>= or abort" not a method" &10 + @ lastif @ @ + :noname drop -1 ; types ' ; alias ; immediate objects definitions : interface ( -- ) \ oof-interface- oof Create here lastif ! 0 A, get-current old-current ! last-interface @ dup IF :inum + @ THEN cell- inter# ! wordlist dup inter-list ! also context ! definitions decl on vars off :inum cell+ methods ! also interfaces DOES> @ decl @ IF implement ELSE inter-method, THEN ; \ Beispiel: Array 06may97py memory also debugging class array private: cell var addr cell var count public: method @ method ! method . method # how: : init dup count F ! cells addr Handle! ; : @ cells addr F @ + F @ ; : ! cells addr F @ + F ! ; : # count F @ ; : . # 0 ?DO I @ F . ?cr LOOP ; : dispose addr HandleOff super dispose ; class; 10 array : array1 10 20 8 2 4 array [] array2 toss Forth --> \ Beispiel: Boxen zeichnen 06may97py: >xyxy ( xy wh -- xy xy ) 2 pick + 1- >r 2 pick + 1- r> ; : >xywh ( xy xy -- xy wh ) 2 pick - 1+ >r 2 pick - 1+ r> ; : pmax rot max -rot max swap ; : pmin rot min -rot min swap ; : rc_inter ( border rec -- rec flag ) 2swap >r >r pmin 2swap r> r> pmax 2swap 2over 2over rot < -rot > or invert ; debugging class box private: 8 var coord public: method ! method @ method draw \ method get how: : ! 3 FOR coord I 2* + w! NEXT ; : @ 4 0 DO coord I 2* + w@ LOOP ; : draw color push $24 color F ! at? @ 0 ?DO >r 2dup swap at r@ 0 ?DO $DB emit LOOP 1+ r> LOOP drop 2drop at ; class; --> \ Beispiel: Boxen zeichnen 02may93pybox class *box how: : draw color push $42 color F ! at? @ 0 ?DO >r 2dup swap at r@ 0 ?DO '* emit LOOP 1+ r> LOOP drop 2drop at ; class; box class 2box private: early @@ public: cell var flag *box : box1 *box : box2 method - method + how: : @@ box1 @ >xyxy box2 @ >xyxy ; : - @@ rc_inter flag F ! >xywh ! ; : + @@ >r >r >r >r 2swap r> r> pmin 2swap r> r> pmax >xywh ! flag on ; : draw box1 draw box2 draw flag F @ IF super draw THEN ; class; box : box1 *box : box2 5 box [] boxes 2box : box3 \ Formale Syntax 01may93py::= CLASS