--- gforth/oof.fs 1997/03/31 22:14:39 1.9 +++ gforth/oof.fs 2002/09/14 08:20:19 1.16 @@ -1,44 +1,48 @@ + \ oof.fs Object Oriented FORTH -\ This file is (c) 1996 by Bernd Paysan -\ e-mail: paysan@informatik.tu-muenchen.de +\ This file is (c) 1996,2000 by Bernd Paysan +\ e-mail: bernd.paysan@gmx.de \ \ Please copy and share this program, modify it for your system \ and improve it as you like. But don't remove this notice. \ \ Thank you. \ -\ The program uses the following words -\ from CORE : -\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF -\ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop -\ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and -\ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1- -\ rshift > / ' move UNTIL or count -\ from CORE-EXT : -\ nip tuck true ?DO compile, false Value erase pick :noname 0<> -\ from BLOCK-EXT : -\ \ -\ from EXCEPTION : -\ throw -\ from EXCEPTION-EXT : -\ abort" -\ from FILE : -\ ( S" -\ from FLOAT : -\ faligned -\ from LOCAL : -\ TO -\ from MEMORY : -\ allocate free -\ from SEARCH : -\ find definitions get-order set-order get-current wordlist set-current -\ search-wordlist -\ from SEARCH-EXT : -\ also Forth previous -\ from STRING : -\ /string compare -\ from TOOLS-EXT : -\ [IF] [THEN] [ELSE] state + +\ The program uses the following words +\ from CORE : +\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ +\ IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ +\ Literal drop align here aligned DOES> execute ['] 2@ recurse swap +\ 1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop +\ BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count +\ from CORE-EXT : +\ nip false Value tuck true ?DO compile, erase pick :noname 0<> +\ from BLOCK-EXT : +\ \ +\ from EXCEPTION : +\ throw +\ from EXCEPTION-EXT : +\ abort" +\ from FILE : +\ ( S" +\ from FLOAT : +\ faligned +\ from LOCAL : +\ TO +\ from MEMORY : +\ allocate free +\ from SEARCH : +\ find definitions get-order set-order get-current wordlist +\ set-current search-wordlist +\ from SEARCH-EXT : +\ also Forth previous +\ from STRING : +\ /string compare +\ from TOOLS-EXT : +\ [IF] [THEN] [ELSE] state +\ from non-ANS : +\ cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G \ Loadscreen 27dec95py @@ -51,6 +55,10 @@ define? cell [IF] 1 cells Constant cell [THEN] +define? \G [IF] +: \G postpone \ ; immediate +[THEN] + define? ?EXIT [IF] : ?EXIT postpone IF postpone EXIT postpone THEN ; immediate [THEN] @@ -126,18 +134,20 @@ Objects definitions : defer? ( addr -- flag ) >body cell+ @ #defer = ; +false Value oset? + : o+, ( addr offset -- ) postpone Literal postpone ^ postpone + - postpone >o drop ; + oset? IF postpone op! ELSE postpone >o THEN drop ; : o*, ( addr offset -- ) postpone Literal postpone * postpone Literal postpone + - postpone >o ; + oset? IF postpone op! ELSE postpone >o THEN ; : ^+@ ( offset -- addr ) ^ + @ ; : o+@, ( addr offset -- ) - postpone Literal postpone ^+@ postpone >o drop ; + postpone Literal postpone ^+@ oset? IF postpone op! ELSE postpone >o THEN drop ; : ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ; : o+@*, ( addr offset -- ) - postpone Literal postpone ^*@ postpone >o drop ; + postpone Literal postpone ^*@ oset? IF postpone op! ELSE postpone >o THEN drop ; \ variables / memory allocation 30oct94py @@ -171,16 +181,26 @@ define? faligned 0= [IF] types definitions -: static ( -- ) mallot Create , #static , - DOES> @ o@ + ; -: method ( -- ) mallot Create , #method , - DOES> @ o@ + @ execute ; -: early ( -- ) Create ['] crash , #early , - DOES> @ execute ; -: var ( size -- ) vallot Create , #var , - DOES> @ ^ + ; -: defer ( -- ) valign cell vallot Create , #defer , - DOES> @ ^ + @ execute ; +: static ( -- ) \ oof- oof + \G Create a class-wide cell-sized variable. + mallot Create , #static , +DOES> @ o@ + ; +: method ( -- ) \ oof- oof + \G Create a method selector. + mallot Create , #method , +DOES> @ o@ + @ execute ; +: early ( -- ) \ oof- oof + \G Create a method selector for early binding. + Create ['] crash , #early , +DOES> @ execute ; +: var ( size -- ) \ oof- oof + \G Create an instance variable + vallot Create , #var , +DOES> @ ^ + ; +: defer ( -- ) \ oof- oof + \G Create an instance defer + valign cell vallot Create , #defer , +DOES> @ ^ + @ execute ; \ dealing with threads 29oct94py @@ -216,16 +236,21 @@ Objects definitions r> drop-order ; false Value method? -false Value oset? : method, ( object early? -- ) true to method? swap >o >r bl word findo 0< state @ and IF r> o, ELSE r> drop execute THEN o> false to method? ; +: cmethod, ( object early? -- ) + state @ dup >r + 0= IF postpone ] THEN + method, + r> 0= IF postpone [ THEN ; + : early, ( object -- ) true to oset? true method, - state @ IF postpone o> THEN false to oset? ; + state @ oset? and IF postpone o> THEN false to oset? ; : late, ( object -- ) true to oset? false method, - state @ IF postpone o> THEN false to oset? ; + state @ oset? and IF postpone o> THEN false to oset? ; \ new, 29oct94py @@ -306,10 +331,11 @@ Objects definitions \ instance creation 29mar94py : instance, ( o -- ) alloc @ >r static new, r> alloc ! drop - DOES> state @ IF dup postpone Literal postpone >o THEN early, ; + DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early, +; : ptr, ( o -- ) 0 , , DOES> state @ - IF dup postpone Literal postpone @ postpone >o cell+ + IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+ ELSE @ THEN late, ; : array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop @@ -328,11 +354,12 @@ Variable ob-interface get-order wordlist tuck classlist ! 1+ set-order also types classlist @ set-current ; -: (class ( parent -- ) +: (class-does> DOES> false method, ; + +: (class ( parent -- ) (class-does> here lastob ! true decl ! 0 ob-interface ! 0 , dup voc! dup lastparent ! - dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! - DOES> false method, ; + dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! ; : (is ( addr -- ) bl word findo drop dup defer? abort" not deferred!" @@ -426,21 +453,32 @@ Variable last-interface 0 last-interfac types definitions -: how: ( -- ) decl @ 0= abort" not twice!" 0 decl ! +: how: ( -- ) \ oof- oof how-to +\G End declaration, start implementation + decl @ 0= abort" not twice!" 0 decl ! align interface, lastob! thread, parent, var, 'link, 0 , cells, interfaces, dup IF dup :method# + @ >r :init + swap r> :init /string move ELSE 2drop THEN ; -: class; ( -- ) decl @ IF how: THEN 0 'link ! - voc# @ drop-order old-current @ set-current ; +: class; ( -- ) \ oof- oof end-class +\G End class declaration or implementation + decl @ IF how: THEN 0 'link ! + voc# @ drop-order old-current @ set-current ; + +: ptr ( -- ) \ oof- oof + \G Create an instance pointer + Create immediate lastob @ here lastob ! instptr, ; +: asptr ( class -- ) \ oof- oof + \G Create an alias to an instance pointer, cast to another class. + cell+ @ Create immediate + lastob @ here lastob ! , , instptr> ; -: ptr ( -- ) Create immediate lastob @ here lastob ! instptr, ; -: asptr ( addr -- ) cell+ @ Create immediate - lastob @ here lastob ! , , instptr> ; +: Fpostpone postpone postpone ; immediate -: : ( -- ) decl @ abort" HOW: missing! " +: : ( -- ) \ oof- oof colon + decl @ abort" HOW: missing! " bl word findo 0= abort" not found" dup exec? over early? or over >body cell+ @ 0< or 0= abort" not a method" @@ -448,7 +486,8 @@ types definitions Forth -: ; ( xt colon-sys -- ) postpone ; +: ; ( xt colon-sys -- ) \ oof- oof + postpone ; m-name @ dup >body swap exec? IF @ o@ + ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN @@ -468,87 +507,102 @@ Create object immediate 0 (class \ do static size \ number of variables (bytes) static newlink \ ptr to allocated space static ilist \ interface list - method init - method dispose + method init ( ... -- ) \ object- oof + method dispose ( -- ) \ object- oof - early class - early new immediate - early new[] immediate - early : - early ptr - early asptr - early [] - early :: immediate - early class? - early super immediate - early self - early bind immediate - early is immediate - early bound - early link immediate - early ' immediate - early send immediate - early with immediate - early endwith immediate + early class ( "name" -- ) \ object- oof + early new ( -- o ) \ object- oof + immediate + early new[] ( n -- o ) \ object- oof new-array + immediate + early : ( "name" -- ) \ object- oof define + early ptr ( "name" -- ) \ object- oof + early asptr ( o "name" -- ) \ object- oof + early [] ( n "name" -- ) \ object- oof array + early :: ( "name" -- ) \ object- oof scope + immediate + early class? ( o -- flag ) \ object- oof class-query + early super ( "name" -- ) \ object- oof + immediate + early self ( -- o ) \ object- oof + early bind ( o "name" -- ) \ object- oof + immediate + early bound ( class addr "name" -- ) \ object- oof + early link ( "name" -- class addr ) \ object- oof + immediate + early is ( xt "name" -- ) \ object- oof + immediate + early send ( xt -- ) \ object- oof + immediate + early with ( o -- ) \ object- oof + immediate + early endwith ( -- ) \ object- oof + immediate + early ' ( "name" -- xt ) \ object- oof tick + immediate + early postpone ( "name" -- ) \ object- oof + immediate + early definitions ( -- ) \ object- oof \ base object class implementation part 23mar95py -how: 0 parento ! - 0 childo ! - 0 nexto ! - : class ( -- ) Create immediate 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 declaration!" - Create immediate o@ , cell+ @ , instptr> ; - : [] ( n -- ) Create immediate o@ - decl @ IF instarray, ELSE array, THEN ; - : new ( -- o ) o@ state @ - IF postpone Literal postpone new, ELSE new, THEN ; - : new[] ( n -- o ) o@ state @ - IF postpone Literal postpone new[], ELSE new[], THEN ; - : dispose ( -- ) ^ size @ dispose, ; - : bind ( addr -- ) (bind ; - : bound ( o1 o2 addr2 -- ) (bound ; - : link ( -- o addr ) (link ; - : class? ( class -- flag ) ^ parent? nip 0<> ; - : :: ( -- ) - state @ IF ^ true method, ELSE inherit THEN ; - : super ( -- ) parento true method, ; - : is ( cfa -- ) (is ; - : self ( -- obj ) ^ ; - : init ( -- ) ; - - : ' ( -- xt ) bl word findo 0= abort" not found!" - state @ IF postpone Literal THEN ; - : send ( xt -- ) execute ; - - : with ( -- ) - state @ oset? 0= and IF postpone >o THEN - o@ add-order voc# ! false to oset? - r> drop state @ - IF o> - ELSE oset? IF ^ THEN o> postpone >o - THEN - r> drop r> drop ; - : endwith postpone o> - voc# @ drop-order ; +how: +0 parento ! +0 childo ! +0 nexto ! + : class ( -- ) Create immediate 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 declaration!" + Create immediate o@ , cell+ @ , instptr> ; + : [] ( n -- ) Create immediate o@ + decl @ IF instarray, ELSE array, THEN ; + : new ( -- o ) o@ state @ + IF Fpostpone Literal Fpostpone new, ELSE new, THEN ; + : new[] ( n -- o ) o@ state @ + IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ; + : dispose ( -- ) ^ size @ dispose, ; + : bind ( addr -- ) (bind ; + : bound ( o1 o2 addr2 -- ) (bound ; + : link ( -- o addr ) (link ; + : class? ( class -- flag ) ^ parent? nip 0<> ; + : :: ( -- ) + state @ IF ^ true method, ELSE inherit THEN ; + : super ( -- ) parento true method, ; + : is ( cfa -- ) (is ; + : self ( -- obj ) ^ ; + : init ( -- ) ; + + : ' ( -- xt ) bl word findo 0= abort" not found!" + state @ IF Fpostpone Literal THEN ; + : send ( xt -- ) execute ; + : postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ; + + : with ( -- ) + state @ oset? 0= and IF Fpostpone >o THEN + o@ add-order voc# ! false to oset? ; + : endwith Fpostpone o> voc# @ drop-order ; + + : definitions + o@ add-order 1+ voc# ! also types o@ lastob ! + false to oset? get-current old-current ! + thread @ set-current ; class; \ object \ interface 01sep96py Objects definitions -: implement ( interface -- ) +: implement ( interface -- ) \ oof-interface- oof align here over , ob-interface @ , ob-interface ! :ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ; -: inter-method, ( interface -- ) - :ilist + @ bl word count 2dup s" '" compare - 0= dup >r IF 2drop bl word count THEN +: inter-method, ( interface -- ) \ oof-interface- oof + :ilist + @ bl word count 2dup s" '" str= + dup >r IF 2drop bl word count THEN rot search-wordlist dup 0= abort" Not an interface method!" r> IF drop state @ IF postpone Literal THEN EXIT THEN @@ -560,19 +614,23 @@ Variable inter# Vocabulary interfaces interfaces definitions -: method ( -- ) mallot Create , inter# @ , - DOES> 2@ swap o@ + @ + @ execute ; +: method ( -- ) \ oof-interface- oof + mallot Create , inter# @ , +DOES> 2@ swap o@ + @ + @ execute ; -: how: ( -- ) align +: how: ( -- ) \ oof-interface- oof + align here lastif @ ! 0 decl ! here last-interface @ , last-interface ! inter-list @ , methods @ , inter# @ , methods @ :inum cell+ ?DO ['] crash , LOOP ; -: interface; ( -- ) old-current @ set-current +: interface; ( -- ) \ oof-interface- oof + old-current @ set-current previous previous ; -: : ( -- ) decl @ abort" HOW: missing! " +: : ( -- ) \ oof-interface- oof colon + decl @ abort" HOW: missing! " bl word count lastif @ @ :ilist + @ search-wordlist 0= abort" not found" dup >body cell+ @ 0< 0= abort" not a method" @@ -580,50 +638,23 @@ Vocabulary interfaces interfaces defini Forth -: ; ( xt colon-sys -- ) postpone ; +: ; ( xt colon-sys -- ) \ oof-interface- oof + postpone ; m-name @ >body @ lastif @ @ + ! ; immediate Forth definitions -: interface ( -- ) - Create here lastif ! 0 , get-current old-current ! +: interface-does> + DOES> @ decl @ IF implement ELSE inter-method, THEN ; +: interface ( -- ) \ oof-interface- oof + Create interface-does> + here lastif ! 0 , get-current old-current ! last-interface @ dup IF :inum @ THEN 1 cells - inter# ! get-order wordlist dup inter-list ! dup set-current swap 1+ set-order true decl ! - 0 vars ! :inum cell+ methods ! also interfaces - DOES> @ decl @ IF implement ELSE inter-method, THEN ; + 0 vars ! :inum cell+ methods ! also interfaces ; previous previous -\ The program uses the following words -\ from CORE : -\ decimal : bl word 0= ; cells Constant POSTPONE IF EXIT THEN immediate -\ Create , DOES> @ >r r> swap + and Variable ! allot ELSE +! dup * >body -\ cell+ = Literal drop align here aligned execute ['] 2@ recurse 1+ over -\ LOOP ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1- -\ rshift > / ' move UNTIL or count -\ from CORE-EXT : -\ nip tuck true ?DO compile, false Value erase pick :noname 0<> -\ from BLOCK-EXT : -\ \ -\ from EXCEPTION : -\ throw -\ from EXCEPTION-EXT : -\ abort" -\ from FILE : -\ ( S" -\ from FLOAT : -\ faligned -\ from LOCAL : -\ TO -\ from MEMORY : -\ allocate free -\ from SEARCH : -\ find wordlist get-order set-order definitions get-current set-current search-wordlist -\ from SEARCH-EXT : -\ also Forth previous -\ from STRING : -\ /string compare -\ from TOOLS-EXT : -\ state [IF] [THEN] +