Diff for /gforth/objects.fs between versions 1.7 and 1.10

version 1.7, 1998/08/02 15:06:01 version 1.10, 1998/11/22 21:23:25
Line 96  end-struct interface% Line 96  end-struct interface%
 interface%  interface%
     cell%    field class-parent      cell%    field class-parent
     cell%    field class-wordlist \ inst-vars and other protected words      cell%    field class-wordlist \ inst-vars and other protected words
     cell% 2* field class-inst-size ( class -- addr ) \ objects      cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
     \g used as @code{class-inst-size 2@ ( class -- align size )},      \g used as @code{class-inst-size 2@ ( class -- align size )},
     \g gives the size specification for an instance (i.e. an object)      \g gives the size specification for an instance (i.e. an object)
     \g of @code{class}.      \g of @code{class}.
Line 118  end-struct selector% Line 118  end-struct selector%
   
 \ selectors and methods  \ selectors and methods
   
 variable current-interface ( -- addr ) \ objects  variable current-interface ( -- addr ) \ objects- objects
 \g this variable contains the class or interface currently being  \g this variable contains the class or interface currently being
 \g defined.  \g defined.
   
Line 139  does> ( ... object -- ... ) Line 139  does> ( ... object -- ... )
     swap object-map @ + @ ( object selector-body map )      swap object-map @ + @ ( object selector-body map )
     swap selector-offset @ + perform ;      swap selector-offset @ + perform ;
   
 : method ( xt "name" -- ) \ objects  : method ( xt "name" -- ) \ objects- objects
     \g @code{name} execution: @code{... object -- ...}@*      \g @code{name} execution: @code{... object -- ...}@*
     \g creates selector @code{name} and makes @code{xt} its method in      \g creates selector @code{name} and makes @code{xt} its method in
     \g the current class.      \g the current class.
Line 154  does> ( ... object -- ... ) Line 154  does> ( ... object -- ... )
         do-class-method          do-class-method
     then ;      then ;
   
 : selector ( "name" -- ) \ objects  : selector ( "name" -- ) \ objects- objects
     \g @code{name} execution: @code{... object -- ...}@*      \g @code{name} execution: @code{... object -- ...}@*
     \g creates selector @code{name} for the current class and its      \g creates selector @code{name} for the current class and its
     \g descendents; you can set a method for the selector in the      \g descendents; you can set a method for the selector in the
Line 166  does> ( ... object -- ... ) Line 166  does> ( ... object -- ... )
     swap >body ( xt map selector-body )      swap >body ( xt map selector-body )
     selector-offset @ + ! ;      selector-offset @ + ! ;
   
 : class->map ( class -- map ) \ objects  : class->map ( class -- map ) \ objects- objects
     \g @code{map} is the pointer to @code{class}'s method map; it      \g @code{map} is the pointer to @code{class}'s method map; it
     \g points to the place in the map to which the selector offsets      \g points to the place in the map to which the selector offsets
     \g refer (i.e., where @code{object-map}s point to).      \g refer (i.e., where @code{object-map}s point to).
Line 177  does> ( ... object -- ... ) Line 177  does> ( ... object -- ... )
     \ copy it to make it unique; used for implementing a copy-on-write policy      \ 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 @ class-parent @ class->map ( class-map offset parent-map )
     over + @ >r  \ the map for the interface for the parent      over + @ >r  \ the map for the interface for the parent
     + dup @ ( mapp map )      + dup @ ( interface-mapp interface-map )
     dup r> =      dup r> =
     if      if
         @ interface-map 2@ save-mem drop          dup @ interface-map 2@ nip save-mem drop        
         swap !          swap !
     else      else
         2drop          2drop
     then ;      then ;
   
 : class-override! ( xt sel-xt class-map -- ) \ objects  : class-override! ( xt sel-xt class-map -- ) \ objects- objects
     \g @code{xt} is the new method for the selector @code{sel-xt} in      \g @code{xt} is the new method for the selector @code{sel-xt} in
     \g @code{class-map}.      \g @code{class-map}.
     over >body ( xt sel-xt class-map selector-body )      over >body ( xt sel-xt class-map selector-body )
Line 197  does> ( ... object -- ... ) Line 197  does> ( ... object -- ... )
     then      then
     interface-override! ;      interface-override! ;
   
 : overrides ( xt "selector" -- ) \ objects  : overrides ( xt "selector" -- ) \ objects- objects
     \g replace default method for @code{selector} in the current class      \g replace default method for @code{selector} in the current class
     \g with @code{xt}. @code{overrides} must not be used during an      \g with @code{xt}. @code{overrides} must not be used during an
     \g interface definition.      \g interface definition.
