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

version 1.5, 1997/01/25 20:53:02 version 1.11, 1997/08/02 20:19:05
Line 7 Line 7
 \  \
 \               Thank you.  \               Thank you.
 \  \
   \ The program uses the following words
   \ from CORE :
   \ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF
   \ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop
   \ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and
   \ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1-
   \ rshift > / ' move UNTIL or count 
   \ from CORE-EXT :
   \ nip tuck true ?DO compile, false Value erase pick :noname 0<> 
   \ from BLOCK-EXT :
   \ \ 
   \ from EXCEPTION :
   \ throw 
   \ from EXCEPTION-EXT :
   \ abort" 
   \ from FILE :
   \ ( S" 
   \ from FLOAT :
   \ faligned 
   \ from LOCAL :
   \ TO 
   \ from MEMORY :
   \ allocate free 
   \ from SEARCH :
   \ find definitions get-order set-order get-current wordlist set-current
   \ search-wordlist 
   \ from SEARCH-EXT :
   \ also Forth previous 
   \ from STRING :
   \ /string compare 
   \ from TOOLS-EXT :
   \ [IF] [THEN] [ELSE] state 
   
 \ Loadscreen                                           27dec95py  \ Loadscreen                                           27dec95py
   
Line 15  decimal Line 47  decimal
 : define?  ( -- flag )  : define?  ( -- flag )
   bl word find  nip 0= ;    bl word find  nip 0= ;
   
 define? cell  [IF]  1 cells Constant cell  [THEN]  define? cell  [IF]
   1 cells Constant cell
   [THEN]
   
 define? ?EXIT [IF]  define? ?EXIT [IF]
 : ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate  : ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate
Line 26  define? Vocabulary [IF] Line 60  define? Vocabulary [IF]
 DOES> @ >r get-order nip r> swap set-order ;  DOES> @ >r get-order nip r> swap set-order ;
 [THEN]  [THEN]
   
   define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]
   [IF]
   : 8aligned ( n1 -- n2 )  faligned ;
   [ELSE]
   : 8aligned ( n1 -- n2 )  7 + -8 and ;
   [THEN]
   
 Vocabulary Objects  also Objects also definitions  Vocabulary Objects  also Objects also definitions
   
 Vocabulary types  types also  Vocabulary types  types also
Line 85  Objects definitions Line 126  Objects definitions
 : defer?   ( addr -- flag )  : defer?   ( addr -- flag )
   >body cell+ @ #defer  = ;    >body cell+ @ #defer  = ;
   
 define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]  false Value oset?
 [IF]   : 8aligned ( n1 -- n2 )  faligned ;  
 [ELSE] : 8aligned ( n1 -- n2 )  7 + -8 and ;  
 [THEN]  
   
 : o+,   ( addr offset -- )  : o+,   ( addr offset -- )
   postpone Literal postpone ^ postpone +    postpone Literal postpone ^ postpone +
   postpone >o drop ;    oset? IF  postpone op!  ELSE  postpone >o  THEN  drop ;
 : o*,   ( addr offset -- )  : o*,   ( addr offset -- )
   postpone Literal postpone * postpone Literal postpone +    postpone Literal postpone * postpone Literal postpone +
   postpone >o ;    oset? IF  postpone op!  ELSE  postpone >o  THEN ;
 : ^+@  ( offset -- addr )  ^ + @ ;  : ^+@  ( offset -- addr )  ^ + @ ;
 : o+@,  ( addr offset -- )  : o+@,  ( addr offset -- )
     postpone Literal postpone ^+@  postpone >o drop ;      postpone Literal postpone ^+@  oset? IF  postpone op!  ELSE  postpone >o  THEN drop ;
 : ^*@  ( offset -- addr )  ^ + @ tuck @ :var# + @ 8aligned * + ;  : ^*@  ( offset -- addr )  ^ + @ tuck @ :var# + @ 8aligned * + ;
 : o+@*, ( addr offset -- )  : o+@*, ( addr offset -- )
   postpone Literal postpone ^*@  postpone >o drop ;    postpone Literal postpone ^*@  oset? IF  postpone op!  ELSE  postpone >o  THEN drop ;
   
 \ variables / memory allocation                        30oct94py  \ variables / memory allocation                        30oct94py
   
Line 180  Objects definitions Line 218  Objects definitions
     r> drop-order ;      r> drop-order ;
   
 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?  ;
   
   : cmethod,  ( object early? -- )
       state @ >r state on  method, r> state ! ;
   
 : early, ( object -- )  true to oset?  true  method,  : early, ( object -- )  true to oset?  true  method,
   state @ IF  postpone o>  THEN  false to oset? ;    state @ oset? and IF  postpone o>  THEN  false to oset? ;
 : late,  ( object -- )  true to oset?  false method,  : late,  ( object -- )  true to oset?  false method,
   state @ IF  postpone o>  THEN  false to oset? ;    state @ oset? and IF  postpone o>  THEN  false to oset? ;
   
 \ new,                                                 29oct94py  \ new,                                                 29oct94py
   
