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

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

version 1.12, 1999/02/16 06:32:29 version 1.19, 2000/09/23 15:06:01
Line 1 Line 1
 \ yet another Forth objects extension  \ yet another Forth objects extension
   
 \ written by Anton Ertl 1996-1998  \ written by Anton Ertl 1996-2000
 \ 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 228  variable last-interface-offset 0 last-in Line 228  variable last-interface-offset 0 last-in
     \g @var{interface}.      \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 237  variable last-interface-offset 0 last-in Line 259  variable last-interface-offset 0 last-in
     then      then
     r> class-wordlist @ swap 1+ ;      r> class-wordlist @ swap 1+ ;
   
 : push-order ( class -- ) \ objects- objects  : class>order ( class -- ) \ objects- objects
     \g Add @var{class}'s wordlists to the head of the search-order.      \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 ;
   
   : 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  : class ( parent-class -- align offset ) \ objects- objects
     \g Start a new class definition as a child of      \g Start a new class definition as a child of
     \g @var{parent-class}. @var{align offset} are for use by      \g @var{parent-class}. @var{align offset} are for use by
Line 252  variable last-interface-offset 0 last-in Line 282  variable last-interface-offset 0 last-in
     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 264  variable last-interface-offset 0 last-in Line 293  variable last-interface-offset 0 last-in
     until      until
     drop ;      drop ;
   
 : drop-order ( class -- ) \ objects- objects  : class-previous ( class -- ) \ objects- objects
     \g Drop @var{class}'s wordlists from the search order. No      \g Drop @var{class}'s wordlists from the search order. No
     \g checking is made whether @var{class}'s wordlists are actually      \g checking is made whether @var{class}'s wordlists are actually
     \g on the search order.      \g on the search order.
     >r get-order r> remove-class-order set-order ;      >r get-order r> remove-class-order set-order ;
   
   : drop-order class-previous ; \ old name
   
   : 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  : end-class-noname ( align offset -- class ) \ objects- objects
     \g End a class definition. The resulting class is @var{class}.      \g End a class definition. The resulting class is @var{class}.
     current-interface @ dup drop-order class-inst-size 2!      public end-methods
       current-interface @ class-inst-size 2!
     end-interface-noname ;      end-interface-noname ;
   
 : end-class ( align offset "name" -- ) \ objects- objects  : end-class ( align offset "name" -- ) \ objects- objects
Line 281  variable last-interface-offset 0 last-in Line 318  variable last-interface-offset 0 last-in
     \ name execution: ( -- class )      \ name execution: ( -- class )
     end-class-noname constant ;      end-class-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.  
     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 )
Line 345  variable public-wordlist Line 363  variable public-wordlist
 \ : to-this ( object -- )  \ : to-this ( object -- )
 \     thisp ! ;  \     thisp ! ;
   
 : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects  : enterm ( -- ; run-time: object -- )
     \g Start a method definition; @var{object} becomes new @code{this}.      \g method prologue; @var{object} becomes new @code{this}.
     :noname   
     POSTPONE this      POSTPONE this
     POSTPONE >r      POSTPONE >r
     POSTPONE to-this ;      POSTPONE to-this ;
       
   : 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  : exitm ( -- ) \ objects- objects
     \g @code{exit} from a method; restore old @code{this}.      \g @code{exit} from a method; restore old @code{this}.
Line 459  current-interface 1 cells save-mem curre Line 485  current-interface 1 cells save-mem curre
 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 -- ) \ objects- objects  method construct ( ... object -- ) \ objects- objects
Line 472  method print ( object -- ) \ objects- ob Line 498  method print ( object -- ) \ objects- ob
 \g Print the object. The method for the class @var{object} prints  \g Print the object. The method for the class @var{object} prints
 \g the address of the object and the address of its class.  \g the address of the object and the address of its class.
   
   selector equal ( object1 object2 -- flag )
   
 end-class object ( -- class ) \ objects- objects  end-class object ( -- class ) \ objects- objects
 \g the ancestor of all classes.  \g the ancestor of all classes.
   
Removed from v.1.12  
changed lines
  Added in v.1.19

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