oo.fr revision 167850
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 167850 2007-03-23 22:26:01Z jkim $ 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. 34 35\ A ficl class consists of a parent class pointer, a wordlist 36\ ID for the methods of the class, and a size for the payload 37\ of objects created by the class. A class is an object. 38\ The NEW method creates and initializes an instance of a class. 39\ Classes have this footprint: 40\ cell 0: parent class address 41\ cell 1: wordlist ID 42\ cell 2: size of instance's payload 43 44\ Methods expect an object couple ( instance class ) 45\ on the stack. This is by convention - ficl has no way to 46\ police your code to make sure this is always done, but it 47\ happens naturally if you use the facilities presented here. 48\ 49\ Overridden methods must maintain the same stack signature as 50\ their predecessors. Ficl has no way of enforcing this, either. 51\ 52\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now 53\ has an extra field for the vtable method count. Hasvtable declares 54\ refs to vtable classes 55\ 56\ Revised Nov 2001 - metaclass debug method now finds only metaclass methods 57\ 58\ Planned: Ficl vtable support 59\ Each class has a vtable size parameter 60\ END-CLASS allocates and clears the vtable - then it walks class's method 61\ list and inserts all new methods into table. For each method, if the table 62\ slot is already nonzero, do nothing (overridden method). Otherwise fill 63\ vtable slot. Now do same check for parent class vtable, filling only 64\ empty slots in the new vtable. 65\ Methods are now structured as follows: 66\ - header 67\ - vtable index 68\ - xt 69\ :noname definition for code 70\ 71\ : is redefined to check for override, fill in vtable index, increment method 72\ count if not an override, create header and fill in index. Allot code pointer 73\ and run :noname 74\ ; is overridden to fill in xt returned by :noname 75\ --> compiles code to fetch vtable address, offset by index, and execute 76\ => looks up xt in the vtable and compiles it directly 77 78 79 80user current-class 810 current-class ! 82 83\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 84\ ** L A T E B I N D I N G 85\ Compile the method name, and code to find and 86\ execute it at run-time... 87\ 88 89\ p a r s e - m e t h o d 90\ compiles a method name so that it pushes 91\ the string base address and count at run-time. 92 93: parse-method \ name run: ( -- c-addr u ) 94 parse-word 95 postpone sliteral 96; compile-only 97 98 99 100: (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 } 101 class name class cell+ @ ( class c-addr u wid ) 102 search-wordlist 103; 104 105\ l o o k u p - m e t h o d 106\ takes a counted string method name from the stack (as compiled 107\ by parse-method) and attempts to look this method up in the method list of 108\ the class that's on the stack. If successful, it leaves the class on the stack 109\ and pushes the xt of the method. If not, it aborts with an error message. 110 111: lookup-method { class 2:name -- class xt } 112 class name (lookup-method) ( 0 | xt 1 | xt -1 ) 113 0= if 114 name type ." not found in " 115 class body> >name type 116 cr abort 117 endif 118; 119 120: find-method-xt \ name ( class -- class xt ) 121 parse-word lookup-method 122; 123 124: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) 125 lookup-method catch 126; 127 128: exec-method ( instance class c-addr u -- <method-signature> ) 129 lookup-method execute 130; 131 132\ Method lookup operator takes a class-addr and instance-addr 133\ and executes the method from the class's wordlist if 134\ interpreting. If compiling, bind late. 135\ 136: --> ( instance class -- ??? ) 137 state @ 0= if 138 find-method-xt execute 139 else 140 parse-method postpone exec-method 141 endif 142; immediate 143 144\ Method lookup with CATCH in case of exceptions 145: c-> ( instance class -- ?? exc-flag ) 146 state @ 0= if 147 find-method-xt catch 148 else 149 parse-method postpone catch-method 150 endif 151; immediate 152 153\ METHOD makes global words that do method invocations by late binding 154\ in case you prefer this style (no --> in your code) 155\ Example: everything has next and prev for array access, so... 156\ method next 157\ method prev 158\ my-instance next ( does whatever next does to my-instance by late binding ) 159 160: method create does> body> >name lookup-method execute ; 161 162 163\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 164\ ** E A R L Y B I N D I N G 165\ Early binding operator compiles code to execute a method 166\ given its class at compile time. Classes are immediate, 167\ so they leave their cell-pair on the stack when compiling. 168\ Example: 169\ : get-wid metaclass => .wid @ ; 170\ Usage 171\ my-class get-wid ( -- wid-of-my-class ) 172\ 1731 ficl-named-wordlist instance-vars 174instance-vars dup >search ficl-set-current 175 176: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 177 drop find-method-xt compile, drop 178; immediate compile-only 179 180: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class 181 current-class @ dup postpone => 182; immediate compile-only 183 184\ Problem: my=[ assumes that each method except the last is am obj: member 185\ which contains its class as the first field of its parameter area. The code 186\ detects non-obect members and assumes the class does not change in this case. 187\ This handles methods like index, prev, and next correctly, but does not deal 188\ correctly with CLASS. 189: my=[ \ same as my=> , but binds a chain of methods 190 current-class @ 191 begin 192 parse-word 2dup ( class c-addr u c-addr u ) 193 s" ]" compare while ( class c-addr u ) 194 lookup-method ( class xt ) 195 dup compile, ( class xt ) 196 dup ?object if \ If object member, get new class. Otherwise assume same class 197 nip >body cell+ @ ( new-class ) 198 else 199 drop ( class ) 200 endif 201 repeat 2drop drop 202; immediate compile-only 203 204 205\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 206\ ** I N S T A N C E V A R I A B L E S 207\ Instance variables (IV) are represented by words in the class's 208\ private wordlist. Each IV word contains the offset 209\ of the IV it represents, and runs code to add that offset 210\ to the base address of an instance when executed. 211\ The metaclass SUB method, defined below, leaves the address 212\ of the new class's offset field and its initial size on the 213\ stack for these words to update. When a class definition is 214\ complete, END-CLASS saves the final size in the class's size 215\ field, and restores the search order and compile wordlist to 216\ prior state. Note that these words are hidden in their own 217\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 218\ 219: do-instance-var 220 does> ( instance class addr[offset] -- addr[field] ) 221 nip @ + 222; 223 224: addr-units: ( offset size "name" -- offset' ) 225 create over , + 226 do-instance-var 227; 228 229: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 230 chars addr-units: ; 231 232: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 233 1 chars: ; 234 235: cells: ( offset nCells "name" -- offset' ) 236 cells >r aligned r> addr-units: 237; 238 239: cell: ( offset nCells "name" -- offset' ) 240 1 cells: ; 241 242\ Aggregate an object into the class... 243\ Needs the class of the instance to create 244\ Example: object obj: m_obj 245\ 246: do-aggregate 247 objectify 248 does> ( instance class pfa -- a-instance a-class ) 249 2@ ( inst class a-class a-offset ) 250 2swap drop ( a-class a-offset inst ) 251 + swap ( a-inst a-class ) 252; 253 254: obj: { offset class meta -- offset' } \ "name" 255 create offset , class , 256 class meta --> get-size offset + 257 do-aggregate 258; 259 260\ Aggregate an array of objects into a class 261\ Usage example: 262\ 3 my-class array: my-array 263\ Makes an instance variable array of 3 instances of my-class 264\ named my-array. 265\ 266: array: ( offset n class meta "name" -- offset' ) 267 locals| meta class nobjs offset | 268 create offset , class , 269 class meta --> get-size nobjs * offset + 270 do-aggregate 271; 272 273\ Aggregate a pointer to an object: REF is a member variable 274\ whose class is set at compile time. This is useful for wrapping 275\ data structures in C, where there is only a pointer and the type 276\ it refers to is known. If you want polymorphism, see c_ref 277\ in classes.fr. REF is only useful for pre-initialized structures, 278\ since there's no supported way to set one. 279: ref: ( offset class meta "name" -- offset' ) 280 locals| meta class offset | 281 create offset , class , 282 offset cell+ 283 does> ( inst class pfa -- ptr-inst ptr-class ) 284 2@ ( inst class ptr-class ptr-offset ) 285 2swap drop + @ swap 286; 287 288\ #if FICL_WANT_VCALL 289\ vcall extensions contributed by Guy Carver 290: vcall: ( paramcnt "name" -- ) 291 current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. 292 create , , \ ( paramcnt index -- ) 293 does> \ ( inst class pfa -- ptr-inst ptr-class ) 294 nip 2@ vcall \ ( params offset inst class offset -- ) 295; 296 297: vcallr: 0x80000000 or vcall: ; \ Call with return address desired. 298 299\ #if FICL_WANT_FLOAT 300: vcallf: \ ( paramcnt -<name>- f: r ) 301 0x80000000 or 302 current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. 303 create , , \ ( paramcnt index -- ) 304 does> \ ( inst class pfa -- ptr-inst ptr-class ) 305 nip 2@ vcall f> \ ( params offset inst class offset -- f: r ) 306; 307\ #endif /* FLOAT */ 308\ #endif /* VCALL */ 309 310\ END-CLASS terminates construction of a class by storing 311\ the size of its instance variables in the class's size field 312\ ( -- old-wid addr[size] 0 ) 313\ 314: end-class ( old-wid addr[size] size -- ) 315 swap ! set-current 316 search> drop \ pop struct builder wordlist 317; 318 319\ See resume-class (a metaclass method) below for usage 320\ This is equivalent to end-class for now, but that will change 321\ when we support vtable bindings. 322: suspend-class ( old-wid addr[size] size -- ) end-class ; 323 324set-current previous 325\ E N D I N S T A N C E V A R I A B L E S 326 327 328\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 329\ D O - D O - I N S T A N C E 330\ Makes a class method that contains the code for an 331\ instance of the class. This word gets compiled into 332\ the wordlist of every class by the SUB method. 333\ PRECONDITION: current-class contains the class address 334\ why use a state variable instead of the stack? 335\ >> Stack state is not well-defined during compilation (there are 336\ >> control structure match codes on the stack, of undefined size 337\ >> easiest way around this is use of this thread-local variable 338\ 339: do-do-instance ( -- ) 340 s" : .do-instance does> [ current-class @ ] literal ;" 341 evaluate 342; 343 344\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 345\ ** M E T A C L A S S 346\ Every class is an instance of metaclass. This lets 347\ classes have methods that are different from those 348\ of their instances. 349\ Classes are IMMEDIATE to make early binding simpler 350\ See above... 351\ 352:noname 353 wordlist 354 create 355 immediate 356 0 , \ NULL parent class 357 dup , \ wid 358\ #if FICL_WANT_VCALL 359 4 cells , \ instance size 360\ #else 361 3 cells , \ instance size 362\ #endif 363 ficl-set-current 364 does> dup 365; execute metaclass 366\ now brand OBJECT's wordlist (so that ORDER can display it by name) 367metaclass drop cell+ @ brand-wordlist 368 369metaclass drop current-class ! 370do-do-instance 371 372\ 373\ C L A S S M E T H O D S 374\ 375instance-vars >search 376 377create .super ( class metaclass -- parent-class ) 378 0 cells , do-instance-var 379 380create .wid ( class metaclass -- wid ) \ return wid of class 381 1 cells , do-instance-var 382 383\ #if FICL_WANT_VCALL 384create .vtCount \ Number of VTABLE methods, if any 385 2 cells , do-instance-var 386 387create .size ( class metaclass -- size ) \ return class's payload size 388 3 cells , do-instance-var 389\ #else 390create .size ( class metaclass -- size ) \ return class's payload size 391 2 cells , do-instance-var 392\ #endif 393 394: get-size metaclass => .size @ ; 395: get-wid metaclass => .wid @ ; 396: get-super metaclass => .super @ ; 397\ #if FICL_WANT_VCALL 398: get-vtCount metaclass => .vtCount @ ; 399: get-vtAdd metaclass => .vtCount ; 400\ #endif 401 402\ create an uninitialized instance of a class, leaving 403\ the address of the new instance and its class 404\ 405: instance ( class metaclass "name" -- instance class ) 406 locals| meta parent | 407 create 408 here parent --> .do-instance \ ( inst class ) 409 parent meta metaclass => get-size 410 allot \ allocate payload space 411; 412 413\ create an uninitialized array 414: array ( n class metaclass "name" -- n instance class ) 415 locals| meta parent nobj | 416 create nobj 417 here parent --> .do-instance \ ( nobj inst class ) 418 parent meta metaclass => get-size 419 nobj * allot \ allocate payload space 420; 421 422\ create an initialized instance 423\ 424: new \ ( class metaclass "name" -- ) 425 metaclass => instance --> init 426; 427 428\ create an initialized array of instances 429: new-array ( n class metaclass "name" -- ) 430 metaclass => array 431 --> array-init 432; 433 434\ Create an anonymous initialized instance from the heap 435: alloc \ ( class metaclass -- instance class ) 436 locals| meta class | 437 class meta metaclass => get-size allocate ( -- addr fail-flag ) 438 abort" allocate failed " ( -- addr ) 439 class 2dup --> init 440; 441 442\ Create an anonymous array of initialized instances from the heap 443: alloc-array \ ( n class metaclass -- instance class ) 444 locals| meta class nobj | 445 class meta metaclass => get-size 446 nobj * allocate ( -- addr fail-flag ) 447 abort" allocate failed " ( -- addr ) 448 nobj over class --> array-init 449 class 450; 451 452\ Create an anonymous initialized instance from the dictionary 453: allot { 2:this -- 2:instance } 454 here ( instance-address ) 455 this my=> get-size allot 456 this drop 2dup --> init 457; 458 459\ Create an anonymous array of initialized instances from the dictionary 460: allot-array { nobj 2:this -- 2:instance } 461 here ( instance-address ) 462 this my=> get-size nobj * allot 463 this drop 2dup ( 2instance 2instance ) 464 nobj -rot --> array-init 465; 466 467\ create a proxy object with initialized payload address given 468: ref ( instance-addr class metaclass "name" -- ) 469 drop create , , 470 does> 2@ 471; 472 473\ suspend-class and resume-class help to build mutually referent classes. 474\ Example: 475\ object subclass c-akbar 476\ suspend-class ( put akbar on hold while we define jeff ) 477\ object subclass c-jeff 478\ c-akbar ref: .akbar 479\ ( and whatever else comprises this class ) 480\ end-class ( done with c-jeff ) 481\ c-akbar --> resume-class 482\ c-jeff ref: .jeff 483\ ( and whatever else goes in c-akbar ) 484\ end-class ( done with c-akbar ) 485\ 486: resume-class { 2:this -- old-wid addr[size] size } 487 this --> .wid @ ficl-set-current ( old-wid ) 488 this --> .size dup @ ( old-wid addr[size] size ) 489 instance-vars >search 490; 491 492\ create a subclass 493\ This method leaves the stack and search order ready for instance variable 494\ building. Pushes the instance-vars wordlist onto the search order, 495\ and sets the compilation wordlist to be the private wordlist of the 496\ new class. The class's wordlist is deliberately NOT in the search order - 497\ to prevent methods from getting used with wrong data. 498\ Postcondition: leaves the address of the new class in current-class 499: sub ( class metaclass "name" -- old-wid addr[size] size ) 500 wordlist 501 locals| wid meta parent | 502 parent meta metaclass => get-wid 503 wid wid-set-super \ set superclass 504 create immediate \ get the subclass name 505 wid brand-wordlist \ label the subclass wordlist 506 here current-class ! \ prep for do-do-instance 507 parent , \ save parent class 508 wid , \ save wid 509\ #if FICL_WANT_VCALL 510 parent meta --> get-vtCount , 511\ #endif 512 here parent meta --> get-size dup , ( addr[size] size ) 513 metaclass => .do-instance 514 wid ficl-set-current -rot 515 do-do-instance 516 instance-vars >search \ push struct builder wordlist 517; 518 519\ OFFSET-OF returns the offset of an instance variable 520\ from the instance base address. If the next token is not 521\ the name of in instance variable method, you get garbage 522\ results -- there is no way at present to check for this error. 523: offset-of ( class metaclass "name" -- offset ) 524 drop find-method-xt nip >body @ ; 525 526\ ID returns the string name cell-pair of its class 527: id ( class metaclass -- c-addr u ) 528 drop body> >name ; 529 530\ list methods of the class 531: methods \ ( class meta -- ) 532 locals| meta class | 533 begin 534 class body> >name type ." methods:" cr 535 class meta --> get-wid >search words cr previous 536 class meta metaclass => get-super 537 dup to class 538 0= until cr 539; 540 541\ list class's ancestors 542: pedigree ( class meta -- ) 543 locals| meta class | 544 begin 545 class body> >name type space 546 class meta metaclass => get-super 547 dup to class 548 0= until cr 549; 550 551\ decompile an instance method 552: see ( class meta -- ) 553 metaclass => get-wid >search see previous ; 554 555\ debug a method of metaclass 556\ Eg: my-class --> debug my-method 557: debug ( class meta -- ) 558 find-method-xt debug-xt ; 559 560previous set-current 561\ E N D M E T A C L A S S 562 563\ ** META is a nickname for the address of METACLASS... 564metaclass drop 565constant meta 566 567\ ** SUBCLASS is a nickname for a class's SUB method... 568\ Subclass compilation ends when you invoke end-class 569\ This method is late bound for safety... 570: subclass --> sub ; 571 572\ #if FICL_WANT_VCALL 573\ VTABLE Support extensions (Guy Carver) 574\ object --> sub mine hasvtable 575: hasvtable 4 + ; immediate 576\ #endif 577 578 579\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 580\ ** O B J E C T 581\ Root of all classes 582:noname 583 wordlist 584 create immediate 585 0 , \ NULL parent class 586 dup , \ wid 587 0 , \ instance size 588 ficl-set-current 589 does> meta 590; execute object 591\ now brand OBJECT's wordlist (so that ORDER can display it by name) 592object drop cell+ @ brand-wordlist 593 594object drop current-class ! 595do-do-instance 596instance-vars >search 597 598\ O B J E C T M E T H O D S 599\ Convert instance cell-pair to class cell-pair 600\ Useful for binding class methods from an instance 601: class ( instance class -- class metaclass ) 602 nip meta ; 603 604\ default INIT method zero fills an instance 605: init ( instance class -- ) 606 meta 607 metaclass => get-size ( inst size ) 608 erase ; 609 610\ Apply INIT to an array of NOBJ objects... 611\ 612: array-init ( nobj inst class -- ) 613 0 dup locals| &init &next class inst | 614 \ 615 \ bind methods outside the loop to save time 616 \ 617 class s" init" lookup-method to &init 618 s" next" lookup-method to &next 619 drop 620 0 ?do 621 inst class 2dup 622 &init execute 623 &next execute drop to inst 624 loop 625; 626 627\ free storage allocated to a heap instance by alloc or alloc-array 628\ NOTE: not protected against errors like FREEing something that's 629\ really in the dictionary. 630: free \ ( instance class -- ) 631 drop free 632 abort" free failed " 633; 634 635\ Instance aliases for common class methods 636\ Upcast to parent class 637: super ( instance class -- instance parent-class ) 638 meta metaclass => get-super ; 639 640: pedigree ( instance class -- ) 641 object => class 642 metaclass => pedigree ; 643 644: size ( instance class -- sizeof-instance ) 645 object => class 646 metaclass => get-size ; 647 648: methods ( instance class -- ) 649 object => class 650 metaclass => methods ; 651 652\ Array indexing methods... 653\ Usage examples: 654\ 10 object-array --> index 655\ obj --> next 656\ 657: index ( n instance class -- instance[n] class ) 658 locals| class inst | 659 inst class 660 object => class 661 metaclass => get-size * ( n*size ) 662 inst + class ; 663 664: next ( instance[n] class -- instance[n+1] class ) 665 locals| class inst | 666 inst class 667 object => class 668 metaclass => get-size 669 inst + 670 class ; 671 672: prev ( instance[n] class -- instance[n-1] class ) 673 locals| class inst | 674 inst class 675 object => class 676 metaclass => get-size 677 inst swap - 678 class ; 679 680: debug ( 2this -- ?? ) 681 find-method-xt debug-xt ; 682 683previous set-current 684\ E N D O B J E C T 685 686\ reset to default search order 687only definitions 688 689\ redefine oop in default search order to put OOP words in the search order and make them 690\ the compiling wordlist... 691 692: oo only also oop definitions ; 693 694\ #endif 695