[gforth] / gforth / objects.fs  

gforth: gforth/objects.fs

Diff for /gforth/objects.fs between version 1.3 and 1.4

version 1.3, Fri Jun 6 17:27:57 1997 UTC version 1.4, Mon Jun 23 15:53:53 1997 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, 1997
 \ 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
Line 151 
Line 44 
 : -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 )  : under+ ( a b c -- a+c b )
     rot + swap ;      rot + swap ;
   
 : perform ( ... addr -- ... )  : perform ( ... addr -- ... )
Line 176 
Line 69 
   
 : 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  
     here 2 cells allot 2! ;  
   
 \ 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 \ instance variables and other private words
     2 cells: field class-inst-size \ size and alignment      cell% 2* field class-inst-size \ size and alignment
 end-struct class-struct  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 298 
Line 188 
 variable last-interface-offset 0 last-interface-offset !  variable last-interface-offset 0 last-interface-offset !
   
 : interface ( -- )  : interface ( -- )
     interface-struct struct-allot >r      interface% %allot >r
     0 0 r@ interface-map 2!      0 0 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 !
Line 325 
Line 215 
     \ add the class's wordlist to the search-order (in front)      \ add the class's wordlist 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 -- size align )  : class ( parent-class -- align size )
     class-struct struct-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 !
     r@ dup class->map !      r@ dup class->map !
Line 349 
Line 239 
     \ note: no checks, whether the wordlists are correct      \ note: no checks, whether the wordlists are correct
     >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 size -- 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 size "name" -- )
     \ name execution: ( -- class )      \ name execution: ( -- class )
     end-class-noname constant ;      end-class-noname constant ;
   
Line 361 
Line 251 
   
 variable public-wordlist  variable public-wordlist
   
 : private ( -- )  : protected ( -- )
     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 ;
Line 432 
Line 322 
 \ 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 
Line 333 
 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 )
     \ name execution: ( -- addr )      \ name execution: ( -- addr )
     ['] do-inst-var inst-something ;      ['] do-inst-var inst-something ;
   
Line 451 
Line 341 
 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 )
     \ name execution: ( -- w )      \ name execution: ( -- w )
     \ a cell-sized value-flavoured instance field      \ a cell-sized value-flavoured instance field
     1 cells: ['] do-inst-value inst-something ;      cell% ['] do-inst-value inst-something ;
   
 : <to-inst> ( w xt -- )  : <to-inst> ( w xt -- )
     >body @ this + ! ;      >body @ this + ! ;
   
 : to-inst ( w "name" -- )  
     ' <to-inst> ;  
   
 : [to-inst] ( compile-time: "name" -- ; run-time: w -- )  : [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 )
     >body swap class->map over selector-interface @      >body swap class->map over selector-interface @
Line 489 
Line 373 
 : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )  : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )
     bind' compile, ; immediate      bind' compile, ; immediate
   
 : [super] ( compile-time: "selector" -- ; run-time: ... object -- ... )  : current' ( "selector" -- xt )
       current-interface @ ' <bind> ;
   
   : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... )
       current' compile, ; immediate
   
   : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... )
     \ same as `[bind] "parent" "selector"', where "parent" is the      \ same as `[bind] "parent" "selector"', where "parent" is the
     \ parent class of the current class      \ parent class of the current class
     current-interface @ class-parent @ ' <bind> compile, ; immediate      current-interface @ class-parent @ ' <bind> compile, ; immediate
Line 499 
Line 389 
 \ 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  
   
 :noname ( object -- )  :noname ( object -- )
     drop ;      drop ;
Line 526 
Line 415 
     construct ;      construct ;
   
 : xt-new ( ... class xt -- object )  : xt-new ( ... class xt -- object )
     \ makes a new object, using XT ( size align -- addr ) to allocate memory      \ makes a new object, using XT ( align size -- addr ) to allocate 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 )
     \ makes a new object HERE in dictionary      \ makes a new object HERE in dictionary
     ['] struct-allot xt-new ;      ['] %allot xt-new ;
   
 : heap-new ( ... class -- object )  : heap-new ( ... class -- object )
     \ makes a new object in ALLOCATEd memory      \ makes a new object in ALLOCATEd memory
     ['] struct-alloc xt-new ;      ['] %alloc xt-new ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help