--- gforth/objects.fs	1997/06/23 15:53:53	1.4
+++ gforth/objects.fs	1999/07/05 18:54:20	1.14
@@ -1,6 +1,6 @@
 \ yet another Forth objects extension
 
-\ written by Anton Ertl 1996, 1997
+\ written by Anton Ertl 1996-1999
 \ public domain; NO WARRANTY
 
 \ This (in combination with compat/struct.fs) is in ANS Forth (with an
@@ -41,12 +41,13 @@
 
 \ helper words
 
+s" gforth" environment? [if]
+    2drop
+[else]
+
 : -rot ( a b c -- c a b )
     rot rot ;
 
-: under+ ( a b c -- a+c b )
-    rot + swap ;
-
 : perform ( ... addr -- ... )
     @ execute ;
 
@@ -73,6 +74,10 @@
     over >r + dup >r resize throw
     r> over r> + -rot ;
 
+: \g ( -- )
+    postpone \ ; immediate
+[then]
+
 \ data structures
 
 struct
@@ -90,8 +95,11 @@ end-struct interface%
 
 interface%
     cell%    field class-parent
-    cell%    field class-wordlist \ instance variables and other private words
-    cell% 2* field class-inst-size \ size and alignment
+    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
@@ -110,14 +118,18 @@ end-struct selector%
 
 \ selectors and methods
 
-variable current-interface
+variable current-interface ( -- addr ) \ objects- objects
+\g Variable: contains the class or interface currently being
+\g defined.
+
+
 
 : no-method ( -- )
     true abort" no method defined for this object/selector combination" ;
 
 : do-class-method ( -- )
 does> ( ... object -- ... )
-    ( object )
+    ( object selector-body )
     selector-offset @ over object-map @ + ( object xtp ) perform ;
 
 : do-interface-method ( -- )
@@ -127,8 +139,10 @@ does> ( ... object -- ... )
     swap object-map @ + @ ( object selector-body map )
     swap selector-offset @ + perform ;
 
-: method ( xt "name" -- )
-    \ define selector with method xt
+: 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 @ - ,
@@ -140,8 +154,11 @@ does> ( ... object -- ... )
 	do-class-method
     then ;
 
-: selector ( "name" -- )
-    \ define a method selector for later overriding in subclasses
+: 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 ;
 
 : interface-override! ( xt sel-xt interface-map -- )
@@ -149,8 +166,10 @@ does> ( ... object -- ... )
     swap >body ( xt map selector-body )
     selector-offset @ + ! ;
 
-: class->map ( class -- map )
-    \ compute the (object-)map for the class
+: 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 -- )
@@ -158,17 +177,18 @@ does> ( ... object -- ... )
     \ 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 @ ( mapp map )
+    + dup @ ( interface-mapp interface-map )
     dup r> =
     if
-	@ interface-map 2@ save-mem drop
+	dup @ interface-map 2@ nip save-mem drop	
 	swap !
     else
 	2drop
     then ;
 
-: class-override! ( xt sel-xt class-map -- )
-    \ xt is the new method for the selector sel-xt in class-map
+: 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
@@ -177,9 +197,10 @@ does> ( ... object -- ... )
     then
     interface-override! ;
 
-: overrides ( xt "selector" -- )
-    \ replace default method "method" in the current class with xt
-    \ must not be used during an interface definition
+: 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
@@ -187,21 +208,48 @@ does> ( ... object -- ... )
 \ every interface gets a different offset; the latest one is stored here
 variable last-interface-offset 0 last-interface-offset !
 
-: interface ( -- )
+: interface ( -- ) \ objects- objects
+    \g Start an interface definition.
     interface% %allot >r
-    0 0 r@ interface-map 2!
+    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 !
-    r> current-interface ! ;
+    0 r> interface-map-offset ! ;
 
-: end-interface-noname ( -- interface )
+: end-interface-noname ( -- interface ) \ objects- objects
+    \g End an interface definition. The resulting interface is
+    \g @var{interface}.
     current-interface @ ;
 
-: end-interface ( "name" -- )
-    \ name execution: ( -- 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 )
@@ -211,11 +259,20 @@ variable last-interface-offset 0 last-in
     then
     r> class-wordlist @ swap 1+ ;
 
-: push-order ( class -- )
-    \ add the class's wordlist to the search-order (in front)
+: push-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 ;
 
-: class ( parent-class -- align size )
+: methods ( class -- )
+    \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 ;
+
+: 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 !
@@ -223,8 +280,7 @@ variable last-interface-offset 0 last-in
     0 r@ interface-offset !
     dup r@ class-parent !
     wordlist r@ class-wordlist !
-    r@ current-interface !
-    r> push-order
+    r> methods
     class-inst-size 2@ ;
 
 : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
@@ -235,44 +291,43 @@ variable last-interface-offset 0 last-in
     until
     drop ;
 
-: drop-order ( class -- )
-    \ note: no checks, whether the wordlists are correct
+: drop-order ( 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 ;
 
-: end-class-noname ( align size -- class )
-    current-interface @ dup drop-order class-inst-size 2!
+: end-methods ( -- )
+    \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 ;
+
+: 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 size "name" -- )
+: 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 ;
 
-\ visibility control
-
-variable public-wordlist
-
-: protected ( -- )
-    current-interface @ class-wordlist @
-    dup get-current <>
-    if \ we are not protected already
-	get-current public-wordlist !
-    then
-    set-current ;
-
-: public ( -- )
-    public-wordlist @ set-current ;
-
 \ 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
+    \ 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 -- )
+: 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
@@ -291,8 +346,10 @@ variable public-wordlist
 \ this/self, instance variables etc.
 
 \ rename "this" into "self" if you are a Smalltalk fiend
-0 value this ( -- object )
-: to-this ( object -- )
+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
@@ -302,19 +359,27 @@ variable public-wordlist
 \ : to-this ( object -- )
 \     thisp ! ;
 
-: m: ( -- xt colon-sys ) ( run-time: object -- )
+: m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects
+    \g Start a method definition; @var{object} becomes new @code{this}.
     :noname 
     POSTPONE this
     POSTPONE >r
     POSTPONE to-this ;
 
-: ;m ( colon-sys -- ) ( run-time: -- )
+: 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: -- ) \ objects- objects
+    \g End a method definition; restore old @code{this}.
     POSTPONE r>
     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> to-this ;
 
@@ -333,23 +398,28 @@ variable public-wordlist
 does> \ name execution: ( -- addr )
     ( addr1 ) @ this + ;
 
-: inst-var ( align1 offset1 align size "name" -- align2 offset2 )
-    \ name execution: ( -- addr )
+: 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 )
-    \ name execution: ( -- w )
-    \ a cell-sized value-flavoured instance field
+: 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 -- )
+: <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 -- )
+: [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 +
@@ -357,31 +427,38 @@ does> \ name execution: ( -- w )
 
 \ class binding stuff
 
-: <bind> ( class selector-xt -- xt )
+: <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 )
+: bind' ( "class" "selector" -- xt ) \ objects- objects
+    \g @var{xt} is the method for @var{selector} in @var{class}.
     ' execute ' <bind> ;
 
-: bind ( ... object "class" "selector" -- ... )
+: bind ( ... "class" "selector" -- ... ) \ objects- objects
+    \g Execute the method for @var{selector} in @var{class}.
     bind' execute ;
 
-: [bind] ( compile-time: "class" "selector" -- ; 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 )
+: 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 -- ... )
+: [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 -- ... )
-    \ same as `[bind] "parent" "selector"', where "parent" is the
-    \ parent class of the current class
+: [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
@@ -398,31 +475,39 @@ wordlist current-interface @ class-wordl
 object%
 current-interface @ push-order
 
-:noname ( object -- )
-    drop ;
-method construct ( ... object -- )
+' 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 -- )}.
 
 :noname ( object -- )
     ." object:" dup . ." class:" object-map @ @ . ;
-method print
+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.
 
-end-class object
+end-class object ( -- class ) \ objects- objects
+\g the ancestor of all classes.
 
 \ constructing objects
 
-: init-object ( ... class object -- )
+: 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 )
-    \ makes a new object, using XT ( align size -- addr ) to allocate memory
+: 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 )
-    \ makes a new object HERE in dictionary
+: 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 )
-    \ makes a new object in ALLOCATEd memory
+: heap-new ( ... class -- object ) \ objects- objects
+    \g @code{allocate} and initialize an object of class @var{class}.
     ['] %alloc xt-new ;