[gforth] / gforth / oof.fs  

gforth: gforth/oof.fs

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

version 1.3, Sun Oct 13 19:56:22 1996 UTC version 1.11, Sat Aug 2 20:19:05 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]  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 157 
Line 195 
     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 212 
   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 @ >r state on  method, r> state ! ;
 : late,  ( object -- )  false method,  
   state @ IF  postpone o>  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 282 
   >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 310 
 \ 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 372 
Line 413 
   
 : 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 403 
Line 444 
 : asptr ( addr -- )  cell+ @ Create immediate  : asptr ( addr -- )  cell+ @ Create immediate
   lastob @ here lastob ! , ,  instptr> ;    lastob @ here lastob ! , ,  instptr> ;
   
   : Fpostpone  postpone postpone ; immediate
   
 : : ( <methodname> -- )  decl @ abort" HOW: missing! "  : : ( <methodname> -- )  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
Line 446 
Line 489 
          early     super       immediate           early     super       immediate
          early     self           early     self
          early     bind        immediate           early     bind        immediate
          early     is          immediate  
          early     bound           early     bound
          early     link        immediate           early     link        immediate
          early     '           immediate           early     is          immediate
          early     send        immediate           early     send        immediate
            early     with        immediate
            early     endwith     immediate
            early     '           immediate
            early     postpone    immediate
            early     definitions
   
 \ 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 516 
          : []      ( 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 532 
          : 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
Line 515 
Line 574 
   
 : 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 604 
     DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;      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.11
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help