| then |
then |
| r> class-wordlist @ swap 1+ ; |
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. |
\g Add @var{class}'s wordlists to the head of the search-order. |
| >r get-order r> add-class-order set-order ; |
>r get-order r> add-class-order set-order ; |
| |
|
| |
: push-order class>order ; \ old name |
| |
|
| : methods ( class -- ) \ objects- objects |
: methods ( class -- ) \ objects- objects |
| \g Makes @var{class} the current class. This is intended to be |
\g Makes @var{class} the current class. This is intended to be |
| \g used for defining methods to override selectors; you cannot |
\g used for defining methods to override selectors; you cannot |
| \g define new fields or selectors. |
\g define new fields or selectors. |
| dup current-interface ! push-order ; |
dup current-interface ! class>order ; |
| |
|
| : class ( parent-class -- align offset ) \ objects- objects |
: class ( parent-class -- align offset ) \ objects- objects |
| \g Start a new class definition as a child of |
\g Start a new class definition as a child of |
| until |
until |
| drop ; |
drop ; |
| |
|
| : drop-order ( class -- ) \ objects- objects |
: class-previous ( class -- ) \ objects- objects |
| \g Drop @var{class}'s wordlists from the search order. No |
\g Drop @var{class}'s wordlists from the search order. No |
| \g checking is made whether @var{class}'s wordlists are actually |
\g checking is made whether @var{class}'s wordlists are actually |
| \g on the search order. |
\g on the search order. |
| >r get-order r> remove-class-order set-order ; |
>r get-order r> remove-class-order set-order ; |
| |
|
| |
: drop-order class-previous ; \ old name |
| |
|
| : end-methods ( -- ) \ objects- objects |
: end-methods ( -- ) \ objects- objects |
| \g Switch back from defining methods of a class to normal mode |
\g Switch back from defining methods of a class to normal mode |
| \g (currently this just restores the old search order). |
\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 |
: end-class-noname ( align offset -- class ) \ objects- objects |
| \g End a class definition. The resulting class is @var{class}. |
\g End a class definition. The resulting class is @var{class}. |
| \ : to-this ( object -- ) |
\ : to-this ( object -- ) |
| \ thisp ! ; |
\ thisp ! ; |
| |
|
| : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects |
: enterm ( -- ; run-time: object -- ) |
| \g Start a method definition; @var{object} becomes new @code{this}. |
\g method prologue; @var{object} becomes new @code{this}. |
| :noname |
|
| POSTPONE this |
POSTPONE this |
| POSTPONE >r |
POSTPONE >r |
| POSTPONE to-this ; |
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 |
: exitm ( -- ) \ objects- objects |
| \g @code{exit} from a method; restore old @code{this}. |
\g @code{exit} from a method; restore old @code{this}. |
| POSTPONE r> |
POSTPONE r> |
| 0 current-interface @ class-parent ! |
0 current-interface @ class-parent ! |
| wordlist current-interface @ class-wordlist ! |
wordlist current-interface @ class-wordlist ! |
| object% |
object% |
| current-interface @ push-order |
current-interface @ class>order |
| |
|
| ' drop ( object -- ) |
' drop ( object -- ) |
| method construct ( ... object -- ) \ objects- objects |
method construct ( ... object -- ) \ objects- objects |
| \g Print the object. The method for the class @var{object} prints |
\g Print the object. The method for the class @var{object} prints |
| \g the address of the object and the address of its class. |
\g the address of the object and the address of its class. |
| |
|
| |
selector equal ( object1 object2 -- flag ) |
| |
|
| end-class object ( -- class ) \ objects- objects |
end-class object ( -- class ) \ objects- objects |
| \g the ancestor of all classes. |
\g the ancestor of all classes. |
| |
|
