Diff for /gforth/objects.fs between versions 1.3 and 1.12

version 1.3, 1997/06/06 17:27:57 version 1.12, 1999/02/16 06:32:29
Line 1 Line 1
 \ yet another Forth objects extension  \ yet another Forth objects extension
   
 \ written by Anton Ertl 1996, 1997  \ written by Anton Ertl 1996-1998
 \ public domain  \ public domain; NO WARRANTY
   
 \ This (in combination with compat/struct.fs) is in ANS Forth (with an  \ This (in combination with compat/struct.fs) is in ANS Forth (with an
 \ environmental dependence on case insensitivity; convert everything  \ environmental dependence on case insensitivity; convert everything
 \ to upper case for state sensitive systems).  \ to upper case for state sensitive systems).
   
 \ If you don't use Gforth, you have to load compat/struct.fs first.  
 \ compat/struct.fs and this file together use the following words:  \ compat/struct.fs and this file together use the following words:
   
 \ from CORE :  \ from CORE :
 \ : 1- + swap invert and ; DOES> @ immediate drop Create >r rot r@ dup  \ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r
 \ , IF ELSE THEN r> chars cells 2* here - allot over execute POSTPONE  \ r> IF ELSE THEN over chars aligned cells 2* here - allot execute
 \ ?dup 2dup move 2! Variable 2@ ! ['] >body = 2drop ' +! Constant  \ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +!
 \ recurse 1+ BEGIN 0= UNTIL negate Literal ." .  \ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." .
 \ from CORE-EXT :  \ from CORE-EXT :
 \ tuck nip true <> 0> erase Value :noname compile,   \ tuck pick nip true <> 0> erase Value :noname compile, 
 \ from BLOCK-EXT :  \ from BLOCK-EXT :
 \ \   \ \ 
 \ from DOUBLE :  \ from DOUBLE :
Line 28 Line 27
 \ from FILE :  \ from FILE :
 \ (   \ ( 
 \ from FLOAT :  \ from FLOAT :
 \ floats   \ faligned floats 
 \ from FLOAT-EXT :  \ from FLOAT-EXT :
 \ dfloats sfloats   \ dfaligned dfloats sfaligned sfloats 
 \ from LOCAL :  \ from LOCAL :
 \ TO   \ TO 
 \ from MEMORY :  \ from MEMORY :
Line 38 Line 37
 \ from SEARCH :  \ from SEARCH :
 \ get-order set-order wordlist get-current set-current   \ get-order set-order wordlist get-current set-current 
   
 \ ---------------------------------------  
 \ 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>  
   
   
 \ An interface is defined like this:  
   
 \ interface  
 \   selector <name>  
 \ : noname ( ... object -- ... )  
 \     ... ;  
 \ method <name>  
 \   ...  
 \ end-interface <name>  
   
 \ You can only define new selectors in an interface definition, no  
 \ fields or instance variables. If you define a selector with  
 \ 'method', the corresponding method becomes the default method for  
 \ this selector.  
   
 \ An interface is used like this:  
   
 \ <parent> class  
 \   <interface> implementation  
 \   <interface> implementation  
   
 \ :noname ( ... -- ... )  
 \     ... ;  
 \ overrides <selector>  
   
 \ end-class name  
   
 \ a class inherits all interfaces of its parent. An 'implementation'  
 \ means that the class also implements the specified interface (If the  
 \ interface is already implemented by the parent class, an  
 \ 'implementation' phrase resets the methods to the defaults.  
   
 \ 'overrides' can also be used to override interface methods. It has  
 \ to be used after announcing the 'implementation' of the  
 \ interface. Apart from this, 'implementation' can be freely mixed  
 \ with the other stuff (but I recommend to put all 'implementation'  
 \ phrases at the beginning of the class definition).  
   
 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\  
   
 \ needs struct.fs  \ needs struct.fs
   
 \ helper words  \ helper words
   
   s" gforth" environment? [if]
       2drop
   [else]
   
 : -rot ( a b c -- c a b )  : -rot ( a b c -- c a b )
     rot rot ;      rot rot ;
   
 : under+ ( a b c -- a+b c )  
     rot + swap ;  
   
 : perform ( ... addr -- ... )  : perform ( ... addr -- ... )
     @ execute ;      @ execute ;
   
Line 176 Line 70
   
 : extend-mem    ( addr1 u1 u -- addr addr2 u2 )  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
     \ extend memory block allocated from the heap by u aus      \ 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      over >r + dup >r resize throw
     r> over r> + -rot ;      r> over r> + -rot ;
   
 : 2,    ( w1 w2 -- ) \ gforth  : \g ( -- )
     here 2 cells allot 2! ;      postpone \ ; immediate
   [then]
   
 \ data structures  \ data structures
   
 struct  struct
     1 cells: field object-map      cell% field object-map
 end-struct object-struct  end-struct object%
   
 struct  struct
     2 cells: field interface-map      cell% 2* field interface-map
     1 cells: field interface-map-offset \ aus      cell%    field interface-map-offset \ aus
       \ difference between where interface-map points and where        \ difference between where interface-map points and where
       \ object-map points (0 for non-classes)        \ object-map points (0 for non-classes)
     1 cells: field interface-offset \ aus      cell%    field interface-offset \ aus
       \ offset of interface map-pointer in class-map (0 for classes)        \ offset of interface map-pointer in class-map (0 for classes)
 end-struct interface-struct  end-struct interface%
   
 interface-struct  interface%
     1 cells: field class-parent      cell%    field class-parent
     1 cells: field class-wordlist \ instance variables and other private words      cell%    field class-wordlist \ inst-vars and other protected words
     2 cells: field class-inst-size \ size and alignment      cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
 end-struct class-struct      \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  struct
     1 cells: field selector-offset \ the offset within the (interface) map      cell% field selector-offset \ the offset within the (interface) map
     1 cells: field selector-interface \ the interface offset      cell% field selector-interface \ the interface offset
 end-struct selector-struct  end-struct selector%
   
 \ maps are not defined explicitly; they have the following structure:  \ maps are not defined explicitly; they have the following structure:
   
 \ pointers to interface maps (for classes) <- interface-map points here  \ pointers to interface maps (for classes) <- interface-map points here
 \ interface/class-struct pointer           <- (object-)map  points here  \ interface%/class% pointer                <- (object-)map  points here
 \ xts of methods   \ xts of methods 
   
   
Line 220  end-struct selector-struct Line 118  end-struct selector-struct
   
 \ selectors and methods  \ 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 ( -- )  : no-method ( -- )
     true abort" no method defined for this object/selector combination" ;      true abort" no method defined for this object/selector combination" ;
   
 : do-class-method ( -- )  : do-class-method ( -- )
 does> ( ... object -- ... )  does> ( ... object -- ... )
     ( object )      ( object selector-body )
     selector-offset @ over object-map @ + ( object xtp ) perform ;      selector-offset @ over object-map @ + ( object xtp ) perform ;
   
 : do-interface-method ( -- )  : do-interface-method ( -- )
Line 237  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" -- )  : method ( xt "name" -- ) \ objects- objects
     \ define selector with method xt      \g @code{name} execution: @code{... object -- ...}@*
       \g Create selector @var{name} and makes @var{xt} its method in
       \g the current class.
     create      create
     current-interface @ interface-map 2@ ( xt map-addr map-size )      current-interface @ interface-map 2@ ( xt map-addr map-size )
     dup current-interface @ interface-map-offset @ - ,      dup current-interface @ interface-map-offset @ - ,
Line 250  does> ( ... object -- ... ) Line 154  does> ( ... object -- ... )
         do-class-method          do-class-method
     then ;      then ;
   
 : selector ( "name" -- )  : selector ( "name" -- ) \ objects- objects
     \ define a method selector for later overriding in subclasses      \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 ;      ['] no-method method ;
   
 : interface-override! ( xt sel-xt interface-map -- )  : interface-override! ( xt sel-xt interface-map -- )
Line 259  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 )  : class->map ( class -- map ) \ objects- objects
     \ compute the (object-)map for the class      \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 @ + ;      dup interface-map 2@ drop swap interface-map-offset @ + ;
   
 : unique-interface-map ( class-map offset -- )  : unique-interface-map ( class-map offset -- )
Line 268  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 -- )  : class-override! ( xt sel-xt class-map -- ) \ objects- objects
     \ xt is the new method for the selector sel-xt in class-map      \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 )      over >body ( xt sel-xt class-map selector-body )
     selector-interface @ ( xt sel-xt class-map offset )      selector-interface @ ( xt sel-xt class-map offset )
     ?dup-if \ the selector is for an interface      ?dup-if \ the selector is for an interface
Line 287  does> ( ... object -- ... ) Line 197  does> ( ... object -- ... )
     then      then
     interface-override! ;      interface-override! ;
   
 : overrides ( xt "selector" -- )  : overrides ( xt "selector" -- ) \ objects- objects
     \ replace default method "method" in the current class with xt      \g replace default method for @var{selector} in the current class
     \ must not be used during an interface definition      \g with @var{xt}. @code{overrides} must not be used during an
       \g interface definition.
     ' current-interface @ class->map class-override! ;      ' current-interface @ class->map class-override! ;
   
 \ interfaces  \ interfaces
Line 297  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 ( -- )  : interface ( -- ) \ objects- objects
     interface-struct struct-allot >r      \g Start an interface definition.
     0 0 r@ interface-map 2!      interface% %allot >r
       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 )  : end-interface-noname ( -- interface ) \ objects- objects
       \g End an interface definition. The resulting interface is
       \g @var{interface}.
     current-interface @ ;      current-interface @ ;
   
 : end-interface ( "name" -- )  : end-interface ( "name" -- ) \ objects- objects
     \ name execution: ( -- interface )      \g @code{name} execution: @code{-- interface}@*
       \g End an interface definition. The resulting interface is
       \g @var{interface}.
     end-interface-noname constant ;      end-interface-noname constant ;
   
 \ classes  \ classes
Line 321  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 -- )  : push-order ( class -- ) \ objects- objects
     \ add the class's wordlist to the search-order (in front)      \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 ;
   
 : class ( parent-class -- size align )  : class ( parent-class -- align offset ) \ objects- objects
     class-struct struct-allot >r      \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 2@ save-mem r@ interface-map 2!
     dup interface-map-offset @ r@ interface-map-offset !      dup interface-map-offset @ r@ interface-map-offset !
     r@ dup class->map !      r@ dup class->map !
