Diff for /gforth/oof.fs between versions 1.5 and 1.6

version 1.5, 1997/01/25 20:53:02 version 1.6, 1997/01/29 21:32:37
Line 157  Objects definitions Line 157  Objects definitions
     dup  IF    2@ >r recurse r> :ilist + @ swap 1+      dup  IF    2@ >r recurse r> :ilist + @ swap 1+
          ELSE  drop  THEN ;           ELSE  drop  THEN ;
   
 : add-order ( addr -- n )  dup 0= ?EXIT  >r  : add-order ( addr -- n )  >r
     get-order r> swap >r 0 swap      get-order r> swap >r 0 swap object-order
     dup >r object-order r> :iface + @ interface-order  
     r> over >r + set-order r> ;      r> over >r + set-order r> ;
   
 : drop-order ( n -- )  0 ?DO  previous  LOOP ;  : drop-order ( n -- )  0 ?DO  previous  LOOP ;
Line 174  Objects definitions Line 173  Objects definitions
   drop dup early?  IF >body @  THEN  compile, ;    drop dup early?  IF >body @  THEN  compile, ;
   
 : findo    ( string -- cfa n )  : findo    ( string -- cfa n )
     o@ add-order >r      >r get-order 0
     find      o@ object-order
       o@ :iface + @ interface-order set-order
       r> find
     ?dup 0= IF drop set-order true abort" method not found!" THEN      ?dup 0= IF drop set-order true abort" method not found!" THEN
     r> drop-order ;      >r >r set-order r> r> ;
   
 false Value method?  false Value method?
 false Value oset?  
   
 : method,  ( object early? -- )  true to method?  : method,  ( object early? -- )  true to method?
     swap >o >r bl word  findo  0< state @ and      swap >o >r bl word  findo  0< state @ and
     IF  r> o,  ELSE  r> drop execute  THEN  o> false to method?  ;      IF  r> o,  ELSE  r> drop execute  THEN  o> false to method?  ;
   
 : early, ( object -- )  true to oset?  true  method,  : early, ( object -- )  true  method,
   state @ IF  postpone o>  THEN  false to oset? ;    state @ IF  postpone o>  THEN  ;
 : late,  ( object -- )  true to oset?  false method,  : late,  ( object -- )  false method,
   state @ IF  postpone o>  THEN  false to oset? ;    state @ IF  postpone o>  THEN  ;
   
 \ new,                                                 29oct94py  \ new,                                                 29oct94py
   
Line 273  Objects definitions Line 272  Objects definitions
   DOES> state @ IF  dup postpone Literal postpone >o  THEN early, ;    DOES> state @ IF  dup postpone Literal postpone >o  THEN early, ;
 : ptr,      ( o -- )  0 , ,  : ptr,      ( o -- )  0 , ,
   DOES>  state @    DOES>  state @
     IF    dup postpone Literal postpone @ postpone >o cell+      IF    postpone Literal postpone @ postpone >o cell+
     ELSE  @  THEN late, ;      ELSE  @  THEN late, ;
   
 : array,  ( n o -- )  alloc @ >r static new[], r> alloc ! drop  : array,  ( n o -- )  alloc @ >r static new[], r> alloc ! drop
Line 373  Variable last-interface  0 last-interfac Line 372  Variable last-interface  0 last-interfac
   
 : lastob!  ( -- )  lastob @ dup  : lastob!  ( -- )  lastob @ dup
     BEGIN  nip dup @ here cell+ 2 pick ! dup 0= UNTIL  drop      BEGIN  nip dup @ here cell+ 2 pick ! dup 0= UNTIL  drop
     dup , op! o@ lastob ! ;      dup , [ order ] op! o@ lastob ! ;
   
 : thread,  ( -- )  classlist @ , ;  : thread,  ( -- )  classlist @ , ;
 : var,     ( -- )  methods @ , vars @ , ;  : var,     ( -- )  methods @ , vars @ , ;
