--- gforth/objects.fs 1999/07/05 19:56:01 1.15 +++ gforth/objects.fs 2000/09/23 15:06:01 1.19 @@ -1,6 +1,6 @@ \ yet another Forth objects extension -\ written by Anton Ertl 1996-1999 +\ written by Anton Ertl 1996-2000 \ public domain; NO WARRANTY \ This (in combination with compat/struct.fs) is in ANS Forth (with an @@ -259,15 +259,17 @@ variable public-wordlist then r> class-wordlist @ swap 1+ ; -: push-order ( class -- ) \ objects- objects +: class>order ( class -- ) \ objects- objects \g Add @var{class}'s wordlists to the head of the search-order. >r get-order r> add-class-order set-order ; +: push-order class>order ; \ old name + : methods ( class -- ) \ objects- objects \g Makes @var{class} the current class. This is intended to be \g used for defining methods to override selectors; you cannot \g define new fields or selectors. - dup current-interface ! push-order ; + dup current-interface ! class>order ; : class ( parent-class -- align offset ) \ objects- objects \g Start a new class definition as a child of @@ -291,16 +293,18 @@ variable public-wordlist until drop ; -: drop-order ( class -- ) \ objects- objects +: class-previous ( class -- ) \ objects- objects \g Drop @var{class}'s wordlists from the search order. No \g checking is made whether @var{class}'s wordlists are actually \g on the search order. >r get-order r> remove-class-order set-order ; +: drop-order class-previous ; \ old name + : end-methods ( -- ) \ objects- objects \g Switch back from defining methods of a class to normal mode \g (currently this just restores the old search order). - current-interface @ drop-order ; + current-interface @ class-previous ; : end-class-noname ( align offset -- class ) \ objects- objects \g End a class definition. The resulting class is @var{class}. @@ -359,12 +363,20 @@ variable public-wordlist \ : to-this ( object -- ) \ thisp ! ; -: m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects - \g Start a method definition; @var{object} becomes new @code{this}. - :noname +: enterm ( -- ; run-time: object -- ) + \g method prologue; @var{object} becomes new @code{this}. POSTPONE this POSTPONE >r POSTPONE to-this ; + +: m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects + \g Start a method definition; @var{object} becomes new @code{this}. + :noname enterm ; + +: :m ( "name" -- xt; run-time: object -- ) \ objects- objects + \g Start a named method definition; @var{object} becomes new + \g @code{this}. Has to be ended with @code{;m}. + : enterm ; : exitm ( -- ) \ objects- objects \g @code{exit} from a method; restore old @code{this}. @@ -473,7 +485,7 @@ current-interface 1 cells save-mem curre 0 current-interface @ class-parent ! wordlist current-interface @ class-wordlist ! object% -current-interface @ push-order +current-interface @ class>order ' drop ( object -- ) method construct ( ... object -- ) \ objects- objects @@ -486,6 +498,8 @@ method print ( object -- ) \ objects- ob \g Print the object. The method for the class @var{object} prints \g the address of the object and the address of its class. +selector equal ( object1 object2 -- flag ) + end-class object ( -- class ) \ objects- objects \g the ancestor of all classes.