Line 345  variable last-interface-offset 0 last-in Line 264  variable last-interface-offset 0 last-in
     until      until
     drop ;      drop ;
   
 : drop-order ( class -- )  : drop-order ( class -- ) \ objects- objects
     \ note: no checks, whether the wordlists are correct      \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 ;      >r get-order r> remove-class-order set-order ;
   
 : end-class-noname ( size align -- class )  : end-class-noname ( align offset -- class ) \ objects- objects
       \g End a class definition. The resulting class is @var{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 ( size align "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 )      \ name execution: ( -- class )
     end-class-noname constant ;      end-class-noname constant ;
   
Line 361  variable last-interface-offset 0 last-in Line 285  variable last-interface-offset 0 last-in
   
 variable public-wordlist  variable public-wordlist
   
 : private ( -- )  : protected ( -- ) \ objects- objects
       \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 <>
     if \ we are not private already      if \ we are not protected already
         get-current public-wordlist !          get-current public-wordlist !
     then      then
     set-current ;      set-current ;
   
 : public ( -- )  : 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.
     public-wordlist @ set-current ;      public-wordlist @ set-current ;
   
 \ classes that implement interfaces  \ classes that implement interfaces
   
 : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )  : 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      \ old stuff coming at the end
     2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )      2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
     dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )      dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
     free throw      free throw
     r> dup r> ;      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 )      dup interface-offset @ ( interface offset )
     current-interface @ interface-map-offset @ negate over - dup 0>      current-interface @ interface-map-offset @ negate over - dup 0>
     if \ the interface does not fit in the present class-map      if \ the interface does not fit in the present class-map
