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