[gforth] / gforth / oof.fs  

gforth: gforth/oof.fs

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

version 1.3, Sun Oct 13 19:56:22 1996 UTC version 1.9, Mon Mar 31 22:14:39 1997 UTC
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 
Line 47 
 : 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 
Line 60 
 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 126 
 : defer?   ( addr -- flag )  : defer?   ( addr -- flag )
   >body cell+ @ #defer  = ;    >body cell+ @ #defer  = ;
   
 define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]  
 [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 ;    postpone >o drop ;
Line 157 
Line 193 
     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 210 
   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?
   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?  ;
   
 : early, ( object -- )  true  method,  : early, ( object -- )  true to oset?  true  method,
   state @ IF  postpone o>  THEN  ;    state @ IF  postpone o>  THEN  false to oset? ;
 : late,  ( object -- )  false method,  : late,  ( object -- )  true to oset?  false method,
   state @ IF  postpone o>  THEN  ;    state @ IF  postpone o>  THEN  false to oset? ;
   
 \ new,                                                 29oct94py  \ new,                                                 29oct94py
   
Line 241 
Line 278 
   >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 272 
Line 309 
   DOES> state @ IF  dup postpone Literal postpone >o  THEN early, ;    DOES> state @ IF  dup postpone Literal postpone >o  THEN early, ;
 : ptr,      ( o -- )  0 , ,  : ptr,      ( o -- )  0 , ,
   DOES>  state @    DOES>  state @
     IF    postpone Literal postpone @ postpone >o cell+      IF    dup postpone Literal postpone @ postpone >o 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 372 
Line 409 
   
 : 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 451 
Line 488 
          early     link        immediate           early     link        immediate
          early     '           immediate           early     '           immediate
          early     send        immediate           early     send        immediate
            early     with        immediate
            early     endwith     immediate
   
 \ base object class implementation part                23mar95py  \ base object class implementation part                23mar95py
   
Line 486 
Line 525 
          : '       ( -- xt )  bl word findo 0= abort" not found!"           : '       ( -- xt )  bl word findo 0= abort" not found!"
            state @ IF  postpone Literal  THEN ;             state @ IF  postpone Literal  THEN ;
          : send    ( xt -- )  execute ;           : send    ( xt -- )  execute ;
   
           : with ( -- )
             state @ oset? 0= and IF  postpone >o  THEN
             o@ add-order voc# ! false to oset?
             r> drop state @
             IF    o>
             ELSE  oset? IF  ^ THEN  o> postpone >o
             THEN
             r> drop r> drop ;
           : endwith  postpone o>
             voc# @ drop-order ;
 class; \ object  class; \ object
   
 \ interface                                            01sep96py  \ interface                                            01sep96py
Line 515 
Line 565 
   
 : how: ( -- )  align  : how: ( -- )  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; ( -- )  old-current @ set-current
Line 544 
Line 595 
     DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;      DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
   
 previous previous  previous previous
   
   \ The program uses the following words
   \ from CORE :
   \ decimal : bl word 0= ; cells Constant POSTPONE IF EXIT THEN immediate
   \ Create , DOES> @ >r r> swap + and Variable ! allot ELSE +! dup * >body
   \ cell+ = Literal drop align here aligned execute ['] 2@ recurse 1+ over
   \ LOOP ?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 wordlist get-order set-order definitions get-current set-current search-wordlist
   \ from SEARCH-EXT :
   \ also Forth previous
   \ from STRING :
   \ /string compare
   \ from TOOLS-EXT :
   \ state [IF] [THEN]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help