Line 401  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 )  0 value this ( -- object ) \ objects- objects
 : to-this ( object -- )  \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 ;      TO this ;
   
 \ another implementation, if you don't have (fast) values  \ another implementation, if you don't have (fast) values
Line 412  variable public-wordlist Line 345  variable public-wordlist
 \ : to-this ( object -- )  \ : to-this ( object -- )
 \     thisp ! ;  \     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       :noname 
     POSTPONE this      POSTPONE this
     POSTPONE >r      POSTPONE >r
     POSTPONE to-this ;      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 r>
     POSTPONE to-this      POSTPONE to-this
     POSTPONE ; ; immediate      POSTPONE ; ; immediate
   
 : catch ( ... xt -- ... n )  : catch ( ... xt -- ... n ) \ exception
     \ make it safe to call CATCH within a method.      \ Make it safe to call CATCH within a method.
     \ should also be done with all words containing CATCH.      \ should also be done with all words containing CATCH.
     this >r catch r> to-this ;      this >r catch r> to-this ;
   
Line 432  variable public-wordlist Line 373  variable public-wordlist
 \ disallowing to change the compilation wordlist between CREATE and  \ disallowing to change the compilation wordlist between CREATE and
 \ DOES> (see RFI 3)  \ DOES> (see RFI 3)
   
 : inst-something ( size1 align1 size align xt "name" -- size2 align2 )  : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
     \ xt ( -- ) typically is for a DOES>-word      \ xt ( -- ) typically is for a DOES>-word
     get-current >r      get-current >r
     current-interface @ class-wordlist @ set-current      current-interface @ class-wordlist @ set-current
