Diff for /gforth/oof.fs between versions 1.14 and 1.15

version 1.14, 1999/02/16 06:32:29 version 1.15, 2000/09/08 11:05:07
Line 1 Line 1
   
 \ oof.fs        Object Oriented FORTH  \ oof.fs        Object Oriented FORTH
 \               This file is (c) 1996 by Bernd Paysan  \               This file is (c) 1996,2000 by Bernd Paysan
 \                       e-mail: paysan@informatik.tu-muenchen.de  \                       e-mail: bernd.paysan@gmx.de
 \  \
 \               Please copy and share this program, modify it for your system  \               Please copy and share this program, modify it for your system
 \               and improve it as you like. But don't remove this notice.  \               and improve it as you like. But don't remove this notice.
 \  \
 \               Thank you.  \               Thank you.
 \  \
 \ The program uses the following words  
 \ from CORE :  \  The program uses the following words
 \ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF  \  from CORE :
 \ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop  \  decimal : bl word 0= ; = cells Constant Variable ! Create , allot @
 \ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and  \  IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+
 \ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1-  \  Literal drop align here aligned DOES> execute ['] 2@ recurse swap
 \ rshift > / ' move UNTIL or count   \  1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop
 \ from CORE-EXT :  \  BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count
 \ nip tuck true ?DO compile, false Value erase pick :noname 0<>   \  from CORE-EXT :
 \ from BLOCK-EXT :  \  nip false Value tuck true ?DO compile, erase pick :noname 0<> 
 \ \   \  from BLOCK-EXT :
 \ from EXCEPTION :  \  \ 
 \ throw   \  from EXCEPTION :
 \ from EXCEPTION-EXT :  \  throw 
 \ abort"   \  from EXCEPTION-EXT :
 \ from FILE :  \  abort" 
 \ ( S"   \  from FILE :
 \ from FLOAT :  \  ( S" 
 \ faligned   \  from FLOAT :
 \ from LOCAL :  \  faligned 
 \ TO   \  from LOCAL :
 \ from MEMORY :  \  TO 
 \ allocate free   \  from MEMORY :
 \ from SEARCH :  \  allocate free 
 \ find definitions get-order set-order get-current wordlist set-current  \  from SEARCH :
 \ search-wordlist   \  find definitions get-order set-order get-current wordlist
 \ from SEARCH-EXT :  \  set-current search-wordlist
 \ also Forth previous   \  from SEARCH-EXT :
 \ from STRING :  \  also Forth previous 
 \ /string compare   \  from STRING :
 \ from TOOLS-EXT :  \  /string compare 
 \ [IF] [THEN] [ELSE] state   \  from TOOLS-EXT :
   \  [IF] [THEN] [ELSE] state 
   \  from non-ANS :
   \  cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G 
   
 \ Loadscreen                                           27dec95py  \ Loadscreen                                           27dec95py
   
Line 51  define? cell  [IF] Line 55  define? cell  [IF]
 1 cells Constant cell  1 cells Constant cell
 [THEN]  [THEN]
   
   define? \G [IF]
   : \G postpone \ ; immediate
   [THEN]
   
 define? ?EXIT [IF]  define? ?EXIT [IF]
 : ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate  : ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate
 [THEN]  [THEN]
Line 234  false Value method? Line 242  false Value method?
     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? -- )  : cmethod,  ( object early? -- )
     state @ >r state on  method, r> state ! ;      state @ dup >r
       0= IF  postpone ]  THEN
       method,
       r> 0= IF  postpone [  THEN ;
   
 : early, ( object -- )  true to oset?  true  method,  : early, ( object -- )  true to oset?  true  method,
   state @ oset? and IF  postpone o>  THEN  false to oset? ;    state @ oset? and IF  postpone o>  THEN  false to oset? ;
Line 320  Objects definitions Line 331  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 oset? IF  postpone op!  ELSE  postpone >o  THEN  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 @ oset? IF  postpone op!  ELSE  postpone >o  THEN cell+      IF    dup postpone Literal postpone @ oset? IF  postpone op!  ELSE  postpone >o  THEN cell+
Line 342  Variable ob-interface Line 354  Variable ob-interface
   get-order wordlist tuck classlist ! 1+ set-order    get-order wordlist tuck classlist ! 1+ set-order
   also types classlist @ set-current ;    also types classlist @ set-current ;
   
 : (class ( parent -- )  : (class-does>  DOES> false method, ;
   
   : (class ( parent -- )  (class-does>
     here lastob !  true decl !  0 ob-interface !      here lastob !  true decl !  0 ob-interface !
     0 ,  dup voc!  dup lastparent !      0 ,  dup voc!  dup lastparent !
     dup 0= IF  0  ELSE  :method# + 2@  THEN  methods ! vars !    dup 0= IF  0  ELSE  :method# + 2@  THEN  methods ! vars ! ;
     DOES>  false method, ;  
   
 : (is ( addr -- )  bl word findo drop  : (is ( addr -- )  bl word findo drop
     dup defer? abort" not deferred!"      dup defer? abort" not deferred!"
Line 631  Forth Line 644  Forth
   
 Forth definitions  Forth definitions
   
   : interface-does>
       DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
 : interface ( -- ) \ oof-interface- oof  : interface ( -- ) \ oof-interface- oof
     Create  here lastif !  0 ,  get-current old-current !      Create  interface-does>
       here lastif !  0 ,  get-current old-current !
     last-interface @ dup  IF  :inum @  THEN  1 cells - inter# !      last-interface @ dup  IF  :inum @  THEN  1 cells - inter# !
     get-order wordlist      get-order wordlist
     dup inter-list ! dup set-current swap 1+ set-order      dup inter-list ! dup set-current swap 1+ set-order
     true decl !      true decl !
     0 vars ! :inum cell+ methods !  also interfaces      0 vars ! :inum cell+ methods !  also interfaces ;
     DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;  
   
 previous previous  previous previous
   
   

Removed from v.1.14  
changed lines
  Added in v.1.15


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