Line 208  does> ( ... object -- ... ) Line 208  does> ( ... object -- ... )
 \ every interface gets a different offset; the latest one is stored here  \ every interface gets a different offset; the latest one is stored here
 variable last-interface-offset 0 last-interface-offset !  variable last-interface-offset 0 last-interface-offset !
   
 : interface ( -- ) \ objects  : interface ( -- ) \ objects- objects
     \g starts an interface definition.      \g starts an interface definition.
     interface% %allot >r      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 +!      -1 cells last-interface-offset +!
     last-interface-offset @ r@ interface-offset !      last-interface-offset @ r@ interface-offset !
     0 r@ interface-map-offset !      0 r> interface-map-offset ! ;
     r> current-interface ! ;  
   
 : end-interface-noname ( -- interface ) \ objects  : end-interface-noname ( -- interface ) \ objects- objects
     \g ends an interface definition. The resulting interface is      \g ends an interface definition. The resulting interface is
     \g @code{interface}.      \g @code{interface}.
     current-interface @ ;      current-interface @ ;
   
 : end-interface ( "name" -- ) \ objects  : end-interface ( "name" -- ) \ objects- objects
     \g @code{name} execution: @code{-- interface}@*      \g @code{name} execution: @code{-- interface}@*
     \g ends an interface definition. The resulting interface is      \g ends an interface definition. The resulting interface is
     \g @code{interface}.      \g @code{interface}.
Line 237  variable last-interface-offset 0 last-in Line 237  variable last-interface-offset 0 last-in
     then      then
     r> class-wordlist @ swap 1+ ;      r> class-wordlist @ swap 1+ ;
   
 : push-order ( class -- ) \ objects  : push-order ( class -- ) \ objects- objects
     \g add @code{class}'s wordlists to the search-order (in front)      \g add @code{class}'s wordlists to the search-order (in front)
     >r get-order r> add-class-order set-order ;      >r get-order r> add-class-order set-order ;
   
 : class ( parent-class -- align offset ) \ 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
     \g @code{parent-class}. @code{align offset} are for use by      \g @code{parent-class}. @code{align offset} are for use by
     \g @code{field} etc.      \g @code{field} etc.
Line 264  variable last-interface-offset 0 last-in Line 264  variable last-interface-offset 0 last-in
     until      until
     drop ;      drop ;
   
 : drop-order ( class -- ) \ objects  : drop-order ( class -- ) \ objects- objects
     \g drops @code{class}'s wordlists from the search order. No      \g drops @code{class}'s wordlists from the search order. No
     \g checking is made whether @code{class}'s wordlists are actually      \g checking is made whether @code{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 ;
   
 : end-class-noname ( align offset -- class ) \ objects  : end-class-noname ( align offset -- class ) \ objects- objects
     \g ends a class definition. The resulting class is @code{class}.      \g ends a class definition. The resulting class is @code{class}.
     current-interface @ dup drop-order class-inst-size 2!      current-interface @ dup drop-order class-inst-size 2!
     end-interface-noname ;      end-interface-noname ;
   
 : end-class ( align offset "name" -- ) \ objects  : end-class ( align offset "name" -- ) \ objects- objects
     \g @code{name} execution: @code{-- class}@*      \g @code{name} execution: @code{-- class}@*
     \g ends a class definition. The resulting class is @code{class}.      \g ends a class definition. The resulting class is @code{class}.
     \ name execution: ( -- class )      \ name execution: ( -- class )
Line 285  variable last-interface-offset 0 last-in Line 285  variable last-interface-offset 0 last-in
   
 variable public-wordlist  variable public-wordlist
   
 : protected ( -- ) \ objects  : protected ( -- ) \ objects- objects
     \g set the compilation wordlist to the current class's wordlist      \g set the compilation wordlist to the current class's wordlist
     current-interface @ class-wordlist @      current-interface @ class-wordlist @
     dup get-current <>      dup get-current <>
Line 294  variable public-wordlist Line 294  variable public-wordlist
     then      then
     set-current ;      set-current ;
   
 : public ( -- ) \ objects  : public ( -- ) \ objects- objects
     \g restore the compilation wordlist that was in effect before the      \g restore the compilation wordlist that was in effect before the
     \g last @code{protected} that actually changed the compilation      \g last @code{protected} that actually changed the compilation
     \g wordlist.      \g wordlist.
