Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.15 | |
| 2 : | pazsan | 1.1 | \ oof.fs Object Oriented FORTH |
| 3 : | pazsan | 1.15 | \ This file is (c) 1996,2000 by Bernd Paysan |
| 4 : | \ e-mail: bernd.paysan@gmx.de | ||
| 5 : | pazsan | 1.1 | \ |
| 6 : | \ Please copy and share this program, modify it for your system | ||
| 7 : | \ and improve it as you like. But don't remove this notice. | ||
| 8 : | \ | ||
| 9 : | \ Thank you. | ||
| 10 : | \ | ||
| 11 : | pazsan | 1.15 | |
| 12 : | \ The program uses the following words | ||
| 13 : | \ from CORE : | ||
| 14 : | \ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ | ||
| 15 : | \ IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ | ||
| 16 : | \ Literal drop align here aligned DOES> execute ['] 2@ recurse swap | ||
| 17 : | \ 1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop | ||
| 18 : | \ BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count | ||
| 19 : | \ from CORE-EXT : | ||
| 20 : | \ nip false Value tuck true ?DO compile, erase pick :noname 0<> | ||
| 21 : | \ from BLOCK-EXT : | ||
| 22 : | \ \ | ||
| 23 : | \ from EXCEPTION : | ||
| 24 : | \ throw | ||
| 25 : | \ from EXCEPTION-EXT : | ||
| 26 : | \ abort" | ||
| 27 : | \ from FILE : | ||
| 28 : | \ ( S" | ||
| 29 : | \ from FLOAT : | ||
| 30 : | \ faligned | ||
| 31 : | \ from LOCAL : | ||
| 32 : | \ TO | ||
| 33 : | \ from MEMORY : | ||
| 34 : | \ allocate free | ||
| 35 : | \ from SEARCH : | ||
| 36 : | \ find definitions get-order set-order get-current wordlist | ||
| 37 : | \ set-current search-wordlist | ||
| 38 : | \ from SEARCH-EXT : | ||
| 39 : | \ also Forth previous | ||
| 40 : | \ from STRING : | ||
| 41 : | \ /string compare | ||
| 42 : | \ from TOOLS-EXT : | ||
| 43 : | \ [IF] [THEN] [ELSE] state | ||
| 44 : | \ from non-ANS : | ||
| 45 : | \ cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G | ||
| 46 : | pazsan | 1.1 | |
| 47 : | \ Loadscreen 27dec95py | ||
| 48 : | |||
| 49 : | decimal | ||
| 50 : | |||
| 51 : | : define? ( -- flag ) | ||
| 52 : | bl word find nip 0= ; | ||
| 53 : | |||
| 54 : | pazsan | 1.7 | define? cell [IF] |
| 55 : | 1 cells Constant cell | ||
| 56 : | [THEN] | ||
| 57 : | pazsan | 1.1 | |
| 58 : | pazsan | 1.15 | define? \G [IF] |
| 59 : | : \G postpone \ ; immediate | ||
| 60 : | [THEN] | ||
| 61 : | |||
| 62 : | pazsan | 1.1 | define? ?EXIT [IF] |
| 63 : | : ?EXIT postpone IF postpone EXIT postpone THEN ; immediate | ||
| 64 : | [THEN] | ||
| 65 : | |||
| 66 : | define? Vocabulary [IF] | ||
| 67 : | : Vocabulary wordlist create , | ||
| 68 : | DOES> @ >r get-order nip r> swap set-order ; | ||
| 69 : | [THEN] | ||
| 70 : | |||
| 71 : | pazsan | 1.7 | define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN] |
| 72 : | [IF] | ||
| 73 : | : 8aligned ( n1 -- n2 ) faligned ; | ||
| 74 : | [ELSE] | ||
| 75 : | : 8aligned ( n1 -- n2 ) 7 + -8 and ; | ||
| 76 : | [THEN] | ||
| 77 : | |||
| 78 : | pazsan | 1.1 | Vocabulary Objects also Objects also definitions |
| 79 : | |||
| 80 : | Vocabulary types types also | ||
| 81 : | |||
| 82 : | 0 cells Constant :wordlist | ||
| 83 : | 1 cells Constant :parent | ||
| 84 : | 2 cells Constant :child | ||
| 85 : | 3 cells Constant :next | ||
| 86 : | 4 cells Constant :method# | ||
| 87 : | 5 cells Constant :var# | ||
| 88 : | 6 cells Constant :newlink | ||
| 89 : | 7 cells Constant :iface | ||
| 90 : | 8 cells Constant :init | ||
| 91 : | |||
| 92 : | 0 cells Constant :inext | ||
| 93 : | 1 cells Constant :ilist | ||
| 94 : | 2 cells Constant :ilen | ||
| 95 : | 3 cells Constant :inum | ||
| 96 : | |||
| 97 : | Variable op | ||
| 98 : | : op! ( o -- ) op ! ; | ||
| 99 : | |||
| 100 : | Forth definitions | ||
| 101 : | |||
| 102 : | Create ostack 0 , 16 cells allot | ||
| 103 : | |||
| 104 : | : ^ ( -- o ) op @ ; | ||
| 105 : | : o@ ( -- o ) op @ @ ; | ||
| 106 : | : >o ( o -- ) | ||
| 107 : | state @ | ||
| 108 : | IF postpone ^ postpone >r postpone op! | ||
| 109 : | ELSE 1 ostack +! ^ ostack dup @ cells + ! op! | ||
| 110 : | THEN ; immediate | ||
| 111 : | : o> ( -- ) | ||
| 112 : | state @ | ||
| 113 : | IF postpone r> postpone op! | ||
| 114 : | ELSE ostack dup @ cells + @ op! -1 ostack +! | ||
| 115 : | THEN ; immediate | ||
| 116 : | : o[] ( n -- ) o@ :var# + @ * ^ + op! ; | ||
| 117 : | |||
| 118 : | Objects definitions | ||
| 119 : | |||
| 120 : | \ Coding 27dec95py | ||
| 121 : | |||
| 122 : | 0 Constant #static | ||
| 123 : | 1 Constant #method | ||
| 124 : | 2 Constant #early | ||
| 125 : | 3 Constant #var | ||
| 126 : | 4 Constant #defer | ||
| 127 : | |||
| 128 : | : exec? ( addr -- flag ) | ||
| 129 : | >body cell+ @ #method = ; | ||
| 130 : | : static? ( addr -- flag ) | ||
| 131 : | >body cell+ @ #static = ; | ||
| 132 : | : early? ( addr -- flag ) | ||
| 133 : | >body cell+ @ #early = ; | ||
| 134 : | : defer? ( addr -- flag ) | ||
| 135 : | >body cell+ @ #defer = ; | ||
| 136 : | |||
| 137 : | pazsan | 1.10 | false Value oset? |
| 138 : | |||
| 139 : | pazsan | 1.1 | : o+, ( addr offset -- ) |
| 140 : | postpone Literal postpone ^ postpone + | ||
| 141 : | pazsan | 1.10 | oset? IF postpone op! ELSE postpone >o THEN drop ; |
| 142 : | pazsan | 1.1 | : o*, ( addr offset -- ) |
| 143 : | postpone Literal postpone * postpone Literal postpone + | ||
| 144 : | pazsan | 1.10 | oset? IF postpone op! ELSE postpone >o THEN ; |
| 145 : | pazsan | 1.1 | : ^+@ ( offset -- addr ) ^ + @ ; |
| 146 : | : o+@, ( addr offset -- ) | ||
| 147 : | pazsan | 1.10 | postpone Literal postpone ^+@ oset? IF postpone op! ELSE postpone >o THEN drop ; |
| 148 : | pazsan | 1.1 | : ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ; |
| 149 : | : o+@*, ( addr offset -- ) | ||
| 150 : | pazsan | 1.10 | postpone Literal postpone ^*@ oset? IF postpone op! ELSE postpone >o THEN drop ; |
| 151 : | pazsan | 1.1 | |
| 152 : | \ variables / memory allocation 30oct94py | ||
| 153 : | |||
| 154 : | Variable lastob | ||
| 155 : | Variable lastparent 0 lastparent ! | ||
| 156 : | Variable vars | ||
| 157 : | Variable methods | ||
| 158 : | Variable decl 0 decl ! | ||
| 159 : | Variable 'link | ||
| 160 : | |||
| 161 : | : crash true abort" unbound method" ; | ||
| 162 : | |||
| 163 : | : link, ( addr -- ) align here 'link ! , 0 , 0 , ; | ||
| 164 : | |||
| 165 : | 0 link, | ||
| 166 : | |||
| 167 : | \ type declaration 30oct94py | ||
| 168 : | |||
| 169 : | : vallot ( size -- offset ) vars @ >r dup vars +! | ||
| 170 : | 'link @ 0= | ||
| 171 : | IF lastparent @ dup IF :newlink + @ THEN link, | ||
| 172 : | THEN | ||
| 173 : | 'link @ 2 cells + +! r> ; | ||
| 174 : | |||
| 175 : | : valign ( -- ) vars @ aligned vars ! ; | ||
| 176 : | define? faligned 0= [IF] | ||
| 177 : | : vfalign ( -- ) vars @ faligned vars ! ; | ||
| 178 : | [THEN] | ||
| 179 : | |||
| 180 : | : mallot ( -- offset ) methods @ cell methods +! ; | ||
| 181 : | |||
| 182 : | types definitions | ||
| 183 : | |||
| 184 : | pazsan | 1.12 | : static ( -- ) \ oof- oof |
| 185 : | crook | 1.14 | \G Create a class-wide cell-sized variable. |
| 186 : | pazsan | 1.12 | mallot Create , #static , |
| 187 : | DOES> @ o@ + ; | ||
| 188 : | : method ( -- ) \ oof- oof | ||
| 189 : | crook | 1.14 | \G Create a method selector. |
| 190 : | pazsan | 1.12 | mallot Create , #method , |
| 191 : | DOES> @ o@ + @ execute ; | ||
| 192 : | : early ( -- ) \ oof- oof | ||
| 193 : | crook | 1.14 | \G Create a method selector for early binding. |
| 194 : | pazsan | 1.12 | Create ['] crash , #early , |
| 195 : | DOES> @ execute ; | ||
| 196 : | : var ( size -- ) \ oof- oof | ||
| 197 : | \G Create an instance variable | ||
| 198 : | vallot Create , #var , | ||
| 199 : | DOES> @ ^ + ; | ||
| 200 : | : defer ( -- ) \ oof- oof | ||
| 201 : | \G Create an instance defer | ||
| 202 : | valign cell vallot Create , #defer , | ||
| 203 : | DOES> @ ^ + @ execute ; | ||
| 204 : | pazsan | 1.1 | |
| 205 : | \ dealing with threads 29oct94py | ||
| 206 : | |||
| 207 : | Objects definitions | ||
| 208 : | |||
| 209 : | : object-order ( wid0 .. widm m addr -- wid0 .. widn n ) | ||
| 210 : | dup IF 2@ >r recurse r> swap 1+ ELSE drop THEN ; | ||
| 211 : | |||
| 212 : | : interface-order ( wid0 .. widm m addr -- wid0 .. widn n ) | ||
| 213 : | dup IF 2@ >r recurse r> :ilist + @ swap 1+ | ||
| 214 : | ELSE drop THEN ; | ||
| 215 : | |||
| 216 : | pazsan | 1.7 | : add-order ( addr -- n ) dup 0= ?EXIT >r |
| 217 : | get-order r> swap >r 0 swap | ||
| 218 : | dup >r object-order r> :iface + @ interface-order | ||
| 219 : | pazsan | 1.1 | r> over >r + set-order r> ; |
| 220 : | |||
| 221 : | : drop-order ( n -- ) 0 ?DO previous LOOP ; | ||
| 222 : | |||
| 223 : | \ object compiling/executing 20feb95py | ||
| 224 : | |||
| 225 : | : o, ( xt early? -- ) | ||
| 226 : | over exec? over and IF | ||
| 227 : | drop >body @ o@ + @ compile, EXIT THEN | ||
| 228 : | over static? over and IF | ||
| 229 : | drop >body @ o@ + @ postpone Literal EXIT THEN | ||
| 230 : | drop dup early? IF >body @ THEN compile, ; | ||
| 231 : | |||
| 232 : | : findo ( string -- cfa n ) | ||
| 233 : | pazsan | 1.7 | o@ add-order >r |
| 234 : | find | ||
| 235 : | pazsan | 1.1 | ?dup 0= IF drop set-order true abort" method not found!" THEN |
| 236 : | pazsan | 1.7 | r> drop-order ; |
| 237 : | pazsan | 1.1 | |
| 238 : | false Value method? | ||
| 239 : | pazsan | 1.7 | |
| 240 : | pazsan | 1.1 | : method, ( object early? -- ) true to method? |
| 241 : | swap >o >r bl word findo 0< state @ and | ||
| 242 : | IF r> o, ELSE r> drop execute THEN o> false to method? ; | ||
| 243 : | |||
| 244 : | pazsan | 1.10 | : cmethod, ( object early? -- ) |
| 245 : | pazsan | 1.15 | state @ dup >r |
| 246 : | 0= IF postpone ] THEN | ||
| 247 : | method, | ||
| 248 : | r> 0= IF postpone [ THEN ; | ||
| 249 : | pazsan | 1.10 | |
| 250 : | pazsan | 1.7 | : early, ( object -- ) true to oset? true method, |
| 251 : | pazsan | 1.10 | state @ oset? and IF postpone o> THEN false to oset? ; |
| 252 : | pazsan | 1.7 | : late, ( object -- ) true to oset? false method, |
| 253 : | pazsan | 1.10 | state @ oset? and IF postpone o> THEN false to oset? ; |
| 254 : | pazsan | 1.1 | |
| 255 : | \ new, 29oct94py | ||
| 256 : | |||
| 257 : | previous Objects definitions | ||
| 258 : | |||
| 259 : | Variable alloc | ||
| 260 : | 0 Value ohere | ||
| 261 : | |||
| 262 : | : oallot ( n -- ) ohere + to ohere ; | ||
| 263 : | |||
| 264 : | : ((new, ( link -- ) | ||
| 265 : | dup @ ?dup IF recurse THEN cell+ 2@ swap ohere + >r | ||
| 266 : | ?dup IF ohere >r dup >r :newlink + @ recurse r> r> ! THEN | ||
| 267 : | r> to ohere ; | ||
| 268 : | |||
| 269 : | : (new ( object -- ) | ||
| 270 : | ohere >r dup >r :newlink + @ ((new, r> r> ! ; | ||
| 271 : | |||
| 272 : | : init-instance ( pos link -- pos ) | ||
| 273 : | dup >r @ ?dup IF recurse THEN r> cell+ 2@ | ||
| 274 : | IF drop dup >r ^ + | ||
| 275 : | >o o@ :init + @ execute 0 o@ :newlink + @ recurse o> | ||
| 276 : | r> THEN + ; | ||
| 277 : | |||
| 278 : | : init-object ( object -- size ) | ||
| 279 : | >o o@ :init + @ execute 0 o@ :newlink + @ init-instance o> ; | ||
| 280 : | |||
| 281 : | : (new, ( object -- ) ohere dup >r over :var# + @ erase (new | ||
| 282 : | r> init-object drop ; | ||
| 283 : | |||
| 284 : | : size@ ( objc -- size ) :var# + @ 8aligned ; | ||
| 285 : | : (new[], ( n o -- addr ) ohere >r | ||
| 286 : | dup size@ rot over * oallot r@ ohere dup >r 2 pick - | ||
| 287 : | ?DO I to ohere >r dup >r (new, r> r> dup negate +LOOP | ||
| 288 : | 2drop r> to ohere r> ; | ||
| 289 : | |||
| 290 : | \ new, 29oct94py | ||
| 291 : | |||
| 292 : | Create chunks here 16 cells dup allot erase | ||
| 293 : | |||
| 294 : | : DelFix ( addr root -- ) dup @ 2 pick ! ! ; | ||
| 295 : | |||
| 296 : | : NewFix ( root size # -- addr ) | ||
| 297 : | BEGIN 2 pick @ ?dup 0= | ||
| 298 : | WHILE 2dup * allocate throw over 0 | ||
| 299 : | ?DO dup 4 pick DelFix 2 pick + | ||
| 300 : | LOOP | ||
| 301 : | drop | ||
| 302 : | REPEAT | ||
| 303 : | >r drop r@ @ rot ! r@ swap erase r> ; | ||
| 304 : | |||
| 305 : | : >chunk ( n -- root n' ) | ||
| 306 : | pazsan | 1.4 | 1- -8 and dup 3 rshift cells chunks + swap 8 + ; |
| 307 : | pazsan | 1.1 | |
| 308 : | : Dalloc ( size -- addr ) | ||
| 309 : | dup 128 > IF allocate throw EXIT THEN | ||
| 310 : | >chunk 2048 over / NewFix ; | ||
| 311 : | |||
| 312 : | : Salloc ( size -- addr ) align here swap allot ; | ||
| 313 : | |||
| 314 : | : dispose, ( addr size -- ) | ||
| 315 : | dup 128 > IF drop free throw EXIT THEN | ||
| 316 : | >chunk drop DelFix ; | ||
| 317 : | |||
| 318 : | : new, ( o -- addr ) dup :var# + @ | ||
| 319 : | alloc @ execute dup >r to ohere (new, r> ; | ||
| 320 : | |||
| 321 : | : new[], ( n o -- addr ) dup :var# + @ 8aligned | ||
| 322 : | 2 pick * alloc @ execute to ohere (new[], ; | ||
| 323 : | |||
| 324 : | Forth definitions | ||
| 325 : | |||
| 326 : | : dynamic ['] Dalloc alloc ! ; dynamic | ||
| 327 : | : static ['] Salloc alloc ! ; | ||
| 328 : | |||
| 329 : | Objects definitions | ||
| 330 : | |||
| 331 : | \ instance creation 29mar94py | ||
| 332 : | |||
| 333 : | : instance, ( o -- ) alloc @ >r static new, r> alloc ! drop | ||
| 334 : | pazsan | 1.15 | DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early, |
| 335 : | ; | ||
| 336 : | pazsan | 1.1 | : ptr, ( o -- ) 0 , , |
| 337 : | DOES> state @ | ||
| 338 : | pazsan | 1.10 | IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+ |
| 339 : | pazsan | 1.1 | ELSE @ THEN late, ; |
| 340 : | |||
| 341 : | : array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop | ||
| 342 : | DOES> ( n -- ) dup dup @ size@ | ||
| 343 : | state @ IF o*, ELSE nip rot * + THEN early, ; | ||
| 344 : | |||
| 345 : | \ class creation 29mar94py | ||
| 346 : | |||
| 347 : | Variable voc# | ||
| 348 : | Variable classlist | ||
| 349 : | Variable old-current | ||
| 350 : | Variable ob-interface | ||
| 351 : | |||
| 352 : | : voc! ( addr -- ) get-current old-current ! | ||
| 353 : | add-order 2 + voc# ! | ||
| 354 : | get-order wordlist tuck classlist ! 1+ set-order | ||
| 355 : | also types classlist @ set-current ; | ||
| 356 : | |||
| 357 : | pazsan | 1.15 | : (class-does> DOES> false method, ; |
| 358 : | |||
| 359 : | : (class ( parent -- ) (class-does> | ||
| 360 : | pazsan | 1.1 | here lastob ! true decl ! 0 ob-interface ! |
| 361 : | 0 , dup voc! dup lastparent ! | ||
| 362 : | pazsan | 1.15 | dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! ; |
| 363 : | pazsan | 1.1 | |
| 364 : | : (is ( addr -- ) bl word findo drop | ||
| 365 : | dup defer? abort" not deferred!" | ||
| 366 : | >body @ state @ | ||
| 367 : | IF postpone ^ postpone Literal postpone + postpone ! | ||
| 368 : | ELSE ^ + ! THEN ; | ||
| 369 : | |||
| 370 : | : inherit ( -- ) bl word findo drop | ||
| 371 : | dup exec? IF >body @ dup o@ + @ swap lastob @ + ! EXIT THEN | ||
| 372 : | abort" Not a polymorph method!" ; | ||
| 373 : | |||
| 374 : | \ instance variables inside objects 27dec93py | ||
| 375 : | |||
| 376 : | : instvar, ( addr -- ) dup , here 0 , 0 vallot swap ! | ||
| 377 : | 'link @ 2 cells + @ IF 'link @ link, THEN | ||
| 378 : | 'link @ >r dup r@ cell+ ! :var# + @ dup vars +! r> 2 cells + ! | ||
| 379 : | DOES> dup 2@ swap state @ IF o+, ELSE ^ + nip nip THEN | ||
| 380 : | early, ; | ||
| 381 : | |||
| 382 : | : instptr> ( -- ) DOES> dup 2@ swap | ||
| 383 : | state @ IF o+@, ELSE ^ + @ nip nip THEN late, ; | ||
| 384 : | |||
| 385 : | : instptr, ( addr -- ) , here 0 , cell vallot swap ! | ||
| 386 : | instptr> ; | ||
| 387 : | |||
| 388 : | : (o* ( i addr -- addr' ) dup @ :var# + @ 8aligned rot * + ; | ||
| 389 : | |||
| 390 : | : instarray, ( addr -- ) , here 0 , cell vallot swap ! | ||
| 391 : | DOES> dup 2@ swap | ||
| 392 : | state @ IF o+@*, ELSE ^ + @ nip nip (o* THEN | ||
| 393 : | late, ; | ||
| 394 : | |||
| 395 : | \ bind instance pointers 27mar94py | ||
| 396 : | |||
| 397 : | : ((link ( addr -- o addr' ) 2@ swap ^ + ; | ||
| 398 : | |||
| 399 : | : (link ( -- o addr ) bl word findo drop >body state @ | ||
| 400 : | IF postpone Literal postpone ((link EXIT THEN ((link ; | ||
| 401 : | |||
| 402 : | : parent? ( class o -- class class' ) @ | ||
| 403 : | BEGIN 2dup = ?EXIT dup WHILE :parent + @ REPEAT ; | ||
| 404 : | |||
| 405 : | : (bound ( obj1 obj2 adr2 -- ) >r over parent? | ||
| 406 : | nip 0= abort" not the same class !" r> ! ; | ||
| 407 : | |||
| 408 : | : (bind ( addr -- ) \ <name> | ||
| 409 : | (link state @ IF postpone (bound EXIT THEN (bound ; | ||
| 410 : | |||
| 411 : | : (sbound ( o addr -- ) dup cell+ @ swap (bound ; | ||
| 412 : | |||
| 413 : | Forth definitions | ||
| 414 : | |||
| 415 : | : bind ( o -- ) ' state @ | ||
| 416 : | IF postpone Literal postpone >body postpone (sbound EXIT THEN | ||
| 417 : | >body (sbound ; immediate | ||
| 418 : | |||
| 419 : | Objects definitions | ||
| 420 : | |||
| 421 : | \ method implementation 29oct94py | ||
| 422 : | |||
| 423 : | Variable m-name | ||
| 424 : | Variable last-interface 0 last-interface ! | ||
| 425 : | |||
| 426 : | : interface, ( -- ) last-interface @ | ||
| 427 : | BEGIN dup WHILE dup , @ REPEAT drop ; | ||
| 428 : | |||
| 429 : | : inter, ( iface -- ) | ||
| 430 : | align here over :inum + @ lastob @ + ! | ||
| 431 : | here over :ilen + @ dup allot move ; | ||
| 432 : | |||
| 433 : | : interfaces, ( -- ) ob-interface @ lastob @ :iface + ! | ||
| 434 : | ob-interface @ | ||
| 435 : | BEGIN dup WHILE 2@ inter, REPEAT drop ; | ||
| 436 : | |||
| 437 : | : lastob! ( -- ) lastob @ dup | ||
| 438 : | BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop | ||
| 439 : | pazsan | 1.7 | dup , op! o@ lastob ! ; |
| 440 : | pazsan | 1.1 | |
| 441 : | : thread, ( -- ) classlist @ , ; | ||
| 442 : | : var, ( -- ) methods @ , vars @ , ; | ||
| 443 : | : parent, ( -- o parent ) | ||
| 444 : | o@ lastparent @ 2dup dup , 0 , | ||
| 445 : | dup IF :child + dup @ , ! ELSE , drop THEN ; | ||
| 446 : | : 'link, ( -- ) | ||
| 447 : | 'link @ ?dup 0= | ||
| 448 : | IF lastparent @ dup IF :newlink + @ THEN THEN , ; | ||
| 449 : | : cells, ( -- ) | ||
| 450 : | methods @ :init ?DO ['] crash , cell +LOOP ; | ||
| 451 : | |||
| 452 : | \ method implementation 20feb95py | ||
| 453 : | |||
| 454 : | types definitions | ||
| 455 : | |||
| 456 : | pazsan | 1.12 | : how: ( -- ) \ oof- oof how-to |
| 457 : | \G End declaration, start implementation | ||
| 458 : | decl @ 0= abort" not twice!" 0 decl ! | ||
| 459 : | pazsan | 1.1 | align interface, |
| 460 : | lastob! thread, parent, var, 'link, 0 , cells, interfaces, | ||
| 461 : | dup | ||
| 462 : | IF dup :method# + @ >r :init + swap r> :init /string move | ||
| 463 : | ELSE 2drop THEN ; | ||
| 464 : | |||
| 465 : | pazsan | 1.12 | : class; ( -- ) \ oof- oof end-class |
| 466 : | \G End class declaration or implementation | ||
| 467 : | decl @ IF how: THEN 0 'link ! | ||
| 468 : | voc# @ drop-order old-current @ set-current ; | ||
| 469 : | |||
| 470 : | : ptr ( -- ) \ oof- oof | ||
| 471 : | \G Create an instance pointer | ||
| 472 : | Create immediate lastob @ here lastob ! instptr, ; | ||
| 473 : | : asptr ( class -- ) \ oof- oof | ||
| 474 : | crook | 1.14 | \G Create an alias to an instance pointer, cast to another class. |
| 475 : | pazsan | 1.12 | cell+ @ Create immediate |
| 476 : | lastob @ here lastob ! , , instptr> ; | ||
| 477 : | pazsan | 1.1 | |
| 478 : | pazsan | 1.10 | : Fpostpone postpone postpone ; immediate |
| 479 : | |||
| 480 : | pazsan | 1.13 | : : ( <methodname> -- ) \ oof- oof colon |
| 481 : | decl @ abort" HOW: missing! " | ||
| 482 : | pazsan | 1.1 | bl word findo 0= abort" not found" |
| 483 : | dup exec? over early? or over >body cell+ @ 0< or | ||
| 484 : | 0= abort" not a method" | ||
| 485 : | m-name ! :noname ; | ||
| 486 : | |||
| 487 : | Forth | ||
| 488 : | |||
| 489 : | pazsan | 1.13 | : ; ( xt colon-sys -- ) \ oof- oof |
| 490 : | postpone ; | ||
| 491 : | pazsan | 1.1 | m-name @ dup >body swap exec? |
| 492 : | IF @ o@ + | ||
| 493 : | ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN | ||
| 494 : | THEN ! ; immediate | ||
| 495 : | |||
| 496 : | Forth definitions | ||
| 497 : | |||
| 498 : | \ object 23mar95py | ||
| 499 : | |||
| 500 : | Create object immediate 0 (class \ do not create as subclass | ||
| 501 : | cell var oblink \ create offset for backlink | ||
| 502 : | static thread \ method/variable wordlist | ||
| 503 : | static parento \ pointer to parent | ||
| 504 : | static childo \ ptr to first child | ||
| 505 : | static nexto \ ptr to next child of parent | ||
| 506 : | static method# \ number of methods (bytes) | ||
| 507 : | static size \ number of variables (bytes) | ||
| 508 : | static newlink \ ptr to allocated space | ||
| 509 : | static ilist \ interface list | ||
| 510 : | pazsan | 1.12 | method init ( ... -- ) \ object- oof |
| 511 : | method dispose ( -- ) \ object- oof | ||
| 512 : | pazsan | 1.1 | |
| 513 : | pazsan | 1.12 | early class ( "name" -- ) \ object- oof |
| 514 : | early new ( -- o ) \ object- oof | ||
| 515 : | immediate | ||
| 516 : | early new[] ( n -- o ) \ object- oof new-array | ||
| 517 : | immediate | ||
| 518 : | early : ( "name" -- ) \ object- oof define | ||
| 519 : | early ptr ( "name" -- ) \ object- oof | ||
| 520 : | early asptr ( o "name" -- ) \ object- oof | ||
| 521 : | early [] ( n "name" -- ) \ object- oof array | ||
| 522 : | early :: ( "name" -- ) \ object- oof scope | ||
| 523 : | immediate | ||
| 524 : | early class? ( o -- flag ) \ object- oof class-query | ||
| 525 : | early super ( "name" -- ) \ object- oof | ||
| 526 : | immediate | ||
| 527 : | early self ( -- o ) \ object- oof | ||
| 528 : | early bind ( o "name" -- ) \ object- oof | ||
| 529 : | immediate | ||
| 530 : | early bound ( class addr "name" -- ) \ object- oof | ||
| 531 : | early link ( "name" -- class addr ) \ object- oof | ||
| 532 : | immediate | ||
| 533 : | early is ( xt "name" -- ) \ object- oof | ||
| 534 : | immediate | ||
| 535 : | early send ( xt -- ) \ object- oof | ||
| 536 : | immediate | ||
| 537 : | early with ( o -- ) \ object- oof | ||
| 538 : | immediate | ||
| 539 : | early endwith ( -- ) \ object- oof | ||
| 540 : | immediate | ||
| 541 : | early ' ( "name" -- xt ) \ object- oof tick | ||
| 542 : | immediate | ||
| 543 : | early postpone ( "name" -- ) \ object- oof | ||
| 544 : | immediate | ||
| 545 : | early definitions ( -- ) \ object- oof | ||
| 546 : | pazsan | 1.1 | |
| 547 : | \ base object class implementation part 23mar95py | ||
| 548 : | |||
| 549 : | pazsan | 1.11 | how: |
| 550 : | 0 parento ! | ||
| 551 : | 0 childo ! | ||
| 552 : | 0 nexto ! | ||
| 553 : | : class ( -- ) Create immediate o@ (class ; | ||
| 554 : | : : ( -- ) Create immediate o@ | ||
| 555 : | decl @ IF instvar, ELSE instance, THEN ; | ||
| 556 : | : ptr ( -- ) Create immediate o@ | ||
| 557 : | decl @ IF instptr, ELSE ptr, THEN ; | ||
| 558 : | : asptr ( addr -- ) | ||
| 559 : | decl @ 0= abort" only in declaration!" | ||
| 560 : | Create immediate o@ , cell+ @ , instptr> ; | ||
| 561 : | : [] ( n -- ) Create immediate o@ | ||
| 562 : | decl @ IF instarray, ELSE array, THEN ; | ||
| 563 : | : new ( -- o ) o@ state @ | ||
| 564 : | IF Fpostpone Literal Fpostpone new, ELSE new, THEN ; | ||
| 565 : | : new[] ( n -- o ) o@ state @ | ||
| 566 : | IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ; | ||
| 567 : | : dispose ( -- ) ^ size @ dispose, ; | ||
| 568 : | : bind ( addr -- ) (bind ; | ||
| 569 : | : bound ( o1 o2 addr2 -- ) (bound ; | ||
| 570 : | : link ( -- o addr ) (link ; | ||
| 571 : | : class? ( class -- flag ) ^ parent? nip 0<> ; | ||
| 572 : | : :: ( -- ) | ||
| 573 : | state @ IF ^ true method, ELSE inherit THEN ; | ||
| 574 : | : super ( -- ) parento true method, ; | ||
| 575 : | : is ( cfa -- ) (is ; | ||
| 576 : | : self ( -- obj ) ^ ; | ||
| 577 : | : init ( -- ) ; | ||
| 578 : | |||
| 579 : | : ' ( -- xt ) bl word findo 0= abort" not found!" | ||
| 580 : | state @ IF Fpostpone Literal THEN ; | ||
| 581 : | : send ( xt -- ) execute ; | ||
| 582 : | : postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ; | ||
| 583 : | |||
| 584 : | : with ( -- ) | ||
| 585 : | state @ oset? 0= and IF Fpostpone >o THEN | ||
| 586 : | o@ add-order voc# ! false to oset? ; | ||
| 587 : | : endwith Fpostpone o> voc# @ drop-order ; | ||
| 588 : | pazsan | 1.7 | |
| 589 : | pazsan | 1.11 | : definitions |
| 590 : | o@ add-order 1+ voc# ! also types o@ lastob ! | ||
| 591 : | false to oset? get-current old-current ! | ||
| 592 : | thread @ set-current ; | ||
| 593 : | pazsan | 1.1 | class; \ object |
| 594 : | |||
| 595 : | \ interface 01sep96py | ||
| 596 : | |||
| 597 : | Objects definitions | ||
| 598 : | |||
| 599 : | pazsan | 1.13 | : implement ( interface -- ) \ oof-interface- oof |
| 600 : | pazsan | 1.1 | align here over , ob-interface @ , ob-interface ! |
| 601 : | pazsan | 1.2 | :ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ; |
| 602 : | pazsan | 1.1 | |
| 603 : | pazsan | 1.13 | : inter-method, ( interface -- ) \ oof-interface- oof |
| 604 : | anton | 1.16 | :ilist + @ bl word count 2dup s" '" str= |
| 605 : | dup >r IF 2drop bl word count THEN | ||
| 606 : | pazsan | 1.1 | rot search-wordlist |
| 607 : | dup 0= abort" Not an interface method!" | ||
| 608 : | r> IF drop state @ IF postpone Literal THEN EXIT THEN | ||
| 609 : | 0< state @ and IF compile, ELSE execute THEN ; | ||
| 610 : | |||
| 611 : | Variable inter-list | ||
| 612 : | Variable lastif | ||
| 613 : | Variable inter# | ||
| 614 : | |||
| 615 : | Vocabulary interfaces interfaces definitions | ||
| 616 : | |||
| 617 : | pazsan | 1.13 | : method ( -- ) \ oof-interface- oof |
| 618 : | mallot Create , inter# @ , | ||
| 619 : | DOES> 2@ swap o@ + @ + @ execute ; | ||
| 620 : | pazsan | 1.1 | |
| 621 : | pazsan | 1.13 | : how: ( -- ) \ oof-interface- oof |
| 622 : | align | ||
| 623 : | pazsan | 1.1 | here lastif @ ! 0 decl ! |
| 624 : | pazsan | 1.4 | here last-interface @ , last-interface ! |
| 625 : | inter-list @ , methods @ , inter# @ , | ||
| 626 : | pazsan | 1.1 | methods @ :inum cell+ ?DO ['] crash , LOOP ; |
| 627 : | |||
| 628 : | pazsan | 1.13 | : interface; ( -- ) \ oof-interface- oof |
| 629 : | old-current @ set-current | ||
| 630 : | pazsan | 1.1 | previous previous ; |
| 631 : | |||
| 632 : | pazsan | 1.13 | : : ( <methodname> -- ) \ oof-interface- oof colon |
| 633 : | decl @ abort" HOW: missing! " | ||
| 634 : | pazsan | 1.1 | bl word count lastif @ @ :ilist + @ |
| 635 : | search-wordlist 0= abort" not found" | ||
| 636 : | dup >body cell+ @ 0< 0= abort" not a method" | ||
| 637 : | m-name ! :noname ; | ||
| 638 : | |||
| 639 : | Forth | ||
| 640 : | |||
| 641 : | pazsan | 1.13 | : ; ( xt colon-sys -- ) \ oof-interface- oof |
| 642 : | postpone ; | ||
| 643 : | pazsan | 1.1 | m-name @ >body @ lastif @ @ + ! ; immediate |
| 644 : | |||
| 645 : | Forth definitions | ||
| 646 : | |||
| 647 : | pazsan | 1.15 | : interface-does> |
| 648 : | DOES> @ decl @ IF implement ELSE inter-method, THEN ; | ||
| 649 : | pazsan | 1.13 | : interface ( -- ) \ oof-interface- oof |
| 650 : | pazsan | 1.15 | Create interface-does> |
| 651 : | here lastif ! 0 , get-current old-current ! | ||
| 652 : | pazsan | 1.1 | last-interface @ dup IF :inum @ THEN 1 cells - inter# ! |
| 653 : | get-order wordlist | ||
| 654 : | dup inter-list ! dup set-current swap 1+ set-order | ||
| 655 : | true decl ! | ||
| 656 : | pazsan | 1.15 | 0 vars ! :inum cell+ methods ! also interfaces ; |
| 657 : | pazsan | 1.1 | |
| 658 : | previous previous | ||
| 659 : | pazsan | 1.15 | |
| 660 : | pazsan | 1.7 |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |