[BACK]Return to objects.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/objects.fs between versions 1.1 and 1.14

version 1.1, 1996/11/11 16:59:17 version 1.14, 1999/07/05 18:54:20
Line 1 Line 1
 \ yet another Forth objects extension  \ yet another Forth objects extension
   
 \ written by Anton Ertl 1996  \ written by Anton Ertl 1996-1999
 \ public domain  \ public domain; NO WARRANTY
   
 \ This is in ANS Forth (with an environmental dependence on case  \ This (in combination with compat/struct.fs) is in ANS Forth (with an
 \ insensitivity; convert everything to upper case for state sensitive  \ environmental dependence on case insensitivity; convert everything
 \ systems). It needs some non-core words (in particular, it uses the  \ to upper case for state sensitive systems).
 \ memory allocation wordset), but I have not made a complete list.  
   \ compat/struct.fs and this file together use the following words:
 \ Manual:  
   \ from CORE :
 \ A class is defined like this:  \ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r
   \ r> IF ELSE THEN over chars aligned cells 2* here - allot execute
 \ <parent> class  \ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +!
 \   ... field <name>  \ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." .
 \   ...  \ from CORE-EXT :
   \ tuck pick nip true <> 0> erase Value :noname compile, 
 \   ... inst-var <name>  \ from BLOCK-EXT :
 \   ...  \ \ 
   \ from DOUBLE :
 \ selector <name>  \ 2Constant 
   \ from EXCEPTION :
 \ :noname ( ... object -- ... )  \ throw catch 
 \   ... ;  \ from EXCEPTION-EXT :
 \ method <name> \ new method  \ abort" 
 \ ...  \ from FILE :
   \ ( 
 \ :noname ( ... object -- ... )  \ from FLOAT :
 \   ... ;  \ faligned floats 
 \ overrides <name> \ existing method  \ from FLOAT-EXT :
 \ ...  \ dfaligned dfloats sfaligned sfloats 
   \ from LOCAL :
 \ end-class <name>  \ TO 
   \ from MEMORY :
 \ you can write fields, inst-vars, selectors, methods and overrides in  \ allocate resize free 
 \ any order.  \ from SEARCH :
   \ get-order set-order wordlist get-current set-current 
 \ 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>  
 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\  
   
 \ 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 ;
   
 : perform ( ... addr -- ... )  : perform ( ... addr -- ... )
     @ execute ;      @ execute ;
   
   : ?dup-if ( compilation: -- orig ; run-time: n -- n|  )
       POSTPONE ?dup POSTPONE if ; immediate
   
 : save-mem      ( addr1 u -- addr2 u ) \ gforth  : save-mem      ( addr1 u -- addr2 u ) \ gforth
     \ copy a memory block into a newly allocated region in the heap      \ copy a memory block into a newly allocated region in the heap
     swap >r      swap >r
     dup allocate throw      dup allocate throw
     swap 2dup r> -rot move ;      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-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]
   
 : const-field ( size1 align1 -- size2 align2 )  \ data structures
     1 cells: field  
 does> ( addr -- w )  
     @ + @ ;  
   
 struct  struct
     1 cells: field object-map      cell% field object-map
 end-struct object-struct  end-struct object%
   
 struct  struct
     2 cells: field class-map      cell% 2* field interface-map
     const-field class-instance-size \ aus      cell%    field interface-map-offset \ aus
     const-field class-instance-align \ aus        \ difference between where interface-map points and where
 end-struct class-struct        \ object-map points (0 for non-classes)
       cell%    field interface-offset \ aus
 2variable current-map \ address and size (in aus) of the current map        \ offset of interface map-pointer in class-map (0 for classes)
   end-struct interface%
 : class ( class -- size align )  
     dup class-map 2@ save-mem current-map 2!  interface%
     dup class-instance-size      cell%    field class-parent
     swap class-instance-align ;      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 ( -- )  : no-method ( -- )
     abort" no method defined" ;      true abort" no method defined for this object/selector combination" ;
   
 : method ( xt "name" -- )  : do-class-method ( -- )
     \ define method and selector  
     current-map 2@ ( xt map-addr map-size )  
     create dup ,  
     1 cells extend-mem current-map 2!  
     !  
 does> ( ... object -- ... )  does> ( ... object -- ... )
     ( object addr )      ( object selector-body )
     @ over ( object-map ) @ + ( object xtp ) perform ;      selector-offset @ over object-map @ + ( object xtp ) perform ;
   
 : selector ( "name" -- )  : do-interface-method ( -- )
     \ define a method selector for later overriding in subclasses  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 ;      ['] no-method method ;
   
 : override! ( xt method-xt -- )  : interface-override! ( xt sel-xt interface-map -- )
     >body @ current-map 2@ drop + ! ;      \ xt is the new method for the selector sel-xt in interface-map
       swap >body ( xt map selector-body )
 : overrides ( xt "selector" -- )      selector-offset @ + ! ;
     \ replace default method "method" with xt  
     ' override! ;  : class->map ( class -- map ) \ objects- objects
       \g @var{map} is the pointer to @var{class}'s method map; it
 : alloc-instance ( class -- object )      \g points to the place in the map to which the selector offsets
     \ make a new, (almost) uninitialized instance of a class      \g refer (i.e., where @var{object-map}s point to).
     dup class-instance-size allocate throw      dup interface-map 2@ drop swap interface-map-offset @ + ;
     swap class-map 2@ drop over ( object-map ) ! ;  
   : 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+ ;
   
   : 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 ;
   
   : 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 !
       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 ;
   
   : 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-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 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.  \ this/self, instance variables etc.
   
 variable thisp  \ rename "this" into "self" if you are a Smalltalk fiend
 : this ( -- object )  0 value this ( -- object ) \ objects- objects
     \ rename this into self if you are a Smalltalk fiend  \g the receiving object of the current method (aka active object).
     thisp @ ;  : 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 -- )  : 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 thisp      POSTPONE to-this ;
     POSTPONE ! ;  
   : 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 r>
     POSTPONE thisp      POSTPONE to-this
     POSTPONE !  
     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> thisp ! ;      this >r catch r> to-this ;
   
 : inst-var ( size1 align1 size align -- size2 align2 )  \ the following is a bit roundabout; this is caused by the standard
     field  \ disallowing to change the compilation wordlist between CREATE and
 does> ( -- addr )  \ DOES> (see RFI 3)
     ( addr1 ) @ this + ;  
   : 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  : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
 \ superclass method invocation (so that you don't have to name your methods)      \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 )  \ class binding stuff
     >body @ swap class-map 2@ drop + @ ;  
   
 : bind' ( "class" "method" -- xt )  : <bind> ( class selector-xt -- xt ) \ objects- objects
     ' >body ' (bind) ;      \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' 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      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  \ the object class
   
 0 0 save-mem current-map 2!  \ because OBJECT has no parent class, we have to build it by hand
 object-struct \ no class to inherit from, so we have to do this manually  \ (instead of with class)
 :noname ( object -- )  
     ." object:" dup . ." class:" object-map @ . ;  
 method print  
 end-class object  
   
 \ examples  
 true [if]  
 cr object alloc-instance print  
   
 object class  class% %allot current-interface !
 :noname ( object -- )  current-interface 1 cells save-mem current-interface @ interface-map 2!
     drop ." undefined" ;  0 current-interface @ interface-map-offset !
 overrides print  0 current-interface @ interface-offset !
 end-class nothing  0 current-interface @ class-parent !
   wordlist current-interface @ class-wordlist !
 nothing alloc-instance constant undefined  object%
   current-interface @ push-order
 cr undefined print  
   ' drop ( object -- )
 \ instance variables and this  method construct ( ... object -- ) \ objects- objects
 object class  \g Initialize the data fields of @var{object}. The method for the
 1 cells: inst-var count-n  \g class @var{object} just does nothing: @code{( object -- )}.
 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 ;  
   
 cr undefined object-print  :noname ( object -- )
 [then]      ." 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.
   
   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 ;
Removed from v.1.1  
changed lines
  Added in v.1.14

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