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