Line 443  variable public-wordlist Line 384  variable public-wordlist
 does> \ name execution: ( -- addr )  does> \ name execution: ( -- addr )
     ( addr1 ) @ this + ;      ( addr1 ) @ this + ;
   
 : inst-var ( size1 align1 size align "name" -- size2 align2 )  : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
     \ name execution: ( -- addr )      \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-var inst-something ;
   
 : do-inst-value ( -- )  : do-inst-value ( -- )
 does> \ name execution: ( -- w )  does> \ name execution: ( -- w )
     ( addr1 ) @ this + @ ;      ( addr1 ) @ this + @ ;
   
 : inst-value ( size1 align1 "name" -- size2 align2 )  : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects
     \ name execution: ( -- w )      \g @var{name} execution: @code{-- w}@*
     \ a cell-sized value-flavoured instance field      \g @var{w} is the value of the field @var{name} in @code{this}
     1 cells: ['] do-inst-value inst-something ;      \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 + ! ;      >body @ this + ! ;
   
 : to-inst ( w "name" -- )  : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
     ' <to-inst> ;      \g store @var{w} into field @var{name} in @code{this} object.
   
 : [to-inst] ( compile-time: "name" -- ; run-time: w -- )  
     ' >body @ POSTPONE literal      ' >body @ POSTPONE literal
     POSTPONE this      POSTPONE this
     POSTPONE +      POSTPONE +
     POSTPONE ! ; immediate      POSTPONE ! ; immediate
   
 \ early binding stuff  \ class binding stuff
   
 \ 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)  
   
 : <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 @      >body swap class->map over selector-interface @
     ?dup-if      ?dup-if
         + @          + @
     then      then
     swap selector-offset @ + @ ;      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> ;      ' execute ' <bind> ;
   
 : bind ( ... object "class" "selector" -- ... )  : bind ( ... "class" "selector" -- ... ) \ objects- objects
       \g Execute the method for @var{selector} in @var{class}.
     bind' execute ;      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      bind' compile, ; immediate
   
 : [super] ( compile-time: "selector" -- ; run-time: ... object -- ... )  : current' ( "selector" -- xt ) \ objects- objects
     \ same as `[bind] "parent" "selector"', where "parent" is the      \g @var{xt} is the method for @var{selector} in the current class.
     \ parent class of 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      current-interface @ class-parent @ ' <bind> compile, ; immediate
   
 \ the object class  \ the object class
Line 499  does> \ name execution: ( -- w ) Line 452  does> \ name execution: ( -- w )
 \ because OBJECT has no parent class, we have to build it by hand  \ because OBJECT has no parent class, we have to build it by hand
 \ (instead of with class)  \ (instead of with class)
   
 wordlist  class% %allot current-interface !
 here current-interface !  current-interface 1 cells save-mem current-interface @ interface-map 2!
 current-interface 1 cells save-mem 2, \ map now contains a pointer to class  0 current-interface @ interface-map-offset !
 0 ,  0 current-interface @ interface-offset !
 0 ,   0 current-interface @ class-parent !
 0 , \ parent  wordlist current-interface @ class-wordlist !
 , \ wordlist  object%
 object-struct 2, \ instance size  current-interface @ push-order
 object-struct  
   ' drop ( object -- )
 :noname ( object -- )  method construct ( ... object -- ) \ objects- objects
     drop ;  \g Initialize the data fields of @var{object}. The method for the
 method construct ( ... object -- )  \g class @var{object} just does nothing: @code{( object -- )}.
   
 :noname ( object -- )  :noname ( object -- )
     ." object:" dup . ." class:" object-map @ @ . ;      ." 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  \ 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 )      swap class->map over object-map ! ( ... object )
     construct ;      construct ;
   
 : xt-new ( ... class xt -- object )  : xt-new ( ... class xt -- object ) \ objects- objects
     \ makes a new object, using XT ( size align -- addr ) to allocate memory      \g Make a new object, using @code{xt ( align size -- addr )} to
       \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 )  : dict-new ( ... class -- object ) \ objects- objects
     \ makes a new object HERE in dictionary      \g @code{allot} and initialize an object of class @var{class} in
     ['] struct-allot xt-new ;      \g the dictionary.
       ['] %allot xt-new ;
 : heap-new ( ... class -- object )  
     \ makes a new object in ALLOCATEd memory  : heap-new ( ... class -- object ) \ objects- objects
     ['] struct-alloc xt-new ;      \g @code{allocate} and initialize an object of class @var{class}.
       ['] %alloc xt-new ;

Removed from v.1.3  
changed lines
  Added in v.1.12


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