Line 452  Create object  immediate  0 (class \ do Line 451  Create object  immediate  0 (class \ do
          early     link        immediate           early     link        immediate
          early     '           immediate           early     '           immediate
          early     send        immediate           early     send        immediate
          early     with        immediate  
          early     endwith     immediate  
                     
 \ base object class implementation part                23mar95py  \ base object class implementation part                23mar95py
   
 how:    0 parento !  how:     0 parento !
         0 childo !           0 childo !
         0 nexto !           0 nexto !
         : class   ( -- )       Create immediate o@ (class ;           : class   ( -- )       Create immediate o@ (class ;
         : :       ( -- )       Create immediate o@           : :       ( -- )       Create immediate o@
           decl @ IF  instvar,    ELSE  instance,  THEN ;               decl @ IF  instvar,    ELSE  instance,  THEN ;
         : ptr     ( -- )       Create immediate o@           : ptr     ( -- )       Create immediate o@
           decl @ IF  instptr,    ELSE  ptr,       THEN ;             decl @ IF  instptr,    ELSE  ptr,       THEN ;
         : asptr   ( addr -- )           : asptr   ( addr -- )
           decl @ 0= abort" only in declaration!"             decl @ 0= abort" only in declaration!"
           Create immediate o@ , cell+ @ , instptr> ;             Create immediate o@ , cell+ @ , instptr> ;
         : []      ( n -- )     Create immediate o@           : []      ( n -- )     Create immediate o@
           decl @ IF  instarray,  ELSE  array,     THEN ;             decl @ IF  instarray,  ELSE  array,     THEN ;
         : new     ( -- o )     o@ state @           : new     ( -- o )     o@ state @
           IF  postpone Literal postpone new,  ELSE  new,  THEN ;             IF  postpone Literal postpone new,  ELSE  new,  THEN ;
         : new[]   ( n -- o )   o@ state @           : new[]   ( n -- o )   o@ state @
           IF postpone Literal postpone new[], ELSE new[], THEN ;             IF postpone Literal postpone new[], ELSE new[], THEN ;
         : dispose ( -- )       ^ size @ dispose, ;           : dispose ( -- )       ^ size @ dispose, ;
         : bind    ( addr -- )  (bind ;           : bind    ( addr -- )  (bind ;
         : bound   ( o1 o2 addr2  -- ) (bound ;           : bound   ( o1 o2 addr2  -- ) (bound ;
         : link    ( -- o addr ) (link ;           : link    ( -- o addr ) (link ;
         : class?  ( class -- flag )  ^ parent? nip 0<> ;           : class?  ( class -- flag )  ^ parent? nip 0<> ;
         : ::      ( -- )           : ::      ( -- )
           state @ IF  ^ true method,  ELSE  inherit  THEN ;             state @ IF  ^ true method,  ELSE  inherit  THEN ;
         : super   ( -- )       parento true method, ;           : super   ( -- )       parento true method, ;
         : is      ( cfa -- )   (is ;           : is      ( cfa -- )   (is ;
         : self    ( -- obj )   ^ ;           : self    ( -- obj )   ^ ;
         : init    ( -- )       ;           : init    ( -- )       ;
   
         : '       ( -- xt )  bl word findo 0= abort" not found!"           : '       ( -- xt )  bl word findo 0= abort" not found!"
           state @ IF  postpone Literal  THEN ;             state @ IF  postpone Literal  THEN ;
         : send    ( xt -- )  execute ;           : send    ( xt -- )  execute ;
   
         : with ( -- )  
           state @ oset? 0= and IF  postpone >o  THEN  
           o@ add-order voc# ! false to oset?  
           rdrop state @  
           IF    o>  
           ELSE  oset? IF  ^ THEN  o> postpone >o  
           THEN  
           rdrop rdrop ;  
         : endwith  postpone o>   
           voc# @ drop-order ;  
 class; \ object  class; \ object
   
 \ interface                                            01sep96py  \ interface                                            01sep96py

Removed from v.1.5  
changed lines
  Added in v.1.6


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