oo.fr revision 60959
1169691Skan\ ** ficl/softwords/oo.fr 2169691Skan\ ** F I C L O - O E X T E N S I O N S 3169691Skan\ ** john sadler aug 1998 4169691Skan\ 5169691Skan\ $FreeBSD: head/sys/boot/ficl/softwords/oo.fr 60959 2000-05-26 21:35:08Z dcs $ 6169691Skan 7169691Skan 8169691Skan.( loading ficl O-O extensions ) cr 9169691Skan7 ficl-vocabulary oop 10169691Skanalso oop definitions 11169691Skan 12169691Skan\ Design goals: 13169691Skan\ 0. Traditional OOP: late binding by default for safety. 14169691Skan\ Early binding if you ask for it. 15169691Skan\ 1. Single inheritance 16169691Skan\ 2. Object aggregation (has-a relationship) 17169691Skan\ 3. Support objects in the dictionary and as proxies for 18169691Skan\ existing structures (by reference): 19169691Skan\ *** A ficl object can wrap a C struct *** 20169691Skan\ 4. Separate name-spaces for methods - methods are 21169691Skan\ only visible in the context of a class / object 22169691Skan\ 5. Methods can be overridden, and subclasses can add methods. 23169691Skan\ No limit on number of methods. 24169691Skan 25169691Skan\ General info: 26169691Skan\ Classes are objects, too: all classes are instances of METACLASS 27169691Skan\ All classes are derived (by convention) from OBJECT. This 28169691Skan\ base class provides a default initializer and superclass 29169691Skan\ access method 30169691Skan 31169691Skan\ A ficl object binds instance storage (payload) to a class. 32169691Skan\ object ( -- instance class ) 33169691Skan\ All objects push their payload address and class address when 34169691Skan\ executed. All objects have this footprint: 35169691Skan\ cell 0: first payload cell 36169691Skan 37169691Skan\ A ficl class consists of a parent class pointer, a wordlist 38169691Skan\ ID for the methods of the class, and a size for the payload 39169691Skan\ of objects created by the class. A class is an object. 40169691Skan\ The NEW method creates and initializes an instance of a class. 41169691Skan\ Classes have this footprint: 42169691Skan\ cell 0: parent class address 43169691Skan\ cell 1: wordlist ID 44169691Skan\ cell 2: size of instance's payload 45169691Skan 46169691Skan\ Methods expect an object couple ( instance class ) 47169691Skan\ on the stack. 48169691Skan\ Overridden methods must maintain the same stack signature as 49169691Skan\ their predecessors. Ficl has no way of enforcing this, though. 50169691Skan 51169691Skanuser current-class 52169691Skan0 current-class ! 53169691Skan 54169691Skan\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 55169691Skan\ ** L A T E B I N D I N G 56169691Skan\ Compile the method name, and code to find and 57169691Skan\ execute it at run-time... 58169691Skan\ parse-method compiles the method name so that it pushes 59169691Skan\ the string base address and count at run-time. 60169691Skan\ 61169691Skan: parse-method \ name run: ( -- c-addr u ) 62169691Skan parse-word 63169691Skan postpone sliteral 64169691Skan; compile-only 65169691Skan 66169691Skan: lookup-method ( class c-addr u -- class xt ) 67169691Skan 2dup 68169691Skan local u 69169691Skan local c-addr 70169691Skan end-locals 71169691Skan 2 pick cell+ @ ( -- class c-addr u wid ) 72169691Skan search-wordlist ( -- class 0 | xt 1 | xt -1 ) 73169691Skan 0= if 74169691Skan c-addr u type ." not found in " 75169691Skan body> >name type 76169691Skan cr abort 77169691Skan endif 78169691Skan; 79169691Skan 80169691Skan: exec-method ( instance class c-addr u -- <method-signature> ) 81169691Skan lookup-method execute 82169691Skan; 83169691Skan 84169691Skan: find-method-xt \ name ( class -- class xt ) 85169691Skan parse-word lookup-method 86169691Skan; 87169691Skan 88169691Skan 89169691Skan\ Method lookup operator takes a class-addr and instance-addr 90169691Skan\ and executes the method from the class's wordlist if 91169691Skan\ interpreting. If compiling, bind late. 92169691Skan\ 93169691Skan: --> ( instance class -- ??? ) 94169691Skan state @ 0= if 95169691Skan find-method-xt execute 96169691Skan else 97169691Skan parse-method postpone exec-method 98169691Skan endif 99169691Skan; immediate 100169691Skan 101169691Skan 102169691Skan\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 103169691Skan\ ** E A R L Y B I N D I N G 104169691Skan\ Early binding operator compiles code to execute a method 105169691Skan\ given its class at compile time. Classes are immediate, 106169691Skan\ so they leave their cell-pair on the stack when compiling. 107169691Skan\ Example: 108169691Skan\ : get-wid metaclass => .wid @ ; 109169691Skan\ Usage 110169691Skan\ my-class get-wid ( -- wid-of-my-class ) 111169691Skan\ 112169691Skan: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 113169691Skan drop find-method-xt compile, drop 114169691Skan; immediate compile-only 115169691Skan 116169691Skan 117169691Skan\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 118169691Skan\ ** I N S T A N C E V A R I A B L E S 119169691Skan\ Instance variables (IV) are represented by words in the class's 120169691Skan\ private wordlist. Each IV word contains the offset 121169691Skan\ of the IV it represents, and runs code to add that offset 122169691Skan\ to the base address of an instance when executed. 123169691Skan\ The metaclass SUB method, defined below, leaves the address 124169691Skan\ of the new class's offset field and its initial size on the 125169691Skan\ stack for these words to update. When a class definition is 126169691Skan\ complete, END-CLASS saves the final size in the class's size 127169691Skan\ field, and restores the search order and compile wordlist to 128169691Skan\ prior state. Note that these words are hidden in their own 129169691Skan\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 130169691Skan\ 131169691Skanwordlist 132169691Skandup constant instance-vars 133169691Skandup >search ficl-set-current 134169691Skan: do-instance-var 135169691Skan does> ( instance class addr[offset] -- addr[field] ) 136169691Skan nip @ + 137169691Skan; 138169691Skan 139169691Skan: addr-units: ( offset size "name" -- offset' ) 140169691Skan create over , + 141169691Skan do-instance-var 142169691Skan; 143169691Skan 144169691Skan: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 145169691Skan chars addr-units: ; 146169691Skan 147169691Skan: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 148169691Skan 1 chars: ; 149169691Skan 150169691Skan: cells: ( offset nCells "name" -- offset' ) 151169691Skan cells >r aligned r> addr-units: 152169691Skan; 153169691Skan 154169691Skan: cell: ( offset nCells "name" -- offset' ) 155169691Skan 1 cells: ; 156169691Skan 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