Diff for /gforth/oof.fs between versions 1.12 and 1.16

version 1.12, 1997/08/03 20:21:35 version 1.16, 2002/09/14 08:20:19
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 174  define? faligned 0= [IF] Line 182  define? faligned 0= [IF]
 types definitions  types definitions
   
 : static   ( -- ) \ oof- oof  : static   ( -- ) \ oof- oof
     \G Create a class-wide cell sized variable      \G Create a class-wide cell-sized variable.
     mallot Create , #static ,      mallot Create , #static ,
 DOES> @ o@ + ;  DOES> @ o@ + ;
 : method   ( -- ) \ oof- oof  : method   ( -- ) \ oof- oof
     \G Create a method selector      \G Create a method selector.
     mallot Create , #method ,      mallot Create , #method ,
 DOES> @ o@ + @ execute ;  DOES> @ o@ + @ execute ;
 : early    ( -- ) \ oof- oof  : early    ( -- ) \ oof- oof
     \G Create a method selector for early binding      \G Create a method selector for early binding.
     Create ['] crash , #early ,      Create ['] crash , #early ,
 DOES> @ execute ;  DOES> @ execute ;
 : var ( size -- ) \ oof- oof  : var ( size -- ) \ oof- oof
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 458  types definitions Line 471  types definitions
     \G Create an instance pointer      \G Create an instance pointer
     Create immediate lastob @ here lastob ! instptr, ;      Create immediate lastob @ here lastob ! instptr, ;
 : asptr ( class -- ) \ oof- oof  : asptr ( class -- ) \ oof- oof
     \G Create an alias to an instance pointer, casted to another class      \G Create an alias to an instance pointer, cast to another class.
     cell+ @ Create immediate      cell+ @ Create immediate
     lastob @ here lastob ! , ,  instptr> ;      lastob @ here lastob ! , ,  instptr> ;
   
 : Fpostpone  postpone postpone ; immediate  : Fpostpone  postpone postpone ; immediate
   
 : : ( <methodname> -- )  decl @ abort" HOW: missing! "  : : ( <methodname> -- ) \ oof- oof colon
       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
     0= abort" not a method"      0= abort" not a method"
Line 472  types definitions Line 486  types definitions
   
 Forth  Forth
   
 : ; ( xt colon-sys -- )  postpone ;  : ; ( xt colon-sys -- ) \ oof- oof
       postpone ;
     m-name @ dup >body swap exec?      m-name @ dup >body swap exec?
     IF    @ o@ +      IF    @ o@ +
     ELSE  dup cell+ @ 0< IF  2@ swap o@ + @ +  THEN      ELSE  dup cell+ @ 0< IF  2@ swap o@ + @ +  THEN
Line 581  class; \ object Line 596  class; \ object
   
 Objects definitions  Objects definitions
   
 : implement ( interface -- )  : implement ( interface -- ) \ oof-interface- oof
     align here over , ob-interface @ , ob-interface !      align here over , ob-interface @ , ob-interface !
     :ilist + @ >r get-order r> swap 1+ set-order  1 voc# +! ;      :ilist + @ >r get-order r> swap 1+ set-order  1 voc# +! ;
   
 : inter-method, ( interface -- )  : inter-method, ( interface -- ) \ oof-interface- oof
     :ilist + @ bl word count 2dup s" '" compare      :ilist + @ bl word count 2dup s" '" str=
     0= dup >r IF  2drop bl word count  THEN      dup >r IF  2drop bl word count  THEN
     rot search-wordlist      rot search-wordlist
     dup 0= abort" Not an interface method!"      dup 0= abort" Not an interface method!"
     r> IF  drop state @ IF  postpone Literal  THEN  EXIT  THEN      r> IF  drop state @ IF  postpone Literal  THEN  EXIT  THEN
Line 599  Variable inter# Line 614  Variable inter#
   
 Vocabulary interfaces  interfaces definitions  Vocabulary interfaces  interfaces definitions
   
 : method  ( -- )  mallot Create , inter# @ ,  : method  ( -- ) \ oof-interface- oof
   DOES> 2@ swap o@ + @ + @ execute ;      mallot Create , inter# @ ,
   DOES> 2@ swap o@ + @ + @ execute ;
   
 : how: ( -- )  align  : how: ( -- ) \ oof-interface- oof
       align
     here lastif @ !  0 decl !      here lastif @ !  0 decl !
     here  last-interface @ ,  last-interface !      here  last-interface @ ,  last-interface !
     inter-list @ ,  methods @ ,  inter# @ ,      inter-list @ ,  methods @ ,  inter# @ ,
     methods @ :inum cell+ ?DO  ['] crash ,  LOOP ;      methods @ :inum cell+ ?DO  ['] crash ,  LOOP ;
   
 : interface; ( -- )  old-current @ set-current  : interface; ( -- ) \ oof-interface- oof
       old-current @ set-current
     previous previous ;      previous previous ;
   
 : : ( <methodname> -- ) decl @ abort" HOW: missing! "  : : ( <methodname> -- ) \ oof-interface- oof colon
       decl @ abort" HOW: missing! "
     bl word count lastif @ @ :ilist + @      bl word count lastif @ @ :ilist + @
     search-wordlist 0= abort" not found"      search-wordlist 0= abort" not found"
     dup >body cell+ @ 0< 0= abort" not a method"      dup >body cell+ @ 0< 0= abort" not a method"
Line 619  Vocabulary interfaces  interfaces defini Line 638  Vocabulary interfaces  interfaces defini
   
 Forth  Forth
   
 : ; ( xt colon-sys -- )  postpone ;  : ; ( xt colon-sys -- ) \ oof-interface- oof
     postpone ;
   m-name @ >body @ lastif @ @ + ! ; immediate    m-name @ >body @ lastif @ @ + ! ; immediate
   
 Forth definitions  Forth definitions
   
 : interface ( -- )  : interface-does>
     Create  here lastif !  0 ,  get-current old-current !      DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
   : interface ( -- ) \ oof-interface- oof
       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.12  
changed lines
  Added in v.1.16


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