Line 310  variable public-wordlist Line 310  variable public-wordlist
     free throw      free throw
     r> dup r> ;      r> dup r> ;
           
 : implementation ( interface -- ) \ objects  : implementation ( interface -- ) \ objects- objects
     \g the current class implements @code{interface}. I.e., you can      \g the current class implements @code{interface}. I.e., you can
     \g use all selectors of the interface in the current class and its      \g use all selectors of the interface in the current class and its
     \g descendents.      \g descendents.
Line 332  variable public-wordlist Line 332  variable public-wordlist
 \ this/self, instance variables etc.  \ this/self, instance variables etc.
   
 \ rename "this" into "self" if you are a Smalltalk fiend  \ rename "this" into "self" if you are a Smalltalk fiend
 0 value this ( -- object ) \ objects  0 value this ( -- object ) \ objects- objects
 \g the receiving object of the current method (aka active object).  \g the receiving object of the current method (aka active object).
 : to-this ( object -- ) \ objects  : to-this ( object -- ) \ objects- objects
     \g sets @code{this} (used internally, but useful when debugging).      \g sets @code{this} (used internally, but useful when debugging).
     TO this ;      TO this ;
   
Line 345  variable public-wordlist Line 345  variable public-wordlist
 \ : to-this ( object -- )  \ : to-this ( object -- )
 \     thisp ! ;  \     thisp ! ;
   
 : m: ( -- xt colon-sys; run-time: object -- ) \ objects  : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects
     \g start a method definition; @code{object} becomes new @code{this}.      \g start a method definition; @code{object} becomes new @code{this}.
     :noname       :noname 
     POSTPONE this      POSTPONE this
     POSTPONE >r      POSTPONE >r
     POSTPONE to-this ;      POSTPONE to-this ;
   
 : exitm ( -- ) \ 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>
     POSTPONE to-this      POSTPONE to-this
     POSTPONE exit ; immediate      POSTPONE exit ; immediate
   
 : ;m ( colon-sys --; run-time: -- ) \ objects  : ;m ( colon-sys --; run-time: -- ) \ objects- objects
     \g end a method definition; restore old @code{this}.      \g end a method definition; restore old @code{this}.
     POSTPONE r>      POSTPONE r>
     POSTPONE to-this      POSTPONE to-this
Line 384  variable public-wordlist Line 384  variable public-wordlist
 does> \ name execution: ( -- addr )  does> \ name execution: ( -- addr )
     ( addr1 ) @ this + ;      ( addr1 ) @ this + ;
   
 : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects  : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
     \g @code{name} execution: @code{-- addr}@*      \g @code{name} execution: @code{-- addr}@*
     \g @code{addr} is the address of the field @code{name} in      \g @code{addr} is the address of the field @code{name} in
     \g @code{this} object.      \g @code{this} object.
Line 394  does> \ name execution: ( -- addr ) Line 394  does> \ name execution: ( -- addr )
 does> \ name execution: ( -- w )  does> \ name execution: ( -- w )
     ( addr1 ) @ this + @ ;      ( addr1 ) @ this + @ ;
   
 : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects  : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects
     \g @code{name} execution: @code{-- w}@*      \g @code{name} execution: @code{-- w}@*
     \g @code{w} is the value of the field @code{name} in @code{this}      \g @code{w} is the value of the field @code{name} in @code{this}
     \g object.      \g object.
     cell% ['] do-inst-value inst-something ;      cell% ['] do-inst-value inst-something ;
   
 : <to-inst> ( w xt -- ) \ objects  : <to-inst> ( w xt -- ) \ objects- objects
     \g store @code{w} into the field @code{xt} in @code{this} object.      \g store @code{w} into the field @code{xt} in @code{this} object.
     >body @ this + ! ;      >body @ this + ! ;
   
 : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects  : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
     \g store @code{w} into field @code{name} in @code{this} object.      \g store @code{w} into field @code{name} in @code{this} object.
     ' >body @ POSTPONE literal      ' >body @ POSTPONE literal
     POSTPONE this      POSTPONE this
Line 413  does> \ name execution: ( -- w ) Line 413  does> \ name execution: ( -- w )
   
 \ class binding stuff  \ class binding stuff
   
 : <bind> ( class selector-xt -- xt ) \ objects  : <bind> ( class selector-xt -- xt ) \ objects- objects
     \g @code{xt} is the method for the selector @code{selector-xt} in      \g @code{xt} is the method for the selector @code{selector-xt} in
     \g @code{class}.      \g @code{class}.
     >body swap class->map over selector-interface @      >body swap class->map over selector-interface @
Line 422  does> \ name execution: ( -- w ) Line 422  does> \ name execution: ( -- w )
     then      then
     swap selector-offset @ + @ ;      swap selector-offset @ + @ ;
   
 : bind' ( "class" "selector" -- xt ) \ objects  : bind' ( "class" "selector" -- xt ) \ objects- objects
     \g @code{xt} is the method for @code{selector} in @code{class}.      \g @code{xt} is the method for @code{selector} in @code{class}.
     ' execute ' <bind> ;      ' execute ' <bind> ;
   
 : bind ( ... "class" "selector" -- ... ) \ objects  : bind ( ... "class" "selector" -- ... ) \ objects- objects
     \g execute the method for @code{selector} in @code{class}.      \g execute the method for @code{selector} in @code{class}.
     bind' execute ;      bind' execute ;
   
 : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects  : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects
     \g compile the method for @code{selector} in @code{class}.      \g compile the method for @code{selector} in @code{class}.
     bind' compile, ; immediate      bind' compile, ; immediate
   
 : current' ( "selector" -- xt ) \ objects  : current' ( "selector" -- xt ) \ objects- objects
     \g @code{xt} is the method for @code{selector} in the current class.      \g @code{xt} is the method for @code{selector} in the current class.
     current-interface @ ' <bind> ;      current-interface @ ' <bind> ;
   
 : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects  : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
     \g compile the method for @code{selector} in the current class.      \g compile the method for @code{selector} in the current class.
     current' compile, ; immediate      current' compile, ; immediate
   
 : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects  : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
     \g compile the method for @code{selector} in the parent of the      \g compile the method for @code{selector} in the parent of the
     \g current class.      \g current class.
     current-interface @ class-parent @ ' <bind> compile, ; immediate      current-interface @ class-parent @ ' <bind> compile, ; immediate
Line 462  object% Line 462  object%
 current-interface @ push-order  current-interface @ push-order
   
 ' drop ( object -- )  ' drop ( object -- )
 method construct ( ... object -- ) \ objects  method construct ( ... object -- ) \ objects- objects
 \g initializes the data fields of @code{object}. The method for the  \g initializes the data fields of @code{object}. The method for the
 \g class @code{object} just does nothing @code{( object -- )}.  \g class @code{object} just does nothing @code{( object -- )}.
   
 :noname ( object -- )  :noname ( object -- )
     ." object:" dup . ." class:" object-map @ @ . ;      ." object:" dup . ." class:" object-map @ @ . ;
 method print ( object -- ) \ objects  method print ( object -- ) \ objects- objects
 \g prints the object. The method for the class @code{object} prints  \g prints the object. The method for the class @code{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.
   
 end-class object ( -- class ) \ objects  end-class object ( -- class ) \ objects- objects
 \g the ancestor of all classes.  \g the ancestor of all classes.
   
 \ constructing objects  \ constructing objects
   
 : init-object ( ... class object -- ) \ objects  : init-object ( ... class object -- ) \ objects- objects
     \g initializes a chunk of memory (@code{object}) to an object of      \g initializes a chunk of memory (@code{object}) to an object of
     \g class @code{class}; then performs @code{construct}.      \g class @code{class}; then performs @code{construct}.
     swap class->map over object-map ! ( ... object )      swap class->map over object-map ! ( ... object )
     construct ;      construct ;
   
 : xt-new ( ... class xt -- object ) \ objects  : xt-new ( ... class xt -- object ) \ objects- objects
     \g makes a new object, using @code{xt ( align size -- addr )} to      \g makes a new object, using @code{xt ( align size -- addr )} to
     \g get memory.      \g get memory.
     over class-inst-size 2@ rot execute      over class-inst-size 2@ rot execute
     dup >r init-object r> ;      dup >r init-object r> ;
   
 : dict-new ( ... class -- object ) \ objects  : dict-new ( ... class -- object ) \ objects- objects
     \g @code{allot} and initialize an object of class @code{class} in      \g @code{allot} and initialize an object of class @code{class} in
     \g the dictionary.      \g the dictionary.
     ['] %allot xt-new ;      ['] %allot xt-new ;
   
 : heap-new ( ... class -- object ) \ objects  : heap-new ( ... class -- object ) \ objects- objects
     \g @code{allocate} and initialize an object of class @code{class}.      \g @code{allocate} and initialize an object of class @code{class}.
     ['] %alloc xt-new ;      ['] %alloc xt-new ;

Removed from v.1.7  
changed lines
  Added in v.1.10


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>