Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ yet another Forth objects extension |
| 2 : | |||
| 3 : | anton | 1.14 | \ written by Anton Ertl 1996-1999 |
| 4 : | anton | 1.4 | \ public domain; NO WARRANTY |
| 5 : | anton | 1.1 | |
| 6 : | anton | 1.2 | \ This (in combination with compat/struct.fs) is in ANS Forth (with an |
| 7 : | \ environmental dependence on case insensitivity; convert everything | ||
| 8 : | \ to upper case for state sensitive systems). | ||
| 9 : | anton | 1.1 | |
| 10 : | anton | 1.2 | \ compat/struct.fs and this file together use the following words: |
| 11 : | |||
| 12 : | \ from CORE : | ||
| 13 : | anton | 1.4 | \ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r |
| 14 : | \ r> IF ELSE THEN over chars aligned cells 2* here - allot execute | ||
| 15 : | \ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +! | ||
| 16 : | \ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." . | ||
| 17 : | anton | 1.2 | \ from CORE-EXT : |
| 18 : | anton | 1.4 | \ tuck pick nip true <> 0> erase Value :noname compile, |
| 19 : | anton | 1.2 | \ from BLOCK-EXT : |
| 20 : | \ \ | ||
| 21 : | \ from DOUBLE : | ||
| 22 : | anton | 1.3 | \ 2Constant |
| 23 : | anton | 1.2 | \ from EXCEPTION : |
| 24 : | \ throw catch | ||
| 25 : | \ from EXCEPTION-EXT : | ||
| 26 : | \ abort" | ||
| 27 : | \ from FILE : | ||
| 28 : | \ ( | ||
| 29 : | \ from FLOAT : | ||
| 30 : | anton | 1.4 | \ faligned floats |
| 31 : | anton | 1.2 | \ from FLOAT-EXT : |
| 32 : | anton | 1.4 | \ dfaligned dfloats sfaligned sfloats |
| 33 : | anton | 1.3 | \ from LOCAL : |
| 34 : | \ TO | ||
| 35 : | anton | 1.2 | \ from MEMORY : |
| 36 : | anton | 1.3 | \ allocate resize free |
| 37 : | \ from SEARCH : | ||
| 38 : | \ get-order set-order wordlist get-current set-current | ||
| 39 : | anton | 1.2 | |
| 40 : | anton | 1.1 | \ needs struct.fs |
| 41 : | |||
| 42 : | \ helper words | ||
| 43 : | |||
| 44 : | anton | 1.6 | s" gforth" environment? [if] |
| 45 : | 2drop | ||
| 46 : | [else] | ||
| 47 : | |||
| 48 : | anton | 1.1 | : -rot ( a b c -- c a b ) |
| 49 : | rot rot ; | ||
| 50 : | |||
| 51 : | : perform ( ... addr -- ... ) | ||
| 52 : | @ execute ; | ||
| 53 : | |||
| 54 : | anton | 1.3 | : ?dup-if ( compilation: -- orig ; run-time: n -- n| ) |
| 55 : | POSTPONE ?dup POSTPONE if ; immediate | ||
| 56 : | |||
| 57 : | anton | 1.1 | : save-mem ( addr1 u -- addr2 u ) \ gforth |
| 58 : | \ copy a memory block into a newly allocated region in the heap | ||
| 59 : | swap >r | ||
| 60 : | dup allocate throw | ||
| 61 : | swap 2dup r> -rot move ; | ||
| 62 : | |||
| 63 : | anton | 1.3 | : resize ( a-addr1 u -- a-addr2 ior ) \ gforth |
| 64 : | over | ||
| 65 : | if | ||
| 66 : | resize | ||
| 67 : | else | ||
| 68 : | nip allocate | ||
| 69 : | then ; | ||
| 70 : | |||
| 71 : | anton | 1.1 | : extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
| 72 : | \ extend memory block allocated from the heap by u aus | ||
| 73 : | anton | 1.4 | \ the (possibly reallocated) piece is addr2 u2, the extension is at addr |
| 74 : | anton | 1.1 | over >r + dup >r resize throw |
| 75 : | r> over r> + -rot ; | ||
| 76 : | |||
| 77 : | anton | 1.6 | : \g ( -- ) |
| 78 : | postpone \ ; immediate | ||
| 79 : | [then] | ||
| 80 : | |||
| 81 : | anton | 1.3 | \ data structures |
| 82 : | anton | 1.1 | |
| 83 : | struct | ||
| 84 : | anton | 1.4 | cell% field object-map |
| 85 : | end-struct object% | ||
| 86 : | anton | 1.1 | |
| 87 : | struct | ||
| 88 : | anton | 1.4 | cell% 2* field interface-map |
| 89 : | cell% field interface-map-offset \ aus | ||
| 90 : | anton | 1.3 | \ difference between where interface-map points and where |
| 91 : | \ object-map points (0 for non-classes) | ||
| 92 : | anton | 1.4 | cell% field interface-offset \ aus |
| 93 : | anton | 1.3 | \ offset of interface map-pointer in class-map (0 for classes) |
| 94 : | anton | 1.4 | end-struct interface% |
| 95 : | anton | 1.3 | |
| 96 : | anton | 1.4 | interface% |
| 97 : | cell% field class-parent | ||
| 98 : | anton | 1.5 | cell% field class-wordlist \ inst-vars and other protected words |
| 99 : | anton | 1.10 | cell% 2* field class-inst-size ( class -- addr ) \ objects- objects |
| 100 : | crook | 1.12 | \g Give the size specification for an instance (i.e. an object) |
| 101 : | \g of @var{class}; | ||
| 102 : | \g used as @code{class-inst-size 2@ ( class -- align size )}. | ||
| 103 : | anton | 1.4 | end-struct class% |
| 104 : | anton | 1.1 | |
| 105 : | anton | 1.3 | struct |
| 106 : | anton | 1.4 | cell% field selector-offset \ the offset within the (interface) map |
| 107 : | cell% field selector-interface \ the interface offset | ||
| 108 : | end-struct selector% | ||
| 109 : | anton | 1.3 | |
| 110 : | \ maps are not defined explicitly; they have the following structure: | ||
| 111 : | |||
| 112 : | \ pointers to interface maps (for classes) <- interface-map points here | ||
| 113 : | anton | 1.4 | \ interface%/class% pointer <- (object-)map points here |
| 114 : | anton | 1.3 | \ xts of methods |
| 115 : | |||
| 116 : | anton | 1.1 | |
| 117 : | anton | 1.3 | \ code |
| 118 : | anton | 1.1 | |
| 119 : | anton | 1.3 | \ selectors and methods |
| 120 : | |||
| 121 : | anton | 1.10 | variable current-interface ( -- addr ) \ objects- objects |
| 122 : | crook | 1.12 | \g Variable: contains the class or interface currently being |
| 123 : | anton | 1.6 | \g defined. |
| 124 : | |||
| 125 : | |||
| 126 : | anton | 1.1 | |
| 127 : | : no-method ( -- ) | ||
| 128 : | anton | 1.3 | true abort" no method defined for this object/selector combination" ; |
| 129 : | |||
| 130 : | : do-class-method ( -- ) | ||
| 131 : | does> ( ... object -- ... ) | ||
| 132 : | anton | 1.5 | ( object selector-body ) |
| 133 : | anton | 1.3 | selector-offset @ over object-map @ + ( object xtp ) perform ; |
| 134 : | |||
| 135 : | : do-interface-method ( -- ) | ||
| 136 : | does> ( ... object -- ... ) | ||
| 137 : | ( object selector-body ) | ||
| 138 : | 2dup selector-interface @ ( object selector-body object interface-offset ) | ||
| 139 : | swap object-map @ + @ ( object selector-body map ) | ||
| 140 : | swap selector-offset @ + perform ; | ||
| 141 : | anton | 1.1 | |
| 142 : | anton | 1.10 | : method ( xt "name" -- ) \ objects- objects |
| 143 : | anton | 1.6 | \g @code{name} execution: @code{... object -- ...}@* |
| 144 : | crook | 1.12 | \g Create selector @var{name} and makes @var{xt} its method in |
| 145 : | anton | 1.6 | \g the current class. |
| 146 : | anton | 1.3 | create |
| 147 : | current-interface @ interface-map 2@ ( xt map-addr map-size ) | ||
| 148 : | dup current-interface @ interface-map-offset @ - , | ||
| 149 : | 1 cells extend-mem current-interface @ interface-map 2! ! ( ) | ||
| 150 : | current-interface @ interface-offset @ dup , | ||
| 151 : | ( 0<> ) if | ||
| 152 : | do-interface-method | ||
| 153 : | else | ||
| 154 : | do-class-method | ||
| 155 : | then ; | ||
| 156 : | anton | 1.1 | |
| 157 : | anton | 1.10 | : selector ( "name" -- ) \ objects- objects |
| 158 : | crook | 1.12 | \g @var{name} execution: @code{... object -- ...}@* |
| 159 : | \g Create selector @var{name} for the current class and its | ||
| 160 : | anton | 1.6 | \g descendents; you can set a method for the selector in the |
| 161 : | \g current class with @code{overrides}. | ||
| 162 : | anton | 1.1 | ['] no-method method ; |
| 163 : | |||
| 164 : | anton | 1.3 | : interface-override! ( xt sel-xt interface-map -- ) |
| 165 : | \ xt is the new method for the selector sel-xt in interface-map | ||
| 166 : | swap >body ( xt map selector-body ) | ||
| 167 : | selector-offset @ + ! ; | ||
| 168 : | |||
| 169 : | anton | 1.10 | : class->map ( class -- map ) \ objects- objects |
| 170 : | crook | 1.12 | \g @var{map} is the pointer to @var{class}'s method map; it |
| 171 : | anton | 1.6 | \g points to the place in the map to which the selector offsets |
| 172 : | crook | 1.12 | \g refer (i.e., where @var{object-map}s point to). |
| 173 : | anton | 1.3 | dup interface-map 2@ drop swap interface-map-offset @ + ; |
| 174 : | |||
| 175 : | : unique-interface-map ( class-map offset -- ) | ||
| 176 : | \ if the interface at offset in class map is the same as its parent, | ||
| 177 : | \ copy it to make it unique; used for implementing a copy-on-write policy | ||
| 178 : | over @ class-parent @ class->map ( class-map offset parent-map ) | ||
| 179 : | over + @ >r \ the map for the interface for the parent | ||
| 180 : | anton | 1.9 | + dup @ ( interface-mapp interface-map ) |
| 181 : | anton | 1.3 | dup r> = |
| 182 : | if | ||
| 183 : | anton | 1.9 | dup @ interface-map 2@ nip save-mem drop |
| 184 : | anton | 1.3 | swap ! |
| 185 : | else | ||
| 186 : | 2drop | ||
| 187 : | then ; | ||
| 188 : | |||
| 189 : | anton | 1.10 | : class-override! ( xt sel-xt class-map -- ) \ objects- objects |
| 190 : | crook | 1.12 | \g @var{xt} is the new method for the selector @var{sel-xt} in |
| 191 : | \g @var{class-map}. | ||
| 192 : | anton | 1.3 | over >body ( xt sel-xt class-map selector-body ) |
| 193 : | selector-interface @ ( xt sel-xt class-map offset ) | ||
| 194 : | ?dup-if \ the selector is for an interface | ||
| 195 : | 2dup unique-interface-map | ||
| 196 : | + @ | ||
| 197 : | then | ||
| 198 : | interface-override! ; | ||
| 199 : | anton | 1.1 | |
| 200 : | anton | 1.10 | : overrides ( xt "selector" -- ) \ objects- objects |
| 201 : | crook | 1.12 | \g replace default method for @var{selector} in the current class |
| 202 : | \g with @var{xt}. @code{overrides} must not be used during an | ||
| 203 : | anton | 1.6 | \g interface definition. |
| 204 : | anton | 1.3 | ' current-interface @ class->map class-override! ; |
| 205 : | |||
| 206 : | \ interfaces | ||
| 207 : | |||
| 208 : | \ every interface gets a different offset; the latest one is stored here | ||
| 209 : | variable last-interface-offset 0 last-interface-offset ! | ||
| 210 : | |||
| 211 : | anton | 1.10 | : interface ( -- ) \ objects- objects |
| 212 : | crook | 1.12 | \g Start an interface definition. |
| 213 : | anton | 1.4 | interface% %allot >r |
| 214 : | anton | 1.8 | r@ current-interface ! |
| 215 : | current-interface 1 cells save-mem r@ interface-map 2! | ||
| 216 : | anton | 1.3 | -1 cells last-interface-offset +! |
| 217 : | last-interface-offset @ r@ interface-offset ! | ||
| 218 : | anton | 1.8 | 0 r> interface-map-offset ! ; |
| 219 : | anton | 1.3 | |
| 220 : | anton | 1.10 | : end-interface-noname ( -- interface ) \ objects- objects |
| 221 : | crook | 1.12 | \g End an interface definition. The resulting interface is |
| 222 : | \g @var{interface}. | ||
| 223 : | anton | 1.3 | current-interface @ ; |
| 224 : | |||
| 225 : | anton | 1.10 | : end-interface ( "name" -- ) \ objects- objects |
| 226 : | anton | 1.6 | \g @code{name} execution: @code{-- interface}@* |
| 227 : | crook | 1.12 | \g End an interface definition. The resulting interface is |
| 228 : | \g @var{interface}. | ||
| 229 : | anton | 1.3 | end-interface-noname constant ; |
| 230 : | |||
| 231 : | anton | 1.13 | \ visibility control |
| 232 : | |||
| 233 : | variable public-wordlist | ||
| 234 : | |||
| 235 : | : protected ( -- ) \ objects- objects | ||
| 236 : | \g Set the compilation wordlist to the current class's wordlist | ||
| 237 : | current-interface @ class-wordlist @ | ||
| 238 : | dup get-current <> | ||
| 239 : | if \ we are not protected already | ||
| 240 : | get-current public-wordlist ! | ||
| 241 : | then | ||
| 242 : | set-current ; | ||
| 243 : | |||
| 244 : | : public ( -- ) \ objects- objects | ||
| 245 : | \g Restore the compilation wordlist that was in effect before the | ||
| 246 : | \g last @code{protected} that actually changed the compilation | ||
| 247 : | \g wordlist. | ||
| 248 : | current-interface @ class-wordlist @ get-current = | ||
| 249 : | if \ we are protected | ||
| 250 : | public-wordlist @ set-current | ||
| 251 : | then ; | ||
| 252 : | |||
| 253 : | anton | 1.3 | \ classes |
| 254 : | |||
| 255 : | : add-class-order ( n1 class -- wid1 ... widn n+n1 ) | ||
| 256 : | dup >r class-parent @ | ||
| 257 : | ?dup-if | ||
| 258 : | recurse \ first add the search order for the parent class | ||
| 259 : | then | ||
| 260 : | r> class-wordlist @ swap 1+ ; | ||
| 261 : | |||
| 262 : | anton | 1.18 | : class>order ( class -- ) \ objects- objects |
| 263 : | crook | 1.12 | \g Add @var{class}'s wordlists to the head of the search-order. |
| 264 : | anton | 1.3 | >r get-order r> add-class-order set-order ; |
| 265 : | |||
| 266 : | anton | 1.18 | : push-order class>order ; \ old name |
| 267 : | |||
| 268 : | anton | 1.15 | : methods ( class -- ) \ objects- objects |
| 269 : | anton | 1.14 | \g Makes @var{class} the current class. This is intended to be |
| 270 : | \g used for defining methods to override selectors; you cannot | ||
| 271 : | \g define new fields or selectors. | ||
| 272 : | anton | 1.18 | dup current-interface ! class>order ; |
| 273 : | anton | 1.14 | |
| 274 : | anton | 1.10 | : class ( parent-class -- align offset ) \ objects- objects |
| 275 : | crook | 1.12 | \g Start a new class definition as a child of |
| 276 : | \g @var{parent-class}. @var{align offset} are for use by | ||
| 277 : | \g @var{field} etc. | ||
| 278 : | anton | 1.4 | class% %allot >r |
| 279 : | anton | 1.3 | dup interface-map 2@ save-mem r@ interface-map 2! |
| 280 : | dup interface-map-offset @ r@ interface-map-offset ! | ||
| 281 : | r@ dup class->map ! | ||
| 282 : | 0 r@ interface-offset ! | ||
| 283 : | dup r@ class-parent ! | ||
| 284 : | wordlist r@ class-wordlist ! | ||
| 285 : | anton | 1.14 | r> methods |
| 286 : | anton | 1.3 | class-inst-size 2@ ; |
| 287 : | |||
| 288 : | : remove-class-order ( wid1 ... widn n+n1 class -- n1 ) | ||
| 289 : | \ note: no checks, whether the wordlists are correct | ||
| 290 : | begin | ||
| 291 : | >r nip 1- | ||
| 292 : | r> class-parent @ dup 0= | ||
| 293 : | until | ||
| 294 : | drop ; | ||
| 295 : | |||
| 296 : | anton | 1.18 | : class-previous ( class -- ) \ objects- objects |
| 297 : | crook | 1.12 | \g Drop @var{class}'s wordlists from the search order. No |
| 298 : | \g checking is made whether @var{class}'s wordlists are actually | ||
| 299 : | anton | 1.6 | \g on the search order. |
| 300 : | anton | 1.3 | >r get-order r> remove-class-order set-order ; |
| 301 : | |||
| 302 : | anton | 1.18 | : drop-order class-previous ; \ old name |
| 303 : | |||
| 304 : | anton | 1.15 | : end-methods ( -- ) \ objects- objects |
| 305 : | anton | 1.14 | \g Switch back from defining methods of a class to normal mode |
| 306 : | \g (currently this just restores the old search order). | ||
| 307 : | anton | 1.18 | current-interface @ class-previous ; |
| 308 : | anton | 1.14 | |
| 309 : | anton | 1.10 | : end-class-noname ( align offset -- class ) \ objects- objects |
| 310 : | crook | 1.12 | \g End a class definition. The resulting class is @var{class}. |
| 311 : | anton | 1.14 | public end-methods |
| 312 : | current-interface @ class-inst-size 2! | ||
| 313 : | anton | 1.3 | end-interface-noname ; |
| 314 : | |||
| 315 : | anton | 1.10 | : end-class ( align offset "name" -- ) \ objects- objects |
| 316 : | crook | 1.12 | \g @var{name} execution: @code{-- class}@* |
| 317 : | \g End a class definition. The resulting class is @var{class}. | ||
| 318 : | anton | 1.3 | \ name execution: ( -- class ) |
| 319 : | end-class-noname constant ; | ||
| 320 : | |||
| 321 : | \ classes that implement interfaces | ||
| 322 : | |||
| 323 : | : front-extend-mem ( addr1 u1 u -- addr addr2 u2 ) | ||
| 324 : | crook | 1.12 | \ Extend memory block allocated from the heap by u aus, with the |
| 325 : | anton | 1.3 | \ old stuff coming at the end |
| 326 : | 2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 ) | ||
| 327 : | dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 ) | ||
| 328 : | free throw | ||
| 329 : | r> dup r> ; | ||
| 330 : | |||
| 331 : | anton | 1.10 | : implementation ( interface -- ) \ objects- objects |
| 332 : | crook | 1.12 | \g The current class implements @var{interface}. I.e., you can |
| 333 : | anton | 1.6 | \g use all selectors of the interface in the current class and its |
| 334 : | \g descendents. | ||
| 335 : | anton | 1.3 | dup interface-offset @ ( interface offset ) |
| 336 : | current-interface @ interface-map-offset @ negate over - dup 0> | ||
| 337 : | if \ the interface does not fit in the present class-map | ||
| 338 : | >r current-interface @ interface-map 2@ | ||
| 339 : | r@ front-extend-mem | ||
| 340 : | current-interface @ interface-map 2! | ||
| 341 : | r@ erase | ||
| 342 : | dup negate current-interface @ interface-map-offset ! | ||
| 343 : | r> | ||
| 344 : | then ( interface offset n ) | ||
| 345 : | drop >r | ||
| 346 : | interface-map 2@ save-mem drop ( map ) | ||
| 347 : | current-interface @ dup interface-map 2@ drop | ||
| 348 : | swap interface-map-offset @ + r> + ! ; | ||
| 349 : | anton | 1.1 | |
| 350 : | \ this/self, instance variables etc. | ||
| 351 : | |||
| 352 : | anton | 1.3 | \ rename "this" into "self" if you are a Smalltalk fiend |
| 353 : | anton | 1.10 | 0 value this ( -- object ) \ objects- objects |
| 354 : | anton | 1.6 | \g the receiving object of the current method (aka active object). |
| 355 : | anton | 1.10 | : to-this ( object -- ) \ objects- objects |
| 356 : | crook | 1.12 | \g Set @code{this} (used internally, but useful when debugging). |
| 357 : | anton | 1.3 | TO this ; |
| 358 : | |||
| 359 : | \ another implementation, if you don't have (fast) values | ||
| 360 : | \ variable thisp | ||
| 361 : | \ : this ( -- object ) | ||
| 362 : | \ thisp @ ; | ||
| 363 : | \ : to-this ( object -- ) | ||
| 364 : | \ thisp ! ; | ||
| 365 : | anton | 1.1 | |
| 366 : | anton | 1.16 | : enterm ( -- ; run-time: object -- ) |
| 367 : | \g method prologue; @var{object} becomes new @code{this}. | ||
| 368 : | anton | 1.1 | POSTPONE this |
| 369 : | POSTPONE >r | ||
| 370 : | anton | 1.3 | POSTPONE to-this ; |
| 371 : | anton | 1.16 | |
| 372 : | : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects | ||
| 373 : | \g Start a method definition; @var{object} becomes new @code{this}. | ||
| 374 : | :noname enterm ; | ||
| 375 : | |||
| 376 : | : :m ( "name" -- xt; run-time: object -- ) \ objects- objects | ||
| 377 : | \g Start a named method definition; @var{object} becomes new | ||
| 378 : | \g @code{this}. Has to be ended with @code{;m}. | ||
| 379 : | : enterm ; | ||
| 380 : | anton | 1.1 | |
| 381 : | anton | 1.10 | : exitm ( -- ) \ objects- objects |
| 382 : | anton | 1.6 | \g @code{exit} from a method; restore old @code{this}. |
| 383 : | anton | 1.5 | POSTPONE r> |
| 384 : | POSTPONE to-this | ||
| 385 : | POSTPONE exit ; immediate | ||
| 386 : | |||
| 387 : | anton | 1.10 | : ;m ( colon-sys --; run-time: -- ) \ objects- objects |
| 388 : | crook | 1.12 | \g End a method definition; restore old @code{this}. |
| 389 : | anton | 1.1 | POSTPONE r> |
| 390 : | anton | 1.3 | POSTPONE to-this |
| 391 : | anton | 1.1 | POSTPONE ; ; immediate |
| 392 : | |||
| 393 : | anton | 1.7 | : catch ( ... xt -- ... n ) \ exception |
| 394 : | crook | 1.12 | \ Make it safe to call CATCH within a method. |
| 395 : | anton | 1.1 | \ should also be done with all words containing CATCH. |
| 396 : | anton | 1.3 | this >r catch r> to-this ; |
| 397 : | |||
| 398 : | \ the following is a bit roundabout; this is caused by the standard | ||
| 399 : | \ disallowing to change the compilation wordlist between CREATE and | ||
| 400 : | \ DOES> (see RFI 3) | ||
| 401 : | |||
| 402 : | anton | 1.4 | : inst-something ( align1 size1 align size xt "name" -- align2 size2 ) |
| 403 : | anton | 1.3 | \ xt ( -- ) typically is for a DOES>-word |
| 404 : | get-current >r | ||
| 405 : | current-interface @ class-wordlist @ set-current | ||
| 406 : | >r create-field r> execute | ||
| 407 : | r> set-current ; | ||
| 408 : | anton | 1.1 | |
| 409 : | anton | 1.3 | : do-inst-var ( -- ) |
| 410 : | does> \ name execution: ( -- addr ) | ||
| 411 : | anton | 1.1 | ( addr1 ) @ this + ; |
| 412 : | |||
| 413 : | anton | 1.10 | : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects |
| 414 : | crook | 1.12 | \g @var{name} execution: @code{-- addr}@* |
| 415 : | \g @var{addr} is the address of the field @var{name} in | ||
| 416 : | anton | 1.6 | \g @code{this} object. |
| 417 : | anton | 1.3 | ['] do-inst-var inst-something ; |
| 418 : | |||
| 419 : | : do-inst-value ( -- ) | ||
| 420 : | does> \ name execution: ( -- w ) | ||
| 421 : | ( addr1 ) @ this + @ ; | ||
| 422 : | |||
| 423 : | anton | 1.10 | : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects |
| 424 : | crook | 1.12 | \g @var{name} execution: @code{-- w}@* |
| 425 : | \g @var{w} is the value of the field @var{name} in @code{this} | ||
| 426 : | anton | 1.6 | \g object. |
| 427 : | anton | 1.4 | cell% ['] do-inst-value inst-something ; |
| 428 : | anton | 1.3 | |
| 429 : | anton | 1.10 | : <to-inst> ( w xt -- ) \ objects- objects |
| 430 : | crook | 1.12 | \g store @var{w} into the field @var{xt} in @code{this} object. |
| 431 : | anton | 1.3 | >body @ this + ! ; |
| 432 : | |||
| 433 : | anton | 1.10 | : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects |
| 434 : | crook | 1.12 | \g store @var{w} into field @var{name} in @code{this} object. |
| 435 : | anton | 1.3 | ' >body @ POSTPONE literal |
| 436 : | POSTPONE this | ||
| 437 : | POSTPONE + | ||
| 438 : | POSTPONE ! ; immediate | ||
| 439 : | |||
| 440 : | anton | 1.4 | \ class binding stuff |
| 441 : | anton | 1.1 | |
| 442 : | anton | 1.10 | : <bind> ( class selector-xt -- xt ) \ objects- objects |
| 443 : | crook | 1.12 | \g @var{xt} is the method for the selector @var{selector-xt} in |
| 444 : | \g @var{class}. | ||
| 445 : | anton | 1.3 | >body swap class->map over selector-interface @ |
| 446 : | ?dup-if | ||
| 447 : | + @ | ||
| 448 : | then | ||
| 449 : | swap selector-offset @ + @ ; | ||
| 450 : | anton | 1.1 | |
| 451 : | anton | 1.10 | : bind' ( "class" "selector" -- xt ) \ objects- objects |
| 452 : | crook | 1.12 | \g @var{xt} is the method for @var{selector} in @var{class}. |
| 453 : | anton | 1.3 | ' execute ' <bind> ; |
| 454 : | anton | 1.1 | |
| 455 : | anton | 1.10 | : bind ( ... "class" "selector" -- ... ) \ objects- objects |
| 456 : | crook | 1.12 | \g Execute the method for @var{selector} in @var{class}. |
| 457 : | anton | 1.1 | bind' execute ; |
| 458 : | |||
| 459 : | anton | 1.10 | : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects |
| 460 : | crook | 1.12 | \g Compile the method for @var{selector} in @var{class}. |
| 461 : | anton | 1.1 | bind' compile, ; immediate |
| 462 : | |||
| 463 : | anton | 1.10 | : current' ( "selector" -- xt ) \ objects- objects |
| 464 : | crook | 1.12 | \g @var{xt} is the method for @var{selector} in the current class. |
| 465 : | anton | 1.4 | current-interface @ ' <bind> ; |
| 466 : | |||
| 467 : | anton | 1.10 | : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects |
| 468 : | crook | 1.12 | \g Compile the method for @var{selector} in the current class. |
| 469 : | anton | 1.4 | current' compile, ; immediate |
| 470 : | |||
| 471 : | anton | 1.10 | : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects |
| 472 : | crook | 1.12 | \g Compile the method for @var{selector} in the parent of the |
| 473 : | anton | 1.6 | \g current class. |
| 474 : | anton | 1.3 | current-interface @ class-parent @ ' <bind> compile, ; immediate |
| 475 : | |||
| 476 : | anton | 1.1 | \ the object class |
| 477 : | |||
| 478 : | anton | 1.3 | \ because OBJECT has no parent class, we have to build it by hand |
| 479 : | \ (instead of with class) | ||
| 480 : | |||
| 481 : | anton | 1.4 | class% %allot current-interface ! |
| 482 : | current-interface 1 cells save-mem current-interface @ interface-map 2! | ||
| 483 : | 0 current-interface @ interface-map-offset ! | ||
| 484 : | 0 current-interface @ interface-offset ! | ||
| 485 : | 0 current-interface @ class-parent ! | ||
| 486 : | wordlist current-interface @ class-wordlist ! | ||
| 487 : | object% | ||
| 488 : | anton | 1.18 | current-interface @ class>order |
| 489 : | anton | 1.3 | |
| 490 : | anton | 1.5 | ' drop ( object -- ) |
| 491 : | anton | 1.10 | method construct ( ... object -- ) \ objects- objects |
| 492 : | crook | 1.12 | \g Initialize the data fields of @var{object}. The method for the |
| 493 : | \g class @var{object} just does nothing: @code{( object -- )}. | ||
| 494 : | anton | 1.3 | |
| 495 : | :noname ( object -- ) | ||
| 496 : | ." object:" dup . ." class:" object-map @ @ . ; | ||
| 497 : | anton | 1.10 | method print ( object -- ) \ objects- objects |
| 498 : | crook | 1.12 | \g Print the object. The method for the class @var{object} prints |
| 499 : | anton | 1.6 | \g the address of the object and the address of its class. |
| 500 : | anton | 1.3 | |
| 501 : | anton | 1.17 | selector equal ( object1 object2 -- flag ) |
| 502 : | |||
| 503 : | anton | 1.10 | end-class object ( -- class ) \ objects- objects |
| 504 : | anton | 1.6 | \g the ancestor of all classes. |
| 505 : | anton | 1.1 | |
| 506 : | anton | 1.3 | \ constructing objects |
| 507 : | anton | 1.1 | |
| 508 : | anton | 1.10 | : init-object ( ... class object -- ) \ objects- objects |
| 509 : | crook | 1.12 | \g Initialize a chunk of memory (@var{object}) to an object of |
| 510 : | \g class @var{class}; then performs @code{construct}. | ||
| 511 : | anton | 1.3 | swap class->map over object-map ! ( ... object ) |
| 512 : | construct ; | ||
| 513 : | |||
| 514 : | anton | 1.10 | : xt-new ( ... class xt -- object ) \ objects- objects |
| 515 : | crook | 1.12 | \g Make a new object, using @code{xt ( align size -- addr )} to |
| 516 : | anton | 1.6 | \g get memory. |
| 517 : | anton | 1.3 | over class-inst-size 2@ rot execute |
| 518 : | dup >r init-object r> ; | ||
| 519 : | |||
| 520 : | anton | 1.10 | : dict-new ( ... class -- object ) \ objects- objects |
| 521 : | crook | 1.12 | \g @code{allot} and initialize an object of class @var{class} in |
| 522 : | anton | 1.6 | \g the dictionary. |
| 523 : | anton | 1.4 | ['] %allot xt-new ; |
| 524 : | anton | 1.3 | |
| 525 : | anton | 1.10 | : heap-new ( ... class -- object ) \ objects- objects |
| 526 : | crook | 1.12 | \g @code{allocate} and initialize an object of class @var{class}. |
| 527 : | anton | 1.4 | ['] %alloc xt-new ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |