--- gforth/objects.fs	1996/11/11 16:59:17	1.1
+++ gforth/objects.fs	2000/09/23 15:06:01	1.19
@@ -1,261 +1,527 @@
 \ yet another Forth objects extension
 
-\ written by Anton Ertl 1996
-\ public domain
+\ written by Anton Ertl 1996-2000
+\ public domain; NO WARRANTY
 
-\ This is in ANS Forth (with an environmental dependence on case
-\ insensitivity; convert everything to upper case for state sensitive
-\ systems). It needs some non-core words (in particular, it uses the
-\ memory allocation wordset), but I have not made a complete list.
-
-\ Manual:
-
-\ A class is defined like this:
-
-\ <parent> class
-\   ... field <name>
-\   ...
-
-\   ... inst-var <name>
-\   ...
-
-\ selector <name>
-
-\ :noname ( ... object -- ... )
-\   ... ;
-\ method <name> \ new method
-\ ...
-
-\ :noname ( ... object -- ... )
-\   ... ;
-\ overrides <name> \ existing method
-\ ...
-
-\ end-class <name>
-
-\ you can write fields, inst-vars, selectors, methods and overrides in
-\ any order.
-
-\ A call of a method looks like this:
-
-\ ... <object> <method>
-
-\ (<object> just needs to reside on the stack, there's no need to name it).
-
-\ Instead of defining a method with ':noname ... ;', you can define it
-\ also with 'm: ... ;m'. The difference is that with ':noname' the
-\ "self" object is on the top of stack; with 'm:' you can get it with
-\ 'this'. You should use 'this' only in an 'm:' method even though the
-\ sample implementation does not enforce this.
-
-\ The difference between a field and and inst-var is that the field
-\ refers to an object at the top of data stack (i.e. a field has the
-\ stack effect (object -- addr), whereas the inst-var refers to this
-\ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var
-\ can only be used in an 'm:' method.
-
-\ 'method' defines a new method selector and binds a method to it.
-
-\ 'selector' defines a new method selector without binding a method to
-\ it (you can use this to define abstract classes)
-
-\ 'overrides' binds a different method (than the parent class) to an
-\ existing method selector.
-
-\ If you want to perform early binding, you can do it like this:
-
-\ ... <object> [bind] <class> <method> \ compilation
-\ ... <object> bind  <class> <method> \ interpretation
-
-\ You can get at the method from the method selector and the class like
-\ this:
-
-\ bind' <class> <method>
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ This (in combination with compat/struct.fs) is in ANS Forth (with an
+\ environmental dependence on case insensitivity; convert everything
+\ to upper case for state sensitive systems).
+
+\ compat/struct.fs and this file together use the following words:
+
+\ from CORE :
+\ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r
+\ r> IF ELSE THEN over chars aligned cells 2* here - allot execute
+\ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +!
+\ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." .
+\ from CORE-EXT :
+\ tuck pick nip true <> 0> erase Value :noname compile, 
+\ from BLOCK-EXT :
+\ \ 
+\ from DOUBLE :
+\ 2Constant 
+\ from EXCEPTION :
+\ throw catch 
+\ from EXCEPTION-EXT :
+\ abort" 
+\ from FILE :
+\ ( 
+\ from FLOAT :
+\ faligned floats 
+\ from FLOAT-EXT :
+\ dfaligned dfloats sfaligned sfloats 
+\ from LOCAL :
+\ TO 
+\ from MEMORY :
+\ allocate resize free 
+\ from SEARCH :
+\ get-order set-order wordlist get-current set-current 
 
 \ needs struct.fs
 
 \ helper words
 
+s" gforth" environment? [if]
+    2drop
+[else]
+
 : -rot ( a b c -- c a b )
     rot rot ;
 
 : perform ( ... addr -- ... )
     @ execute ;
 
+: ?dup-if ( compilation: -- orig ; run-time: n -- n|  )
+    POSTPONE ?dup POSTPONE if ; immediate
+
 : save-mem	( addr1 u -- addr2 u ) \ gforth
     \ copy a memory block into a newly allocated region in the heap
     swap >r
     dup allocate throw
     swap 2dup r> -rot move ;
 
+: resize ( a-addr1 u -- a-addr2 ior ) \ gforth
+    over
+    if
+	resize
+    else
+	nip allocate
+    then ;
+
 : extend-mem	( addr1 u1 u -- addr addr2 u2 )
     \ extend memory block allocated from the heap by u aus
-    \ the (possibly reallocated piece is addr2 u2, the extension is at addr )
+    \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
     over >r + dup >r resize throw
     r> over r> + -rot ;
 
-: 2,	( w1 w2 -- ) \ gforth
-    here 2 cells allot 2! ;
+: \g ( -- )
+    postpone \ ; immediate
+[then]
 
-: const-field ( size1 align1 -- size2 align2 )
-    1 cells: field
-does> ( addr -- w )
-    @ + @ ;
+\ data structures
 
 struct
-    1 cells: field object-map
-end-struct object-struct
+    cell% field object-map
+end-struct object%
 
 struct
-    2 cells: field class-map
-    const-field class-instance-size \ aus
-    const-field class-instance-align \ aus
-end-struct class-struct
-
-2variable current-map \ address and size (in aus) of the current map
-
-: class ( class -- size align )
-    dup class-map 2@ save-mem current-map 2!
-    dup class-instance-size
-    swap class-instance-align ;
+    cell% 2* field interface-map
+    cell%    field interface-map-offset \ aus
+      \ difference between where interface-map points and where
+      \ object-map points (0 for non-classes)
+    cell%    field interface-offset \ aus
+      \ offset of interface map-pointer in class-map (0 for classes)
+end-struct interface%
+
+interface%
+    cell%    field class-parent
+    cell%    field class-wordlist \ inst-vars and other protected words
+    cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
+    \g Give the size specification for an instance (i.e. an object)
+    \g of @var{class};
+    \g used as @code{class-inst-size 2@ ( class -- align size )}.
+end-struct class%
+
+struct
+    cell% field selector-offset \ the offset within the (interface) map
+    cell% field selector-interface \ the interface offset
+end-struct selector%
+
+\ maps are not defined explicitly; they have the following structure:
+
+\ pointers to interface maps (for classes) <- interface-map points here
+\ interface%/class% pointer                <- (object-)map  points here
+\ xts of methods 
+
+
+\ code
+
+\ selectors and methods
+
+variable current-interface ( -- addr ) \ objects- objects
+\g Variable: contains the class or interface currently being
+\g defined.
+
 
-: end-class ( size align "name" -- )
-    create
-    current-map 2@ 2,
-    swap , , ;
 
 : no-method ( -- )
-    abort" no method defined" ;
+    true abort" no method defined for this object/selector combination" ;
 
-: method ( xt "name" -- )
-    \ define method and selector
-    current-map 2@ ( xt map-addr map-size )
-    create dup ,
-    1 cells extend-mem current-map 2!
-    !
+: do-class-method ( -- )
 does> ( ... object -- ... )
-    ( object addr )
-    @ over ( object-map ) @ + ( object xtp ) perform ;
+    ( object selector-body )
+    selector-offset @ over object-map @ + ( object xtp ) perform ;
 
-: selector ( "name" -- )
-    \ define a method selector for later overriding in subclasses
+: do-interface-method ( -- )
+does> ( ... object -- ... )
+    ( object selector-body )
+    2dup selector-interface @ ( object selector-body object interface-offset )
+    swap object-map @ + @ ( object selector-body map )
+    swap selector-offset @ + perform ;
+
+: method ( xt "name" -- ) \ objects- objects
+    \g @code{name} execution: @code{... object -- ...}@*
+    \g Create selector @var{name} and makes @var{xt} its method in
+    \g the current class.
+    create
+    current-interface @ interface-map 2@ ( xt map-addr map-size )
+    dup current-interface @ interface-map-offset @ - ,
+    1 cells extend-mem current-interface @ interface-map 2! ! ( )
+    current-interface @ interface-offset @ dup ,
+    ( 0<> ) if
+	do-interface-method
+    else
+	do-class-method
+    then ;
+
+: selector ( "name" -- ) \ objects- objects
+    \g @var{name} execution: @code{... object -- ...}@*
+    \g Create selector @var{name} for the current class and its
+    \g descendents; you can set a method for the selector in the
+    \g current class with @code{overrides}.
     ['] no-method method ;
 
-: override! ( xt method-xt -- )
-    >body @ current-map 2@ drop + ! ;
-
-: overrides ( xt "selector" -- )
-    \ replace default method "method" with xt
-    ' override! ;
-
-: alloc-instance ( class -- object )
-    \ make a new, (almost) uninitialized instance of a class
-    dup class-instance-size allocate throw
-    swap class-map 2@ drop over ( object-map ) ! ;
+: interface-override! ( xt sel-xt interface-map -- )
+    \ xt is the new method for the selector sel-xt in interface-map
+    swap >body ( xt map selector-body )
+    selector-offset @ + ! ;
+
+: class->map ( class -- map ) \ objects- objects
+    \g @var{map} is the pointer to @var{class}'s method map; it
+    \g points to the place in the map to which the selector offsets
+    \g refer (i.e., where @var{object-map}s point to).
+    dup interface-map 2@ drop swap interface-map-offset @ + ;
+
+: unique-interface-map ( class-map offset -- )
+    \ if the interface at offset in class map is the same as its parent,
+    \ copy it to make it unique; used for implementing a copy-on-write policy
+    over @ class-parent @ class->map ( class-map offset parent-map )
+    over + @ >r  \ the map for the interface for the parent
+    + dup @ ( interface-mapp interface-map )
+    dup r> =
+    if
+	dup @ interface-map 2@ nip save-mem drop	
+	swap !
+    else
+	2drop
+    then ;
+
+: class-override! ( xt sel-xt class-map -- ) \ objects- objects
+    \g @var{xt} is the new method for the selector @var{sel-xt} in
+    \g @var{class-map}.
+    over >body ( xt sel-xt class-map selector-body )
+    selector-interface @ ( xt sel-xt class-map offset )
+    ?dup-if \ the selector is for an interface
+	2dup unique-interface-map
+	+ @
+    then
+    interface-override! ;
+
+: overrides ( xt "selector" -- ) \ objects- objects
+    \g replace default method for @var{selector} in the current class
+    \g with @var{xt}. @code{overrides} must not be used during an
+    \g interface definition.
+    ' current-interface @ class->map class-override! ;
+
+\ interfaces
+
+\ every interface gets a different offset; the latest one is stored here
+variable last-interface-offset 0 last-interface-offset !
+
+: interface ( -- ) \ objects- objects
+    \g Start an interface definition.
+    interface% %allot >r
+    r@ current-interface !
+    current-interface 1 cells save-mem r@ interface-map 2!
+    -1 cells last-interface-offset +!
+    last-interface-offset @ r@ interface-offset !
+    0 r> interface-map-offset ! ;
+
+: end-interface-noname ( -- interface ) \ objects- objects
+    \g End an interface definition. The resulting interface is
+    \g @var{interface}.
+    current-interface @ ;
+
+: end-interface ( "name" -- ) \ objects- objects
+    \g @code{name} execution: @code{-- interface}@*
+    \g End an interface definition. The resulting interface is
+    \g @var{interface}.
+    end-interface-noname constant ;
+
+\ visibility control
+
+variable public-wordlist
+
+: protected ( -- ) \ objects- objects
+    \g Set the compilation wordlist to the current class's wordlist
+    current-interface @ class-wordlist @
+    dup get-current <>
+    if \ we are not protected already
+	get-current public-wordlist !
+    then
+    set-current ;
+
+: public ( -- ) \ objects- objects
+    \g Restore the compilation wordlist that was in effect before the
+    \g last @code{protected} that actually changed the compilation
+    \g wordlist.
+    current-interface @ class-wordlist @ get-current =
+    if \ we are protected
+	public-wordlist @ set-current
+    then ;
+
+\ classes
+
+: add-class-order ( n1 class -- wid1 ... widn n+n1 )
+    dup >r class-parent @
+    ?dup-if
+	recurse \ first add the search order for the parent class
+    then
+    r> class-wordlist @ swap 1+ ;
+
+: 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 ! class>order ;
+
+: class ( parent-class -- align offset ) \ objects- objects
+    \g Start a new class definition as a child of
+    \g @var{parent-class}. @var{align offset} are for use by
+    \g @var{field} etc.
+    class% %allot >r
+    dup interface-map 2@ save-mem r@ interface-map 2!
+    dup interface-map-offset @ r@ interface-map-offset !
+    r@ dup class->map !
+    0 r@ interface-offset !
+    dup r@ class-parent !
+    wordlist r@ class-wordlist !
+    r> methods
+    class-inst-size 2@ ;
+
+: remove-class-order ( wid1 ... widn n+n1 class -- n1 )
+    \ note: no checks, whether the wordlists are correct
+    begin
+	>r nip 1-
+	r> class-parent @ dup 0=
+    until
+    drop ;
+
+: 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 @ class-previous ;
+
+: end-class-noname ( align offset -- class ) \ objects- objects
+    \g End a class definition. The resulting class is @var{class}.
+    public end-methods
+    current-interface @ class-inst-size 2!
+    end-interface-noname ;
+
+: end-class ( align offset "name" -- ) \ objects- objects
+    \g @var{name} execution: @code{-- class}@*
+    \g End a class definition. The resulting class is @var{class}.
+    \ name execution: ( -- class )
+    end-class-noname constant ;
+
+\ classes that implement interfaces
+
+: front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
+    \ Extend memory block allocated from the heap by u aus, with the
+    \ old stuff coming at the end
+    2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
+    dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
+    free throw
+    r> dup r> ;
+    
+: implementation ( interface -- ) \ objects- objects
+    \g The current class implements @var{interface}. I.e., you can
+    \g use all selectors of the interface in the current class and its
+    \g descendents.
+    dup interface-offset @ ( interface offset )
+    current-interface @ interface-map-offset @ negate over - dup 0>
+    if \ the interface does not fit in the present class-map
+	>r current-interface @ interface-map 2@
+	r@ front-extend-mem
+	current-interface @ interface-map 2!
+	r@ erase
+	dup negate current-interface @ interface-map-offset !
+	r>
+    then ( interface offset n )
+    drop >r
+    interface-map 2@ save-mem drop ( map )
+    current-interface @ dup interface-map 2@ drop
+    swap interface-map-offset @ + r> + ! ;
 
 \ this/self, instance variables etc.
 
-variable thisp
-: this ( -- object )
-    \ rename this into self if you are a Smalltalk fiend
-    thisp @ ;
+\ rename "this" into "self" if you are a Smalltalk fiend
+0 value this ( -- object ) \ objects- objects
+\g the receiving object of the current method (aka active object).
+: to-this ( object -- ) \ objects- objects
+    \g Set @code{this} (used internally, but useful when debugging).
+    TO this ;
+
+\ another implementation, if you don't have (fast) values
+\ variable thisp
+\ : this ( -- object )
+\     thisp @ ;
+\ : to-this ( object -- )
+\     thisp ! ;
 
-: m: ( -- xt colon-sys ) ( run-time: object -- )
-    :noname 
+: enterm ( -- ; run-time: object -- )
+    \g method prologue; @var{object} becomes new @code{this}.
     POSTPONE this
     POSTPONE >r
-    POSTPONE thisp
-    POSTPONE ! ;
+    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}.
+    POSTPONE r>
+    POSTPONE to-this
+    POSTPONE exit ; immediate
 
-: ;m ( colon-sys -- ) ( run-time: -- )
+: ;m ( colon-sys --; run-time: -- ) \ objects- objects
+    \g End a method definition; restore old @code{this}.
     POSTPONE r>
-    POSTPONE thisp
-    POSTPONE !
+    POSTPONE to-this
     POSTPONE ; ; immediate
 
-: catch ( ... xt -- ... n )
-    \ make it safe to call CATCH within a method.
+: catch ( ... xt -- ... n ) \ exception
+    \ Make it safe to call CATCH within a method.
     \ should also be done with all words containing CATCH.
-    this >r catch r> thisp ! ;
+    this >r catch r> to-this ;
 
-: inst-var ( size1 align1 size align -- size2 align2 )
-    field
-does> ( -- addr )
-    ( addr1 ) @ this + ;
+\ the following is a bit roundabout; this is caused by the standard
+\ disallowing to change the compilation wordlist between CREATE and
+\ DOES> (see RFI 3)
+
+: inst-something ( align1 size1 align size xt "name" -- align2 size2 )
+    \ xt ( -- ) typically is for a DOES>-word
+    get-current >r
+    current-interface @ class-wordlist @ set-current
+    >r create-field r> execute
+    r> set-current ;
 
-\ early binding stuff
+: do-inst-var ( -- )
+does> \ name execution: ( -- addr )
+    ( addr1 ) @ this + ;
 
-\ this is not generally used, only where you want to do something like
-\ superclass method invocation (so that you don't have to name your methods)
+: inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
+    \g @var{name} execution: @code{-- addr}@*
+    \g @var{addr} is the address of the field @var{name} in
+    \g @code{this} object.
+    ['] do-inst-var inst-something ;
+
+: do-inst-value ( -- )
+does> \ name execution: ( -- w )
+    ( addr1 ) @ this + @ ;
+
+: inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects
+    \g @var{name} execution: @code{-- w}@*
+    \g @var{w} is the value of the field @var{name} in @code{this}
+    \g object.
+    cell% ['] do-inst-value inst-something ;
+
+: <to-inst> ( w xt -- ) \ objects- objects
+    \g store @var{w} into the field @var{xt} in @code{this} object.
+    >body @ this + ! ;
+
+: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
+    \g store @var{w} into field @var{name} in @code{this} object.
+    ' >body @ POSTPONE literal
+    POSTPONE this
+    POSTPONE +
+    POSTPONE ! ; immediate
 
-: (bind) ( class method-xt -- xt )
-    >body @ swap class-map 2@ drop + @ ;
+\ class binding stuff
 
-: bind' ( "class" "method" -- xt )
-    ' >body ' (bind) ;
+: <bind> ( class selector-xt -- xt ) \ objects- objects
+    \g @var{xt} is the method for the selector @var{selector-xt} in
+    \g @var{class}.
+    >body swap class->map over selector-interface @
+    ?dup-if
+	+ @
+    then
+    swap selector-offset @ + @ ;
+
+: bind' ( "class" "selector" -- xt ) \ objects- objects
+    \g @var{xt} is the method for @var{selector} in @var{class}.
+    ' execute ' <bind> ;
 
-: bind ( ... object "class" "method" -- ... )
+: bind ( ... "class" "selector" -- ... ) \ objects- objects
+    \g Execute the method for @var{selector} in @var{class}.
     bind' execute ;
 
-: [bind] ( compile-time: "class" "method" -- ; run-time: ... object -- ... )
+: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects
+    \g Compile the method for @var{selector} in @var{class}.
     bind' compile, ; immediate
 
+: current' ( "selector" -- xt ) \ objects- objects
+    \g @var{xt} is the method for @var{selector} in the current class.
+    current-interface @ ' <bind> ;
+
+: [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
+    \g Compile the method for @var{selector} in the current class.
+    current' compile, ; immediate
+
+: [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
+    \g Compile the method for @var{selector} in the parent of the
+    \g current class.
+    current-interface @ class-parent @ ' <bind> compile, ; immediate
+
 \ the object class
 
-0 0 save-mem current-map 2!
-object-struct \ no class to inherit from, so we have to do this manually
-:noname ( object -- )
-    ." object:" dup . ." class:" object-map @ . ;
-method print
-end-class object
-
-\ examples
-true [if]
-cr object alloc-instance print
+\ because OBJECT has no parent class, we have to build it by hand
+\ (instead of with class)
 
-object class
-:noname ( object -- )
-    drop ." undefined" ;
-overrides print
-end-class nothing
-
-nothing alloc-instance constant undefined
-
-cr undefined print
-
-\ instance variables and this
-object class
-1 cells: inst-var count-n
-m: ( object -- )
-    count-n @ . ;m
-overrides print
-m: ( object -- )
-   0 count-n ! ;m
-method init
-m: ( object -- )
-    1 count-n +! ;m
-method inc
-end-class counter
-
-counter alloc-instance constant counter1
-
-cr
-counter1 init
-counter1 print
-counter1 inc
-counter1 print
-counter1 inc
-counter1 inc
-counter1 inc
-counter1 print
-counter1 print
-
-\ examples of static binding
-
-cr undefined bind object print
-: object-print ( object -- )
-    [bind] object print ;
+class% %allot current-interface !
+current-interface 1 cells save-mem current-interface @ interface-map 2!
+0 current-interface @ interface-map-offset !
+0 current-interface @ interface-offset !
+0 current-interface @ class-parent !
+wordlist current-interface @ class-wordlist !
+object%
+current-interface @ class>order
+
+' drop ( object -- )
+method construct ( ... object -- ) \ objects- objects
+\g Initialize the data fields of @var{object}. The method for the
+\g class @var{object} just does nothing: @code{( object -- )}.
 
-cr undefined object-print
-[then]
+:noname ( object -- )
+    ." object:" dup . ." class:" object-map @ @ . ;
+method print ( object -- ) \ objects- objects
+\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.
+
+\ constructing objects
+
+: init-object ( ... class object -- ) \ objects- objects
+    \g Initialize a chunk of memory (@var{object}) to an object of
+    \g class @var{class}; then performs @code{construct}.
+    swap class->map over object-map ! ( ... object )
+    construct ;
+
+: xt-new ( ... class xt -- object ) \ objects- objects
+    \g Make a new object, using @code{xt ( align size -- addr )} to
+    \g get memory.
+    over class-inst-size 2@ rot execute
+    dup >r init-object r> ;
+
+: dict-new ( ... class -- object ) \ objects- objects
+    \g @code{allot} and initialize an object of class @var{class} in
+    \g the dictionary.
+    ['] %allot xt-new ;
+
+: heap-new ( ... class -- object ) \ objects- objects
+    \g @code{allocate} and initialize an object of class @var{class}.
+    ['] %alloc xt-new ;