[gforth] / gforth / oof.fs  

gforth: gforth/oof.fs

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

version 1.12, Sun Aug 3 20:21:35 1997 UTC version 1.16, Sat Sep 14 08:20:19 2002 UTC
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  \ The program uses the following words
 \ from CORE :  \ from CORE :
 \ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF  \  decimal : bl word 0= ; = cells Constant Variable ! Create , allot @
 \ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop  \  IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+
 \ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and  \  Literal drop align here aligned DOES> execute ['] 2@ recurse swap
 \ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1-  \  1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop
 \ rshift > / ' move UNTIL or count  \  BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count
 \ from CORE-EXT :  \ from CORE-EXT :
 \ nip tuck true ?DO compile, false Value erase pick :noname 0<>  \  nip false Value tuck true ?DO compile, erase pick :noname 0<>
 \ from BLOCK-EXT :  \ from BLOCK-EXT :
 \ \  \ \
 \ from EXCEPTION :  \ from EXCEPTION :
Line 31 
Line 33 
 \ from MEMORY :  \ from MEMORY :
 \ allocate free  \ allocate free
 \ from SEARCH :  \ from SEARCH :
 \ find definitions get-order set-order get-current wordlist set-current  \  find definitions get-order set-order get-current wordlist
 \ search-wordlist  \  set-current search-wordlist
 \ from SEARCH-EXT :  \ from SEARCH-EXT :
 \ also Forth previous  \ also Forth previous
 \ from STRING :  \ from STRING :
 \ /string compare  \ /string compare
 \ from TOOLS-EXT :  \ from TOOLS-EXT :
 \ [IF] [THEN] [ELSE] state  \ [IF] [THEN] [ELSE] state
   \  from non-ANS :
   \  cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G
   
 \ Loadscreen                                           27dec95py  \ Loadscreen                                           27dec95py
   
Line 51 
Line 55 
 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 
Line 182 
 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 
Line 242 
     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 
Line 331 
 \ 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 
Line 354 
   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 
Line 471 
     \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 
Line 486 
   
 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 
Line 596 
   
 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 
Line 614 
   
 Vocabulary interfaces  interfaces definitions  Vocabulary interfaces  interfaces definitions
   
 : method  ( -- )  mallot Create , inter# @ ,  : method  ( -- ) \ oof-interface- oof
       mallot Create , inter# @ ,
   DOES> 2@ swap o@ + @ + @ execute ;    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 
Line 638 
   
 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
   
   

Generate output suitable for use with a patch program
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.16
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help