[gforth] / gforth / oof.fs  

gforth: gforth/oof.fs

Diff for /gforth/oof.fs between version 1.3 and 1.15

version 1.3, Sun Oct 13 19:56:22 1996 UTC version 1.15, Fri Sep 8 11:05:07 2000 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.
Line 8 
Line 9 
 \               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 false Value tuck true ?DO compile, 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
   \  from non-ANS :
   \  cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G
   
 \ Loadscreen                                           27dec95py  \ Loadscreen                                           27dec95py
   
 decimal  decimal
Line 15 
Line 51 
 : 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? \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
Line 26 
Line 68 
 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 
Line 134 
 : 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 135 
Line 181 
   
 types definitions  types definitions
   
 : static   ( -- )  mallot Create , #static ,  : static   ( -- ) \ oof- oof
       \G Create a class-wide cell-sized variable.
       mallot Create , #static ,
   DOES> @ o@ + ;    DOES> @ o@ + ;
 : method   ( -- )  mallot Create , #method ,  : method   ( -- ) \ oof- oof
       \G Create a method selector.
       mallot Create , #method ,
   DOES> @ o@ + @ execute ;    DOES> @ o@ + @ execute ;
 : early    ( -- )  Create ['] crash , #early ,  : early    ( -- ) \ oof- oof
       \G Create a method selector for early binding.
       Create ['] crash , #early ,
   DOES> @ execute ;    DOES> @ execute ;
 : var ( size -- )  vallot Create , #var ,  : var ( size -- ) \ oof- oof
       \G Create an instance variable
       vallot Create , #var ,
   DOES> @ ^ + ;    DOES> @ ^ + ;
 : defer    ( -- )  valign cell vallot Create , #defer ,  : defer    ( -- ) \ oof- oof
       \G Create an instance defer
       valign cell vallot Create , #defer ,
   DOES> @ ^ + @ execute ;    DOES> @ ^ + @ execute ;
   
 \ dealing with threads                                 29oct94py  \ dealing with threads                                 29oct94py
Line 157 
Line 213 
     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 )  >r  : add-order ( addr -- n )  dup 0= ?EXIT  >r
     get-order r> swap >r 0 swap object-order      get-order r> swap >r 0 swap
       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 173 
Line 230 
   drop dup early?  IF >body @  THEN  compile, ;    drop dup early?  IF >body @  THEN  compile, ;
   
 : findo    ( string -- cfa n )  : findo    ( string -- cfa n )
     >r get-order 0      o@ add-order >r
     o@ object-order      find
     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 >r set-order r> r> ;      r> drop-order ;
   
 false Value method?  false Value method?
   
 : 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  method,  : cmethod,  ( object early? -- )
   state @ IF  postpone o>  THEN  ;      state @ dup >r
 : late,  ( object -- )  false method,      0= IF  postpone ]  THEN
   state @ IF  postpone o>  THEN  ;      method,
       r> 0= IF  postpone [  THEN ;
   
   : early, ( object -- )  true to oset?  true  method,
     state @ oset? and IF  postpone o>  THEN  false to oset? ;
   : late,  ( object -- )  true to oset?  false method,
     state @ oset? and IF  postpone o>  THEN  false to oset? ;
   
 \ new,                                                 29oct94py  \ new,                                                 29oct94py
   
Line 241 
Line 303 
   >r drop r@ @ rot ! r@ swap erase r> ;    >r drop r@ @ rot ! r@ swap erase r> ;
   
 : >chunk ( n -- root n' )  : >chunk ( n -- root n' )
   8aligned dup 3 rshift cells chunks + swap ;    1- -8 and dup 3 rshift cells chunks + swap 8 + ;
   
 : Dalloc ( size -- addr )  : Dalloc ( size -- addr )
   dup 128 > IF  allocate throw EXIT  THEN    dup 128 > IF  allocate throw EXIT  THEN
Line 269 
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 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    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 291 
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 372 
Line 436 
   
 : 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 , [ order ] op! o@ lastob ! ;      dup , op! o@ lastob ! ;
   
 : thread,  ( -- )  classlist @ , ;  : thread,  ( -- )  classlist @ , ;
 : var,     ( -- )  methods @ , vars @ , ;  : var,     ( -- )  methods @ , vars @ , ;
Line 389 
Line 453 
   
 types definitions  types definitions
   
 : how:  ( -- )  decl @ 0= abort" not twice!" 0 decl !  : how:  ( -- ) \ oof- oof how-to
   \G End declaration, start implementation
       decl @ 0= abort" not twice!" 0 decl !
     align  interface,      align  interface,
     lastob! thread, parent, var, 'link, 0 , cells, interfaces,      lastob! thread, parent, var, 'link, 0 , cells, interfaces,
     dup      dup
     IF    dup :method# + @ >r :init + swap r> :init /string move      IF    dup :method# + @ >r :init + swap r> :init /string move
     ELSE  2drop  THEN ;      ELSE  2drop  THEN ;
   
 : class; ( -- ) decl @ IF  how:  THEN  0 'link !  : class; ( -- ) \ oof- oof end-class
   \G End class declaration or implementation
       decl @ IF  how:  THEN  0 'link !
   voc# @ drop-order old-current @ set-current ;    voc# @ drop-order old-current @ set-current ;
   
 : ptr ( -- ) Create immediate lastob @ here lastob ! instptr, ;  : ptr ( -- ) \ oof- oof
 : asptr ( addr -- )  cell+ @ Create immediate      \G Create an instance pointer
       Create immediate lastob @ here lastob ! instptr, ;
   : asptr ( class -- ) \ oof- oof
       \G Create an alias to an instance pointer, cast to another class.
       cell+ @ Create immediate
   lastob @ here lastob ! , ,  instptr> ;    lastob @ here lastob ! , ,  instptr> ;
   
 : : ( <methodname> -- )  decl @ abort" HOW: missing! "  : Fpostpone  postpone postpone ; immediate
   
   : : ( <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 411 
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 431 
Line 507 
          static    size         \ number of variables (bytes)           static    size         \ number of variables (bytes)
          static    newlink      \ ptr to allocated space           static    newlink      \ ptr to allocated space
          static    ilist        \ interface list           static    ilist        \ interface list
          method    init           method    init ( ... -- ) \ object- oof
          method    dispose           method    dispose ( -- ) \ object- oof
   
          early     class           early     class ( "name" -- ) \ object- oof
          early     new         immediate           early     new ( -- o ) \ object- oof
          early     new[]       immediate                                  immediate
          early     :           early     new[] ( n -- o ) \ object- oof new-array
          early     ptr                                  immediate
          early     asptr           early     : ( "name" -- ) \ object- oof define
          early     []           early     ptr ( "name" -- ) \ object- oof
          early     ::          immediate           early     asptr ( o "name" -- ) \ object- oof
          early     class?           early     [] ( n "name" -- ) \ object- oof array
          early     super       immediate           early     ::  ( "name" -- ) \ object- oof scope
          early     self                                  immediate
          early     bind        immediate           early     class? ( o -- flag ) \ object- oof class-query
          early     is          immediate           early     super  ( "name" -- ) \ object- oof
          early     bound                                  immediate
          early     link        immediate           early     self ( -- o ) \ object- oof
          early     '           immediate           early     bind ( o "name" -- ) \ object- oof
          early     send        immediate                                  immediate
            early     bound ( class addr "name" -- ) \ object- oof
            early     link ( "name" -- class addr ) \ object- oof
                                   immediate
            early     is  ( xt "name" -- ) \ object- oof
                                   immediate
            early     send ( xt -- ) \ object- oof
                                   immediate
            early     with ( o -- ) \ object- oof
                                   immediate
            early     endwith ( -- ) \ object- oof
                                   immediate
            early     ' ( "name" -- xt ) \ object- oof tick
                                   immediate
            early     postpone ( "name" -- ) \ object- oof
                                   immediate
            early     definitions ( -- ) \ object- oof
   
 \ 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 ;
Line 468 
Line 561 
          : []      ( 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  Fpostpone Literal Fpostpone new,  ELSE  new,  THEN ;
          : new[]   ( n -- o )   o@ state @           : new[]   ( n -- o )   o@ state @
            IF postpone Literal postpone new[], ELSE new[], THEN ;          IF Fpostpone Literal Fpostpone 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 ;
Line 484 
Line 577 
          : 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  Fpostpone Literal  THEN ;
          : send    ( xt -- )  execute ;           : send    ( xt -- )  execute ;
       : postpone ( -- )  o@ add-order Fpostpone Fpostpone drop-order ;
   
       : with ( -- )
           state @ oset? 0= and IF  Fpostpone >o  THEN
           o@ add-order voc# ! false to oset? ;
       : endwith  Fpostpone o> voc# @ drop-order ;
   
       : definitions
           o@ add-order 1+ voc# ! also types o@ lastob !
           false to oset?   get-current old-current !
           thread @ set-current ;
 class; \ object  class; \ object
   
 \ interface                                            01sep96py  \ interface                                            01sep96py
   
 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" '" compare
     0= dup >r IF  2drop bl word count  THEN      0= dup >r IF  2drop bl word count  THEN
     rot search-wordlist      rot search-wordlist
Line 510 
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 !
     last-interface @ ,  inter-list @ ,  methods @ ,  inter# @ ,      here  last-interface @ ,  last-interface !
       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 529 
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.3  
changed lines
  Added in v.1.15
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help