Line 270  Objects definitions Line 310  Objects definitions
 \ instance creation                                    29mar94py  \ instance creation                                    29mar94py
   
 : instance, ( o -- )  alloc @ >r static new, r> alloc ! drop  : instance, ( o -- )  alloc @ >r static new, r> alloc ! drop
   DOES> state @ IF  dup postpone Literal postpone >o  THEN early, ;    DOES> state @ IF  dup postpone Literal oset? IF  postpone op!  ELSE  postpone >o  THEN  THEN early, ;
 : ptr,      ( o -- )  0 , ,  : ptr,      ( o -- )  0 , ,
   DOES>  state @    DOES>  state @
     IF    dup postpone Literal postpone @ postpone >o cell+      IF    dup postpone Literal postpone @ oset? IF  postpone op!  ELSE  postpone >o  THEN 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 404  types definitions Line 444  types definitions
 : asptr ( addr -- )  cell+ @ Create immediate  : asptr ( addr -- )  cell+ @ Create immediate
   lastob @ here lastob ! , ,  instptr> ;    lastob @ here lastob ! , ,  instptr> ;
   
   : Fpostpone  postpone postpone ; immediate
   
 : : ( <methodname> -- )  decl @ abort" HOW: missing! "  : : ( <methodname> -- )  decl @ abort" HOW: missing! "
     bl word findo 0= abort" not found"      bl word findo 0= abort" not found"
     dup exec? over early? or over >body cell+ @ 0< or      dup exec? over early? or over >body cell+ @ 0< or
Line 447  Create object  immediate  0 (class \ do Line 489  Create object  immediate  0 (class \ do
          early     super       immediate           early     super       immediate
          early     self           early     self
          early     bind        immediate           early     bind        immediate
          early     is          immediate  
          early     bound           early     bound
          early     link        immediate           early     link        immediate
          early     '           immediate           early     is          immediate
          early     send        immediate           early     send        immediate
          early     with        immediate           early     with        immediate
          early     endwith     immediate           early     endwith     immediate
            early     '           immediate
            early     postpone    immediate
            early     definitions
                     
 \ base object class implementation part                23mar95py  \ base object class implementation part                23mar95py
   
 how:    0 parento !  how:
         0 childo !  0 parento !
         0 nexto !  0 childo !
         : class   ( -- )       Create immediate o@ (class ;  0 nexto !
         : :       ( -- )       Create immediate o@      : class   ( -- )       Create immediate o@ (class ;
           decl @ IF  instvar,    ELSE  instance,  THEN ;      : :       ( -- )       Create immediate o@
         : ptr     ( -- )       Create immediate o@          decl @ IF  instvar,    ELSE  instance,  THEN ;
           decl @ IF  instptr,    ELSE  ptr,       THEN ;      : ptr     ( -- )       Create immediate o@
         : asptr   ( addr -- )          decl @ IF  instptr,    ELSE  ptr,       THEN ;
           decl @ 0= abort" only in declaration!"      : asptr   ( addr -- )
           Create immediate o@ , cell+ @ , instptr> ;          decl @ 0= abort" only in declaration!"
         : []      ( n -- )     Create immediate o@          Create immediate o@ , cell+ @ , instptr> ;
           decl @ IF  instarray,  ELSE  array,     THEN ;      : []      ( n -- )     Create immediate o@
         : new     ( -- o )     o@ state @          decl @ IF  instarray,  ELSE  array,     THEN ;
           IF  postpone Literal postpone new,  ELSE  new,  THEN ;      : new     ( -- o )     o@ state @
         : new[]   ( n -- o )   o@ state @          IF  Fpostpone Literal Fpostpone new,  ELSE  new,  THEN ;
           IF postpone Literal postpone new[], ELSE new[], THEN ;      : new[]   ( n -- o )   o@ state @
         : dispose ( -- )       ^ size @ dispose, ;          IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ;
         : bind    ( addr -- )  (bind ;      : dispose ( -- )       ^ size @ dispose, ;
         : bound   ( o1 o2 addr2  -- ) (bound ;      : bind    ( addr -- )  (bind ;
         : link    ( -- o addr ) (link ;      : bound   ( o1 o2 addr2  -- ) (bound ;
         : class?  ( class -- flag )  ^ parent? nip 0<> ;      : link    ( -- o addr ) (link ;
         : ::      ( -- )      : class?  ( class -- flag )  ^ parent? nip 0<> ;
           state @ IF  ^ true method,  ELSE  inherit  THEN ;      : ::      ( -- )
         : super   ( -- )       parento true method, ;          state @ IF  ^ true method,  ELSE  inherit  THEN ;
         : is      ( cfa -- )   (is ;      : super   ( -- )       parento true method, ;
         : self    ( -- obj )   ^ ;      : is      ( cfa -- )   (is ;
         : init    ( -- )       ;      : self    ( -- obj )   ^ ;
       : init    ( -- )       ;
         : '       ( -- xt )  bl word findo 0= abort" not found!"      
           state @ IF  postpone Literal  THEN ;      : '       ( -- xt )  bl word findo 0= abort" not found!"
         : send    ( xt -- )  execute ;          state @ IF  Fpostpone Literal  THEN ;
       : send    ( xt -- )  execute ;
         : with ( -- )      : postpone ( -- )  o@ add-order Fpostpone Fpostpone drop-order ;
           state @ oset? 0= and IF  postpone >o  THEN      
           o@ add-order voc# ! false to oset?      : with ( -- )
           rdrop state @          state @ oset? 0= and IF  Fpostpone >o  THEN
           IF    o>          o@ add-order voc# ! false to oset? ;
           ELSE  oset? IF  ^ THEN  o> postpone >o      : endwith  Fpostpone o> voc# @ drop-order ;
           THEN  
           rdrop rdrop ;      : definitions
         : endwith  postpone o>           o@ add-order 1+ voc# ! also types o@ lastob !
           voc# @ drop-order ;          false to oset?   get-current old-current !
           thread @ set-current ;
 class; \ object  class; \ object
   
 \ interface                                            01sep96py  \ interface                                            01sep96py
Line 559  Forth definitions Line 604  Forth definitions
     DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;      DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
   
 previous previous  previous previous
   

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


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