oo.fr revision 76116
1\ #if FICL_WANT_OOP 2\ ** ficl/softwords/oo.fr 3\ ** F I C L O - O E X T E N S I O N S 4\ ** john sadler aug 1998 5\ 6\ $FreeBSD: head/sys/boot/ficl/softwords/oo.fr 76116 2001-04-29 02:36:36Z dcs $ 7 817 ficl-vocabulary oop 9also oop definitions 10 11\ Design goals: 12\ 0. Traditional OOP: late binding by default for safety. 13\ Early binding if you ask for it. 14\ 1. Single inheritance 15\ 2. Object aggregation (has-a relationship) 16\ 3. Support objects in the dictionary and as proxies for 17\ existing structures (by reference): 18\ *** A ficl object can wrap a C struct *** 19\ 4. Separate name-spaces for methods - methods are 20\ only visible in the context of a class / object 21\ 5. Methods can be overridden, and subclasses can add methods. 22\ No limit on number of methods. 23 24\ General info: 25\ Classes are objects, too: all classes are instances of METACLASS 26\ All classes are derived (by convention) from OBJECT. This 27\ base class provides a default initializer and superclass 28\ access method 29 30\ A ficl object binds instance storage (payload) to a class. 31\ object ( -- instance class ) 32\ All objects push their payload address and class address when 33\ executed. All objects have this footprint: 34\ cell 0: first payload cell 35 36\ A ficl class consists of a parent class pointer, a wordlist 37\ ID for the methods of the class, and a size for the payload 38\ of objects created by the class. A class is an object. 39\ The NEW method creates and initializes an instance of a class. 40\ Classes have this footprint: 41\ cell 0: parent class address 42\ cell 1: wordlist ID 43\ cell 2: size of instance's payload 44 45\ Methods expect an object couple ( instance class ) 46\ on the stack. 47\ Overridden methods must maintain the same stack signature as 48\ their predecessors. Ficl has no way of enforcing this, though. 49 50user current-class 510 current-class ! 52 53\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 54\ ** L A T E B I N D I N G 55\ Compile the method name, and code to find and 56\ execute it at run-time... 57\ parse-method compiles the method name so that it pushes 58\ the string base address and count at run-time. 59\ 60 61hide 62 63: parse-method \ name run: ( -- c-addr u ) 64 parse-word 65 postpone sliteral 66; compile-only 67 68: lookup-method { class 2:name -- class xt } 69 name class cell+ @ ( c-addr u wid ) 70 search-wordlist ( 0 | xt 1 | xt -1 ) 71 0= if 72 name type ." not found in " 73 class body> >name type 74 cr abort 75 endif 76 class swap 77; 78 79: find-method-xt \ name ( class -- class xt ) 80 parse-word lookup-method 81; 82 83set-current ( stop hiding definitions ) 84 85: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) 86 lookup-method catch 87; 88 89: exec-method ( instance class c-addr u -- <method-signature> ) 90 lookup-method execute 91; 92 93\ Method lookup operator takes a class-addr and instance-addr 94\ and executes the method from the class's wordlist if 95\ interpreting. If compiling, bind late. 96\ 97: --> ( instance class -- ??? ) 98 state @ 0= if 99 find-method-xt execute 100 else 101 parse-method postpone exec-method 102 endif 103; immediate 104 105\ Method lookup with CATCH in case of exceptions 106: c-> ( instance class -- ?? exc-flag ) 107 state @ 0= if 108 find-method-xt catch 109 else 110 parse-method postpone catch-method 111 endif 112; immediate 113 114\ METHOD makes global words that do method invocations by late binding 115\ in case you prefer this style (no --> in your code) 116: method create does> body> >name lookup-method execute ; 117 118 119\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 120\ ** E A R L Y B I N D I N G 121\ Early binding operator compiles code to execute a method 122\ given its class at compile time. Classes are immediate, 123\ so they leave their cell-pair on the stack when compiling. 124\ Example: 125\ : get-wid metaclass => .wid @ ; 126\ Usage 127\ my-class get-wid ( -- wid-of-my-class ) 128\ 1291 ficl-named-wordlist instance-vars 130instance-vars dup >search ficl-set-current 131 132: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 133 drop find-method-xt compile, drop 134; immediate compile-only 135 136: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class 137 current-class @ dup postpone => 138; immediate compile-only 139 140: my=[ \ same as my=> , but binds a chain of methods 141 current-class @ 142 begin 143 parse-word 2dup 144 s" ]" compare while ( class c-addr u ) 145 lookup-method nip dup ( xt xt ) 146 compile, >body cell+ @ ( class' ) 147 repeat 2drop drop 148; immediate compile-only 149 150 151\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 152\ ** I N S T A N C E V A R I A B L E S 153\ Instance variables (IV) are represented by words in the class's 154\ private wordlist. Each IV word contains the offset 155\ of the IV it represents, and runs code to add that offset 156\ to the base address of an instance when executed. 157\ The metaclass SUB method, defined below, leaves the address 158\ of the new class's offset field and its initial size on the 159\ stack for these words to update. When a class definition is 160\ complete, END-CLASS saves the final size in the class's size 161\ field, and restores the search order and compile wordlist to 162\ prior state. Note that these words are hidden in their own 163\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 164\ 165: do-instance-var 166 does> ( instance class addr[offset] -- addr[field] ) 167 nip @ + 168; 169 170: addr-units: ( offset size "name" -- offset' ) 171 create over , + 172 do-instance-var 173; 174 175: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 176 chars addr-units: ; 177 178: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 179 1 chars: ; 180 181: cells: ( offset nCells "name" -- offset' ) 182 cells >r aligned r> addr-units: 183; 184 185: cell: ( offset nCells "name" -- offset' ) 186 1 cells: ; 187 188\ Aggregate an object into the class... 189\ Needs the class of the instance to create 190\ Example: object obj: m_obj 191\ 192: do-aggregate 193 does> ( instance class pfa -- a-instance a-class ) 194 2@ ( inst class a-class a-offset ) 195 2swap drop ( a-class a-offset inst ) 196 + swap ( a-inst a-class ) 197; 198 199: obj: ( offset class meta "name" -- offset' ) 200 locals| meta class offset | 201 create offset , class , 202 class meta --> get-size offset + 203 do-aggregate 204; 205 206\ Aggregate an array of objects into a class 207\ Usage example: 208\ 3 my-class array: my-array 209\ Makes an instance variable array of 3 instances of my-class 210\ named my-array. 211\ 212: array: ( offset n class meta "name" -- offset' ) 213 locals| meta class nobjs offset | 214 create offset , class , 215 class meta --> get-size nobjs * offset + 216 do-aggregate 217; 218 219\ Aggregate a pointer to an object: REF is a member variable 220\ whose class is set at compile time. This is useful for wrapping 221\ data structures in C, where there is only a pointer and the type 222\ it refers to is known. If you want polymorphism, see c_ref 223\ in classes.fr. REF is only useful for pre-initialized structures, 224\ since there's no supported way to set one. 225: ref: ( offset class meta "name" -- offset' ) 226 locals| meta class offset | 227 create offset , class , 228 offset cell+ 229 does> ( inst class pfa -- ptr-inst ptr-class ) 230 2@ ( inst class ptr-class ptr-offset ) 231 2swap drop + @ swap 232; 233 234\ END-CLASS terminates construction of a class by storing 235\ the size of its instance variables in the class's size field 236\ ( -- old-wid addr[size] 0 ) 237\ 238: end-class ( old-wid addr[size] size -- ) 239 swap ! set-current 240 search> drop \ pop struct builder wordlist 241; 242 243\ See resume-class (a metaclass method) below for usage 244\ This is equivalent to end-class for now, but that will change 245\ when we support vtable bindings. 246: suspend-class ( old-wid addr[size] size -- ) end-class ; 247 248set-current previous 249\ E N D I N S T A N C E V A R I A B L E S 250 251 252\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 253\ D O - D O - I N S T A N C E 254\ Makes a class method that contains the code for an 255\ instance of the class. This word gets compiled into 256\ the wordlist of every class by the SUB method. 257\ PRECONDITION: current-class contains the class address 258\ why use a state variable instead of the stack? 259\ >> Stack state is not well-defined during compilation (there are 260\ >> control structure match codes on the stack, of undefined size 261\ >> easiest way around this is use of this thread-local variable 262\ 263: do-do-instance ( -- ) 264 s" : .do-instance does> [ current-class @ ] literal ;" 265 evaluate 266; 267 268\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 269\ ** M E T A C L A S S 270\ Every class is an instance of metaclass. This lets 271\ classes have methods that are different from those 272\ of their instances. 273\ Classes are IMMEDIATE to make early binding simpler 274\ See above... 275\ 276:noname 277 wordlist 278 create 279 immediate 280 0 , \ NULL parent class 281 dup , \ wid 282 3 cells , \ instance size 283 ficl-set-current 284 does> dup 285; execute metaclass 286\ now brand OBJECT's wordlist (so that ORDER can display it by name) 287metaclass drop cell+ @ brand-wordlist 288 289metaclass drop current-class ! 290do-do-instance 291 292\ 293\ C L A S S M E T H O D S 294\ 295instance-vars >search 296 297create .super ( class metaclass -- parent-class ) 298 0 cells , do-instance-var 299 300create .wid ( class metaclass -- wid ) \ return wid of class 301 1 cells , do-instance-var 302 303create .size ( class metaclass -- size ) \ return class's payload size 304 2 cells , do-instance-var 305 306: get-size metaclass => .size @ ; 307: get-wid metaclass => .wid @ ; 308: get-super metaclass => .super @ ; 309 310\ create an uninitialized instance of a class, leaving 311\ the address of the new instance and its class 312\ 313: instance ( class metaclass "name" -- instance class ) 314 locals| meta parent | 315 create 316 here parent --> .do-instance \ ( inst class ) 317 parent meta metaclass => get-size 318 allot \ allocate payload space 319; 320 321\ create an uninitialized array 322: array ( n class metaclass "name" -- n instance class ) 323 locals| meta parent nobj | 324 create nobj 325 here parent --> .do-instance \ ( nobj inst class ) 326 parent meta metaclass => get-size 327 nobj * allot \ allocate payload space 328; 329 330\ create an initialized instance 331\ 332: new \ ( class metaclass "name" -- ) 333 metaclass => instance --> init 334; 335 336\ create an initialized array of instances 337: new-array ( n class metaclass "name" -- ) 338 metaclass => array 339 --> array-init 340; 341 342\ Create an anonymous initialized instance from the heap 343: alloc \ ( class metaclass -- instance class ) 344 locals| meta class | 345 class meta metaclass => get-size allocate ( -- addr fail-flag ) 346 abort" allocate failed " ( -- addr ) 347 class 2dup --> init 348; 349 350\ Create an anonymous array of initialized instances from the heap 351: alloc-array \ ( n class metaclass -- instance class ) 352 locals| meta class nobj | 353 class meta metaclass => get-size 354 nobj * allocate ( -- addr fail-flag ) 355 abort" allocate failed " ( -- addr ) 356 nobj over class --> array-init 357 class 358; 359 360\ Create an anonymous initialized instance from the dictionary 361: allot { 2:this -- 2:instance } 362 here ( instance-address ) 363 this my=> get-size allot 364 this drop 2dup --> init 365; 366 367\ Create an anonymous array of initialized instances from the dictionary 368: allot-array { nobj 2:this -- 2:instance } 369 here ( instance-address ) 370 this my=> get-size nobj * allot 371 this drop 2dup ( 2instance 2instance ) 372 nobj -rot --> array-init 373; 374 375\ create a proxy object with initialized payload address given 376: ref ( instance-addr class metaclass "name" -- ) 377 drop create , , 378 does> 2@ 379; 380 381\ suspend-class and resume-class help to build mutually referent classes. 382\ Example: 383\ object subclass c-akbar 384\ suspend-class ( put akbar on hold while we define jeff ) 385\ object subclass c-jeff 386\ c-akbar ref: .akbar 387\ ( and whatever else comprises this class ) 388\ end-class ( done with c-jeff ) 389\ c-akbar --> resume-class 390\ c-jeff ref: .jeff 391\ ( and whatever else goes in c-akbar ) 392\ end-class ( done with c-akbar ) 393\ 394: resume-class { 2:this -- old-wid addr[size] size } 395 this --> .wid @ ficl-set-current ( old-wid ) 396 this --> .size dup @ ( old-wid addr[size] size ) 397 instance-vars >search 398; 399 400\ create a subclass 401\ This method leaves the stack and search order ready for instance variable 402\ building. Pushes the instance-vars wordlist onto the search order, 403\ and sets the compilation wordlist to be the private wordlist of the 404\ new class. The class's wordlist is deliberately NOT in the search order - 405\ to prevent methods from getting used with wrong data. 406\ Postcondition: leaves the address of the new class in current-class 407: sub ( class metaclass "name" -- old-wid addr[size] size ) 408 wordlist 409 locals| wid meta parent | 410 parent meta metaclass => get-wid 411 wid wid-set-super \ set superclass 412 create immediate \ get the subclass name 413 wid brand-wordlist \ label the subclass wordlist 414 here current-class ! \ prep for do-do-instance 415 parent , \ save parent class 416 wid , \ save wid 417 here parent meta --> get-size dup , ( addr[size] size ) 418 metaclass => .do-instance 419 wid ficl-set-current -rot 420 do-do-instance 421 instance-vars >search \ push struct builder wordlist 422; 423 424\ OFFSET-OF returns the offset of an instance variable 425\ from the instance base address. If the next token is not 426\ the name of in instance variable method, you get garbage 427\ results -- there is no way at present to check for this error. 428: offset-of ( class metaclass "name" -- offset ) 429 drop find-method-xt nip >body @ ; 430 431\ ID returns the string name cell-pair of its class 432: id ( class metaclass -- c-addr u ) 433 drop body> >name ; 434 435\ list methods of the class 436: methods \ ( class meta -- ) 437 locals| meta class | 438 begin 439 class body> >name type ." methods:" cr 440 class meta --> get-wid >search words cr previous 441 class meta metaclass => get-super 442 dup to class 443 0= until cr 444; 445 446\ list class's ancestors 447: pedigree ( class meta -- ) 448 locals| meta class | 449 begin 450 class body> >name type space 451 class meta metaclass => get-super 452 dup to class 453 0= until cr 454; 455 456\ decompile a method 457: see ( class meta -- ) 458 metaclass => get-wid >search see previous ; 459 460previous set-current 461\ E N D M E T A C L A S S 462 463\ ** META is a nickname for the address of METACLASS... 464metaclass drop 465constant meta 466 467\ ** SUBCLASS is a nickname for a class's SUB method... 468\ Subclass compilation ends when you invoke end-class 469\ This method is late bound for safety... 470: subclass --> sub ; 471 472 473\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 474\ ** O B J E C T 475\ Root of all classes 476:noname 477 wordlist 478 create immediate 479 0 , \ NULL parent class 480 dup , \ wid 481 0 , \ instance size 482 ficl-set-current 483 does> meta 484; execute object 485\ now brand OBJECT's wordlist (so that ORDER can display it by name) 486object drop cell+ @ brand-wordlist 487 488object drop current-class ! 489do-do-instance 490instance-vars >search 491 492\ O B J E C T M E T H O D S 493\ Convert instance cell-pair to class cell-pair 494\ Useful for binding class methods from an instance 495: class ( instance class -- class metaclass ) 496 nip meta ; 497 498\ default INIT method zero fills an instance 499: init ( instance class -- ) 500 meta 501 metaclass => get-size ( inst size ) 502 erase ; 503 504\ Apply INIT to an array of NOBJ objects... 505\ 506: array-init ( nobj inst class -- ) 507 0 dup locals| &init &next class inst | 508 \ 509 \ bind methods outside the loop to save time 510 \ 511 class s" init" lookup-method to &init 512 s" next" lookup-method to &next 513 drop 514 0 ?do 515 inst class 2dup 516 &init execute 517 &next execute drop to inst 518 loop 519; 520 521\ free storage allocated to a heap instance by alloc or alloc-array 522\ NOTE: not protected against errors like FREEing something that's 523\ really in the dictionary. 524: free \ ( instance class -- ) 525 drop free 526 abort" free failed " 527; 528 529\ Instance aliases for common class methods 530\ Upcast to parent class 531: super ( instance class -- instance parent-class ) 532 meta metaclass => get-super ; 533 534: pedigree ( instance class -- ) 535 object => class 536 metaclass => pedigree ; 537 538: size ( instance class -- sizeof-instance ) 539 object => class 540 metaclass => get-size ; 541 542: methods ( instance class -- ) 543 object => class 544 metaclass => methods ; 545 546\ Array indexing methods... 547\ Usage examples: 548\ 10 object-array --> index 549\ obj --> next 550\ 551: index ( n instance class -- instance[n] class ) 552 locals| class inst | 553 inst class 554 object => class 555 metaclass => get-size * ( n*size ) 556 inst + class ; 557 558: next ( instance[n] class -- instance[n+1] class ) 559 locals| class inst | 560 inst class 561 object => class 562 metaclass => get-size 563 inst + 564 class ; 565 566: prev ( instance[n] class -- instance[n-1] class ) 567 locals| class inst | 568 inst class 569 object => class 570 metaclass => get-size 571 inst swap - 572 class ; 573 574: debug ( 2this -- ?? ) 575 find-method-xt debug-xt ; 576 577previous set-current 578\ E N D O B J E C T 579 580 581only definitions 582\ #endif 583