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.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 : | : -rot ( a b c -- c a b ) | ||
| 45 : | rot rot ; | ||
| 46 : | |||
| 47 : | : perform ( ... addr -- ... ) | ||
| 48 : | @ execute ; | ||
| 49 : | |||
| 50 : | anton | 1.3 | : ?dup-if ( compilation: -- orig ; run-time: n -- n| ) |
| 51 : | POSTPONE ?dup POSTPONE if ; immediate | ||
| 52 : | |||
| 53 : | anton | 1.1 | : save-mem ( addr1 u -- addr2 u ) \ gforth |
| 54 : | \ copy a memory block into a newly allocated region in the heap | ||
| 55 : | swap >r | ||
| 56 : | dup allocate throw | ||
| 57 : | swap 2dup r> -rot move ; | ||
| 58 : | |||
| 59 : | anton | 1.3 | : resize ( a-addr1 u -- a-addr2 ior ) \ gforth |
| 60 : | over | ||
| 61 : | if | ||
| 62 : | resize | ||
| 63 : | else | ||
| 64 : | nip allocate | ||
| 65 : | then ; | ||
| 66 : | |||
| 67 : | anton | 1.1 | : extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
| 68 : | \ extend memory block allocated from the heap by u aus | ||
| 69 : | anton | 1.4 | \ the (possibly reallocated) piece is addr2 u2, the extension is at addr |
| 70 : | anton | 1.1 | over >r + dup >r resize throw |
| 71 : | r> over r> + -rot ; | ||
| 72 : | |||
| 73 : | anton | 1.3 | \ data structures |
| 74 : | anton | 1.1 | |
| 75 : | struct | ||
| 76 : | anton | 1.4 | cell% field object-map |
| 77 : | end-struct object% | ||
| 78 : | anton | 1.1 | |
| 79 : | struct | ||
| 80 : | anton | 1.4 | cell% 2* field interface-map |
| 81 : | cell% field interface-map-offset \ aus | ||
| 82 : | anton | 1.3 | \ difference between where interface-map points and where |
| 83 : | \ object-map points (0 for non-classes) | ||
| 84 : | anton | 1.4 | cell% field interface-offset \ aus |
| 85 : | anton | 1.3 | \ offset of interface map-pointer in class-map (0 for classes) |
| 86 : | anton | 1.4 | end-struct interface% |
| 87 : | anton | 1.3 | |
| 88 : | anton | 1.4 | interface% |
| 89 : | cell% field class-parent | ||
| 90 : | anton | 1.5 | cell% field class-wordlist \ inst-vars and other protected words |
| 91 : | anton | 1.4 | cell% 2* field class-inst-size \ size and alignment |
| 92 : | end-struct class% | ||
| 93 : | anton | 1.1 | |
| 94 : | anton | 1.3 | struct |
| 95 : | anton | 1.4 | cell% field selector-offset \ the offset within the (interface) map |
| 96 : | cell% field selector-interface \ the interface offset | ||
| 97 : | end-struct selector% | ||
| 98 : | anton | 1.3 | |
| 99 : | \ maps are not defined explicitly; they have the following structure: | ||
| 100 : | |||
| 101 : | \ pointers to interface maps (for classes) <- interface-map points here | ||
| 102 : | anton | 1.4 | \ interface%/class% pointer <- (object-)map points here |
| 103 : | anton | 1.3 | \ xts of methods |
| 104 : | |||
| 105 : | anton | 1.1 | |
| 106 : | anton | 1.3 | \ code |
| 107 : | anton | 1.1 | |
| 108 : | anton | 1.3 | \ selectors and methods |
| 109 : | |||
| 110 : | variable current-interface | ||
| 111 : | anton | 1.1 | |
| 112 : | : no-method ( -- ) | ||
| 113 : | anton | 1.3 | true abort" no method defined for this object/selector combination" ; |
| 114 : | |||
| 115 : | : do-class-method ( -- ) | ||
| 116 : | does> ( ... object -- ... ) | ||
| 117 : | anton | 1.5 | ( object selector-body ) |
| 118 : | anton | 1.3 | selector-offset @ over object-map @ + ( object xtp ) perform ; |
| 119 : | |||
| 120 : | : do-interface-method ( -- ) | ||
| 121 : | does> ( ... object -- ... ) | ||
| 122 : | ( object selector-body ) | ||
| 123 : | 2dup selector-interface @ ( object selector-body object interface-offset ) | ||
| 124 : | swap object-map @ + @ ( object selector-body map ) | ||
| 125 : | swap selector-offset @ + perform ; | ||
| 126 : | anton | 1.1 | |
| 127 : | : method ( xt "name" -- ) | ||
| 128 : | anton | 1.3 | \ define selector with method xt |
| 129 : | create | ||
| 130 : | current-interface @ interface-map 2@ ( xt map-addr map-size ) | ||
| 131 : | dup current-interface @ interface-map-offset @ - , | ||
| 132 : | 1 cells extend-mem current-interface @ interface-map 2! ! ( ) | ||
| 133 : | current-interface @ interface-offset @ dup , | ||
| 134 : | ( 0<> ) if | ||
| 135 : | do-interface-method | ||
| 136 : | else | ||
| 137 : | do-class-method | ||
| 138 : | then ; | ||
| 139 : | anton | 1.1 | |
| 140 : | : selector ( "name" -- ) | ||
| 141 : | \ define a method selector for later overriding in subclasses | ||
| 142 : | ['] no-method method ; | ||
| 143 : | |||
| 144 : | anton | 1.3 | : interface-override! ( xt sel-xt interface-map -- ) |
| 145 : | \ xt is the new method for the selector sel-xt in interface-map | ||
| 146 : | swap >body ( xt map selector-body ) | ||
| 147 : | selector-offset @ + ! ; | ||
| 148 : | |||
| 149 : | : class->map ( class -- map ) | ||
| 150 : | \ compute the (object-)map for the class | ||
| 151 : | dup interface-map 2@ drop swap interface-map-offset @ + ; | ||
| 152 : | |||
| 153 : | : unique-interface-map ( class-map offset -- ) | ||
| 154 : | \ if the interface at offset in class map is the same as its parent, | ||
| 155 : | \ copy it to make it unique; used for implementing a copy-on-write policy | ||
| 156 : | over @ class-parent @ class->map ( class-map offset parent-map ) | ||
| 157 : | over + @ >r \ the map for the interface for the parent | ||
| 158 : | + dup @ ( mapp map ) | ||
| 159 : | dup r> = | ||
| 160 : | if | ||
| 161 : | @ interface-map 2@ save-mem drop | ||
| 162 : | swap ! | ||
| 163 : | else | ||
| 164 : | 2drop | ||
| 165 : | then ; | ||
| 166 : | |||
| 167 : | : class-override! ( xt sel-xt class-map -- ) | ||
| 168 : | \ xt is the new method for the selector sel-xt in class-map | ||
| 169 : | over >body ( xt sel-xt class-map selector-body ) | ||
| 170 : | selector-interface @ ( xt sel-xt class-map offset ) | ||
| 171 : | ?dup-if \ the selector is for an interface | ||
| 172 : | 2dup unique-interface-map | ||
| 173 : | + @ | ||
| 174 : | then | ||
| 175 : | interface-override! ; | ||
| 176 : | anton | 1.1 | |
| 177 : | : overrides ( xt "selector" -- ) | ||
| 178 : | anton | 1.5 | \ replace default method for "selector" in the current class with xt |
| 179 : | anton | 1.3 | \ must not be used during an interface definition |
| 180 : | ' current-interface @ class->map class-override! ; | ||
| 181 : | |||
| 182 : | \ interfaces | ||
| 183 : | |||
| 184 : | \ every interface gets a different offset; the latest one is stored here | ||
| 185 : | variable last-interface-offset 0 last-interface-offset ! | ||
| 186 : | |||
| 187 : | : interface ( -- ) | ||
| 188 : | anton | 1.4 | interface% %allot >r |
| 189 : | anton | 1.3 | 0 0 r@ interface-map 2! |
| 190 : | -1 cells last-interface-offset +! | ||
| 191 : | last-interface-offset @ r@ interface-offset ! | ||
| 192 : | 0 r@ interface-map-offset ! | ||
| 193 : | r> current-interface ! ; | ||
| 194 : | |||
| 195 : | : end-interface-noname ( -- interface ) | ||
| 196 : | current-interface @ ; | ||
| 197 : | |||
| 198 : | : end-interface ( "name" -- ) | ||
| 199 : | \ name execution: ( -- interface ) | ||
| 200 : | end-interface-noname constant ; | ||
| 201 : | |||
| 202 : | \ classes | ||
| 203 : | |||
| 204 : | : add-class-order ( n1 class -- wid1 ... widn n+n1 ) | ||
| 205 : | dup >r class-parent @ | ||
| 206 : | ?dup-if | ||
| 207 : | recurse \ first add the search order for the parent class | ||
| 208 : | then | ||
| 209 : | r> class-wordlist @ swap 1+ ; | ||
| 210 : | |||
| 211 : | : push-order ( class -- ) | ||
| 212 : | \ add the class's wordlist to the search-order (in front) | ||
| 213 : | >r get-order r> add-class-order set-order ; | ||
| 214 : | |||
| 215 : | anton | 1.4 | : class ( parent-class -- align size ) |
| 216 : | class% %allot >r | ||
| 217 : | anton | 1.3 | dup interface-map 2@ save-mem r@ interface-map 2! |
| 218 : | dup interface-map-offset @ r@ interface-map-offset ! | ||
| 219 : | r@ dup class->map ! | ||
| 220 : | 0 r@ interface-offset ! | ||
| 221 : | dup r@ class-parent ! | ||
| 222 : | wordlist r@ class-wordlist ! | ||
| 223 : | r@ current-interface ! | ||
| 224 : | r> push-order | ||
| 225 : | class-inst-size 2@ ; | ||
| 226 : | |||
| 227 : | : remove-class-order ( wid1 ... widn n+n1 class -- n1 ) | ||
| 228 : | \ note: no checks, whether the wordlists are correct | ||
| 229 : | begin | ||
| 230 : | >r nip 1- | ||
| 231 : | r> class-parent @ dup 0= | ||
| 232 : | until | ||
| 233 : | drop ; | ||
| 234 : | |||
| 235 : | : drop-order ( class -- ) | ||
| 236 : | \ note: no checks, whether the wordlists are correct | ||
| 237 : | >r get-order r> remove-class-order set-order ; | ||
| 238 : | |||
| 239 : | anton | 1.4 | : end-class-noname ( align size -- class ) |
| 240 : | anton | 1.3 | current-interface @ dup drop-order class-inst-size 2! |
| 241 : | end-interface-noname ; | ||
| 242 : | |||
| 243 : | anton | 1.4 | : end-class ( align size "name" -- ) |
| 244 : | anton | 1.3 | \ name execution: ( -- class ) |
| 245 : | end-class-noname constant ; | ||
| 246 : | anton | 1.1 | |
| 247 : | anton | 1.3 | \ visibility control |
| 248 : | |||
| 249 : | variable public-wordlist | ||
| 250 : | |||
| 251 : | anton | 1.4 | : protected ( -- ) |
| 252 : | anton | 1.3 | current-interface @ class-wordlist @ |
| 253 : | dup get-current <> | ||
| 254 : | anton | 1.4 | if \ we are not protected already |
| 255 : | anton | 1.3 | get-current public-wordlist ! |
| 256 : | then | ||
| 257 : | set-current ; | ||
| 258 : | |||
| 259 : | : public ( -- ) | ||
| 260 : | public-wordlist @ set-current ; | ||
| 261 : | |||
| 262 : | \ classes that implement interfaces | ||
| 263 : | |||
| 264 : | : front-extend-mem ( addr1 u1 u -- addr addr2 u2 ) | ||
| 265 : | \ extend memory block allocated from the heap by u aus, with the | ||
| 266 : | \ old stuff coming at the end | ||
| 267 : | 2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 ) | ||
| 268 : | dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 ) | ||
| 269 : | free throw | ||
| 270 : | r> dup r> ; | ||
| 271 : | |||
| 272 : | : implementation ( interface -- ) | ||
| 273 : | dup interface-offset @ ( interface offset ) | ||
| 274 : | current-interface @ interface-map-offset @ negate over - dup 0> | ||
| 275 : | if \ the interface does not fit in the present class-map | ||
| 276 : | >r current-interface @ interface-map 2@ | ||
| 277 : | r@ front-extend-mem | ||
| 278 : | current-interface @ interface-map 2! | ||
| 279 : | r@ erase | ||
| 280 : | dup negate current-interface @ interface-map-offset ! | ||
| 281 : | r> | ||
| 282 : | then ( interface offset n ) | ||
| 283 : | drop >r | ||
| 284 : | interface-map 2@ save-mem drop ( map ) | ||
| 285 : | current-interface @ dup interface-map 2@ drop | ||
| 286 : | swap interface-map-offset @ + r> + ! ; | ||
| 287 : | anton | 1.1 | |
| 288 : | \ this/self, instance variables etc. | ||
| 289 : | |||
| 290 : | anton | 1.3 | \ rename "this" into "self" if you are a Smalltalk fiend |
| 291 : | 0 value this ( -- object ) | ||
| 292 : | : to-this ( object -- ) | ||
| 293 : | TO this ; | ||
| 294 : | |||
| 295 : | \ another implementation, if you don't have (fast) values | ||
| 296 : | \ variable thisp | ||
| 297 : | \ : this ( -- object ) | ||
| 298 : | \ thisp @ ; | ||
| 299 : | \ : to-this ( object -- ) | ||
| 300 : | \ thisp ! ; | ||
| 301 : | anton | 1.1 | |
| 302 : | : m: ( -- xt colon-sys ) ( run-time: object -- ) | ||
| 303 : | :noname | ||
| 304 : | POSTPONE this | ||
| 305 : | POSTPONE >r | ||
| 306 : | anton | 1.3 | POSTPONE to-this ; |
| 307 : | anton | 1.1 | |
| 308 : | anton | 1.5 | : exitm ( -- ) |
| 309 : | POSTPONE r> | ||
| 310 : | POSTPONE to-this | ||
| 311 : | POSTPONE exit ; immediate | ||
| 312 : | |||
| 313 : | anton | 1.1 | : ;m ( colon-sys -- ) ( run-time: -- ) |
| 314 : | POSTPONE r> | ||
| 315 : | anton | 1.3 | POSTPONE to-this |
| 316 : | anton | 1.1 | POSTPONE ; ; immediate |
| 317 : | |||
| 318 : | : catch ( ... xt -- ... n ) | ||
| 319 : | \ make it safe to call CATCH within a method. | ||
| 320 : | \ should also be done with all words containing CATCH. | ||
| 321 : | anton | 1.3 | this >r catch r> to-this ; |
| 322 : | |||
| 323 : | \ the following is a bit roundabout; this is caused by the standard | ||
| 324 : | \ disallowing to change the compilation wordlist between CREATE and | ||
| 325 : | \ DOES> (see RFI 3) | ||
| 326 : | |||
| 327 : | anton | 1.4 | : inst-something ( align1 size1 align size xt "name" -- align2 size2 ) |
| 328 : | anton | 1.3 | \ xt ( -- ) typically is for a DOES>-word |
| 329 : | get-current >r | ||
| 330 : | current-interface @ class-wordlist @ set-current | ||
| 331 : | >r create-field r> execute | ||
| 332 : | r> set-current ; | ||
| 333 : | anton | 1.1 | |
| 334 : | anton | 1.3 | : do-inst-var ( -- ) |
| 335 : | does> \ name execution: ( -- addr ) | ||
| 336 : | anton | 1.1 | ( addr1 ) @ this + ; |
| 337 : | |||
| 338 : | anton | 1.4 | : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) |
| 339 : | anton | 1.3 | \ name execution: ( -- addr ) |
| 340 : | ['] do-inst-var inst-something ; | ||
| 341 : | |||
| 342 : | : do-inst-value ( -- ) | ||
| 343 : | does> \ name execution: ( -- w ) | ||
| 344 : | ( addr1 ) @ this + @ ; | ||
| 345 : | |||
| 346 : | anton | 1.4 | : inst-value ( align1 offset1 "name" -- align2 offset2 ) |
| 347 : | anton | 1.3 | \ name execution: ( -- w ) |
| 348 : | \ a cell-sized value-flavoured instance field | ||
| 349 : | anton | 1.4 | cell% ['] do-inst-value inst-something ; |
| 350 : | anton | 1.3 | |
| 351 : | : <to-inst> ( w xt -- ) | ||
| 352 : | >body @ this + ! ; | ||
| 353 : | |||
| 354 : | : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) | ||
| 355 : | ' >body @ POSTPONE literal | ||
| 356 : | POSTPONE this | ||
| 357 : | POSTPONE + | ||
| 358 : | POSTPONE ! ; immediate | ||
| 359 : | |||
| 360 : | anton | 1.4 | \ class binding stuff |
| 361 : | anton | 1.1 | |
| 362 : | anton | 1.3 | : <bind> ( class selector-xt -- xt ) |
| 363 : | >body swap class->map over selector-interface @ | ||
| 364 : | ?dup-if | ||
| 365 : | + @ | ||
| 366 : | then | ||
| 367 : | swap selector-offset @ + @ ; | ||
| 368 : | anton | 1.1 | |
| 369 : | anton | 1.3 | : bind' ( "class" "selector" -- xt ) |
| 370 : | ' execute ' <bind> ; | ||
| 371 : | anton | 1.1 | |
| 372 : | anton | 1.5 | : bind ( ... "class" "selector" -- ... ) |
| 373 : | anton | 1.1 | bind' execute ; |
| 374 : | |||
| 375 : | anton | 1.3 | : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) |
| 376 : | anton | 1.1 | bind' compile, ; immediate |
| 377 : | |||
| 378 : | anton | 1.4 | : current' ( "selector" -- xt ) |
| 379 : | current-interface @ ' <bind> ; | ||
| 380 : | |||
| 381 : | : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) | ||
| 382 : | current' compile, ; immediate | ||
| 383 : | |||
| 384 : | : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) | ||
| 385 : | anton | 1.3 | \ same as `[bind] "parent" "selector"', where "parent" is the |
| 386 : | \ parent class of the current class | ||
| 387 : | current-interface @ class-parent @ ' <bind> compile, ; immediate | ||
| 388 : | |||
| 389 : | anton | 1.1 | \ the object class |
| 390 : | |||
| 391 : | anton | 1.3 | \ because OBJECT has no parent class, we have to build it by hand |
| 392 : | \ (instead of with class) | ||
| 393 : | |||
| 394 : | anton | 1.4 | class% %allot current-interface ! |
| 395 : | current-interface 1 cells save-mem current-interface @ interface-map 2! | ||
| 396 : | 0 current-interface @ interface-map-offset ! | ||
| 397 : | 0 current-interface @ interface-offset ! | ||
| 398 : | 0 current-interface @ class-parent ! | ||
| 399 : | wordlist current-interface @ class-wordlist ! | ||
| 400 : | object% | ||
| 401 : | current-interface @ push-order | ||
| 402 : | anton | 1.3 | |
| 403 : | anton | 1.5 | ' drop ( object -- ) |
| 404 : | anton | 1.3 | method construct ( ... object -- ) |
| 405 : | |||
| 406 : | :noname ( object -- ) | ||
| 407 : | ." object:" dup . ." class:" object-map @ @ . ; | ||
| 408 : | anton | 1.1 | method print |
| 409 : | anton | 1.3 | |
| 410 : | anton | 1.1 | end-class object |
| 411 : | |||
| 412 : | anton | 1.3 | \ constructing objects |
| 413 : | anton | 1.1 | |
| 414 : | anton | 1.3 | : init-object ( ... class object -- ) |
| 415 : | swap class->map over object-map ! ( ... object ) | ||
| 416 : | construct ; | ||
| 417 : | |||
| 418 : | : xt-new ( ... class xt -- object ) | ||
| 419 : | anton | 1.4 | \ makes a new object, using XT ( align size -- addr ) to allocate memory |
| 420 : | anton | 1.3 | over class-inst-size 2@ rot execute |
| 421 : | dup >r init-object r> ; | ||
| 422 : | |||
| 423 : | : dict-new ( ... class -- object ) | ||
| 424 : | \ makes a new object HERE in dictionary | ||
| 425 : | anton | 1.4 | ['] %allot xt-new ; |
| 426 : | anton | 1.3 | |
| 427 : | : heap-new ( ... class -- object ) | ||
| 428 : | \ makes a new object in ALLOCATEd memory | ||
| 429 : | anton | 1.4 | ['] %alloc xt-new ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |