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