[gforth] / gforth / objects.fs  

gforth: gforth/objects.fs

Diff for /gforth/objects.fs between version 1.5 and 1.18

version 1.5, Wed Jul 2 15:56:51 1997 UTC version 1.18, Wed Aug 23 21:03:52 2000 UTC
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-1999
 \ public domain; NO WARRANTY  \ 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
Line 41 
Line 41 
   
 \ 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 ;
   
Line 70 
Line 74 
     over >r + dup >r resize throw      over >r + dup >r resize throw
     r> over r> + -rot ;      r> over r> + -rot ;
   
   : \g ( -- )
       postpone \ ; immediate
   [then]
   
 \ data structures  \ data structures
   
 struct  struct
Line 88 
Line 96 
 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 \ size and alignment      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%  end-struct class%
   
 struct  struct
Line 107 
Line 118 
   
 \ 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" ;
Line 124 
Line 139 
     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 137 
Line 154 
         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 146 
Line 166 
     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 155 
Line 177 
     \ 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 174 
Line 197 
     then      then
     interface-override! ;      interface-override! ;
   
 : overrides ( xt "selector" -- )  : overrides ( xt "selector" -- ) \ objects- objects
     \ replace default method for "selector" 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 184 
Line 208 
 \ 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
       \g Start 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 )  : 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 ;
   
   \ 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  \ classes
   
 : add-class-order ( n1 class -- wid1 ... widn n+n1 )  : add-class-order ( n1 class -- wid1 ... widn n+n1 )
Line 208 
Line 259 
     then      then
     r> class-wordlist @ swap 1+ ;      r> class-wordlist @ swap 1+ ;
   
 : push-order ( class -- )  : class>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 -- align size )  : push-order class>order ; \ old name
   
   : methods ( class -- ) \ objects- objects
       \g Makes @var{class} the current class. This is intended to be
       \g used for defining methods to override selectors; you cannot
       \g define new fields or selectors.
       dup current-interface ! class>order ;
   
   : class ( parent-class -- align offset ) \ objects- objects
       \g Start a new class definition as a child of
       \g @var{parent-class}. @var{align offset} are for use by
       \g @var{field} etc.
     class% %allot >r      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 !
Line 220 
Line 282 
     0 r@ interface-offset !      0 r@ interface-offset !
     dup r@ class-parent !      dup r@ class-parent !
     wordlist r@ class-wordlist !      wordlist r@ class-wordlist !
     r@ current-interface !      r> methods
     r> push-order  
     class-inst-size 2@ ;      class-inst-size 2@ ;
   
 : remove-class-order ( wid1 ... widn n+n1 class -- n1 )  : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
Line 232 
Line 293 
     until      until
     drop ;      drop ;
   
 : drop-order ( class -- )  : class-previous ( 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 ( align size -- class )  : drop-order class-previous ; \ old name
     current-interface @ dup drop-order class-inst-size 2!  
   : end-methods ( -- ) \ objects- objects
       \g Switch back from defining methods of a class to normal mode
       \g (currently this just restores the old search order).
       current-interface @ class-previous ;
   
   : end-class-noname ( align offset -- class ) \ objects- objects
       \g End a class definition. The resulting class is @var{class}.
       public end-methods
       current-interface @ class-inst-size 2!
     end-interface-noname ;      end-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 )      \ name execution: ( -- class )
     end-class-noname constant ;      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  \ 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 288 
Line 350 
 \ 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 299 
Line 363 
 \ : to-this ( object -- )  \ : to-this ( object -- )
 \     thisp ! ;  \     thisp ! ;
   
 : m: ( -- xt colon-sys ) ( run-time: object -- )  : enterm ( -- ; run-time: object -- )
     :noname      \g method prologue; @var{object} becomes new @code{this}.
     POSTPONE this      POSTPONE this
     POSTPONE >r      POSTPONE >r
     POSTPONE to-this ;      POSTPONE to-this ;
   
 : exitm ( -- )  : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects
       \g Start a method definition; @var{object} becomes new @code{this}.
       :noname enterm ;
   
   : :m ( "name" -- xt; run-time: object -- ) \ objects- objects
       \g Start a named method definition; @var{object} becomes new
       \g @code{this}.  Has to be ended with @code{;m}.
       : enterm ;
   
   : exitm ( -- ) \ objects- objects
       \g @code{exit} from a method; restore old @code{this}.
     POSTPONE r>      POSTPONE r>
     POSTPONE to-this      POSTPONE to-this
     POSTPONE exit ; immediate      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 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 335 
Line 410 
 does> \ name execution: ( -- addr )  does> \ name execution: ( -- addr )
     ( addr1 ) @ this + ;      ( addr1 ) @ this + ;
   
 : inst-var ( align1 offset1 align size "name" -- align2 offset2 )  : 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 ( align1 offset1 "name" -- align2 offset2 )  : 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}
       \g object.
     cell% ['] do-inst-value inst-something ;      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] ( 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      ' >body @ POSTPONE literal
     POSTPONE this      POSTPONE this
     POSTPONE +      POSTPONE +
Line 359 
Line 439 
   
 \ class binding stuff  \ 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 @      >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 ( ... "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
   
 : 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-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      current' compile, ; immediate
   
 : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... )  : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
     \ same as `[bind] "parent" "selector"', where "parent" is the      \g Compile the method for @var{selector} in the parent of the
     \ parent class of the current class      \g current class.
     current-interface @ class-parent @ ' <bind> compile, ; immediate      current-interface @ class-parent @ ' <bind> compile, ; immediate
   
 \ the object class  \ the object class
Line 398 
Line 485 
 0 current-interface @ class-parent !  0 current-interface @ class-parent !
 wordlist current-interface @ class-wordlist !  wordlist current-interface @ class-wordlist !
 object%  object%
 current-interface @ push-order  current-interface @ class>order
   
 ' drop ( object -- )  ' drop ( object -- )
 method construct ( ... 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 -- )  :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.
   
   selector equal ( object1 object2 -- flag )
   
 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 ( align size -- 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
       \g the dictionary.
     ['] %allot xt-new ;      ['] %allot xt-new ;
   
 : heap-new ( ... class -- object )  : heap-new ( ... class -- object ) \ objects- objects
     \ makes a new object in ALLOCATEd memory      \g @code{allocate} and initialize an object of class @var{class}.
     ['] %alloc xt-new ;      ['] %alloc xt-new ;

Generate output suitable for use with a patch program
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.18
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help