oo.fr revision 40843
1275072Semaste\ ** ficl/softwords/oo.fr 2275072Semaste\ ** F I C L O - O E X T E N S I O N S 3353358Sdim\ ** john sadler aug 1998 4353358Sdim 5353358Sdim.( loading ficl O-O extensions ) cr 6275072Semaste7 ficl-vocabulary oop 7275072Semastealso oop definitions 8275072Semaste 9314564Sdim\ Design goals: 10314564Sdim\ 0. Traditional OOP: late binding by default for safety. 11314564Sdim\ Early binding if you ask for it. 12275072Semaste\ 1. Single inheritance 13275072Semaste\ 2. Object aggregation (has-a relationship) 14275072Semaste\ 3. Support objects in the dictionary and as proxies for 15275072Semaste\ existing structures (by reference): 16275072Semaste\ *** A ficl object can wrap a C struct *** 17275072Semaste\ 4. Separate name-spaces for methods - methods are 18314564Sdim\ only visible in the context of a class / object 19314564Sdim\ 5. Methods can be overridden, and subclasses can add methods. 20314564Sdim\ No limit on number of methods. 21314564Sdim 22314564Sdim\ General info: 23314564Sdim\ Classes are objects, too: all classes are instances of METACLASS 24314564Sdim\ All classes are derived (by convention) from OBJECT. This 25314564Sdim\ base class provides a default initializer and superclass 26314564Sdim\ access method 27314564Sdim 28314564Sdim\ A ficl object binds instance storage (payload) to a class. 29314564Sdim\ object ( -- instance class ) 30314564Sdim\ All objects push their payload address and class address when 31314564Sdim\ executed. All objects have this footprint: 32314564Sdim\ cell 0: first payload cell 33314564Sdim 34314564Sdim\ A ficl class consists of a parent class pointer, a wordlist 35314564Sdim\ ID for the methods of the class, and a size for the payload 36314564Sdim\ of objects created by the class. A class is an object. 37314564Sdim\ The NEW method creates and initializes an instance of a class. 38314564Sdim\ Classes have this footprint: 39314564Sdim\ cell 0: parent class address 40314564Sdim\ cell 1: wordlist ID 41314564Sdim\ cell 2: size of instance's payload 42314564Sdim 43314564Sdim\ Methods expect an object couple ( instance class ) 44314564Sdim\ on the stack. 45275072Semaste\ Overridden methods must maintain the same stack signature as 46275072Semaste\ their predecessors. Ficl has no way of enforcing this, though. 47288943Sdim 48314564Sdimuser current-class 49314564Sdim0 current-class ! 50314564Sdim 51314564Sdim\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 52314564Sdim\ ** L A T E B I N D I N G 53314564Sdim\ Compile the method name, and code to find and 54275072Semaste\ execute it at run-time... 55275072Semaste\ parse-method compiles the method name so that it pushes 56314564Sdim\ the string base address and count at run-time. 57314564Sdim\ 58314564Sdim: parse-method \ name run: ( -- c-addr u ) 59314564Sdim parse-word 60288943Sdim postpone sliteral 61288943Sdim; compile-only 62314564Sdim 63275072Semaste: lookup-method ( class c-addr u -- class xt ) 64314564Sdim 2dup 65314564Sdim local u 66275072Semaste local c-addr 67275072Semaste end-locals 68275072Semaste 2 pick cell+ @ ( -- class c-addr u wid ) 69275072Semaste search-wordlist ( -- class 0 | xt 1 | xt -1 ) 70314564Sdim 0= if 71314564Sdim c-addr u type ." not found in " 72314564Sdim body> >name type 73275072Semaste cr abort 74275072Semaste endif 75275072Semaste; 76314564Sdim 77314564Sdim: exec-method ( instance class c-addr u -- <method-signature> ) 78314564Sdim lookup-method execute 79275072Semaste; 80314564Sdim 81314564Sdim: find-method-xt \ name ( class -- class xt ) 82314564Sdim parse-word lookup-method 83314564Sdim; 84314564Sdim 85314564Sdim 86314564Sdim\ Method lookup operator takes a class-addr and instance-addr 87314564Sdim\ and executes the method from the class's wordlist if 88275072Semaste\ interpreting. If compiling, bind late. 89314564Sdim\ 90314564Sdim: --> ( instance class -- ??? ) 91314564Sdim state @ 0= if 92314564Sdim find-method-xt execute 93314564Sdim else 94314564Sdim parse-method postpone exec-method 95275072Semaste endif 96314564Sdim; immediate 97275072Semaste 98275072Semaste 99275072Semaste\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 100314564Sdim\ ** E A R L Y B I N D I N G 101314564Sdim\ Early binding operator compiles code to execute a method 102314564Sdim\ given its class at compile time. Classes are immediate, 103314564Sdim\ so they leave their cell-pair on the stack when compiling. 104314564Sdim\ Example: 105314564Sdim\ : get-wid metaclass => .wid @ ; 106314564Sdim\ Usage 107314564Sdim\ my-class get-wid ( -- wid-of-my-class ) 108314564Sdim\ 109314564Sdim: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method 110275072Semaste drop find-method-xt compile, drop 111275072Semaste; immediate compile-only 112275072Semaste 113314564Sdim 114314564Sdim\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 115314564Sdim\ ** I N S T A N C E V A R I A B L E S 116314564Sdim\ Instance variables (IV) are represented by words in the class's 117314564Sdim\ private wordlist. Each IV word contains the offset 118314564Sdim\ of the IV it represents, and runs code to add that offset 119314564Sdim\ to the base address of an instance when executed. 120314564Sdim\ The metaclass SUB method, defined below, leaves the address 121314564Sdim\ of the new class's offset field and its initial size on the 122314564Sdim\ stack for these words to update. When a class definition is 123314564Sdim\ complete, END-CLASS saves the final size in the class's size 124314564Sdim\ field, and restores the search order and compile wordlist to 125314564Sdim\ prior state. Note that these words are hidden in their own 126314564Sdim\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 127275072Semaste\ 128275072Semastewordlist 129314564Sdimdup constant instance-vars 130314564Sdimdup >search ficl-set-current 131314564Sdim: do-instance-var 132314564Sdim does> ( instance class addr[offset] -- addr[field] ) 133314564Sdim nip @ + 134275072Semaste; 135314564Sdim 136275072Semaste: addr-units: ( offset size "name" -- offset' ) 137314564Sdim create over , + 138314564Sdim do-instance-var 139275072Semaste; 140275072Semaste 141314564Sdim: chars: \ ( offset nCells "name" -- offset' ) Create n char member. 142314564Sdim chars addr-units: ; 143275072Semaste 144: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 145 1 chars: ; 146 147: cells: ( offset nCells "name" -- offset' ) 148 cells >r aligned r> addr-units: 149; 150 151: cell: ( offset nCells "name" -- offset' ) 152 1 cells: ; 153 154\ Aggregate an object into the class... 155\ Needs the class of the instance to create 156\ Example: object obj: m_obj 157\ 158: do-aggregate 159 does> ( instance class pfa -- a-instance a-class ) 160 2@ ( inst class a-class a-offset ) 161 2swap drop ( a-class a-offset inst ) 162 + swap ( a-inst a-class ) 163; 164 165: obj: ( offset class meta "name" -- offset' ) 166 locals| meta class offset | 167 create offset , class , 168 class meta --> get-size offset + 169 do-aggregate 170; 171 172\ Aggregate an array of objects into a class 173\ Usage example: 174\ 3 my-class array: my-array 175\ Makes an instance variable array of 3 instances of my-class 176\ named my-array. 177\ 178: array: ( offset n class meta "name" -- offset' ) 179 locals| meta class nobjs offset | 180 create offset , class , 181 class meta --> get-size nobjs * offset + 182 do-aggregate 183; 184 185\ Aggregate a pointer to an object: REF is a member variable 186\ whose class is set at compile time. This is useful for wrapping 187\ data structures in C, where there is only a pointer and the type 188\ it refers to is known. If you want polymorphism, see c_ref 189\ in classes.fr. REF is only useful for pre-initialized structures, 190\ since there's no supported way to set one. 191: ref: ( offset class meta "name" -- offset' ) 192 locals| meta class offset | 193 create offset , class , 194 offset cell+ 195 does> ( inst class pfa -- ptr-inst ptr-class ) 196 2@ ( inst class ptr-class ptr-offset ) 197 2swap drop + @ swap 198; 199 200\ END-CLASS terminates construction of a class by storing 201\ the size of its instance variables in the class's size field 202\ ( -- old-wid addr[size] 0 ) 203\ 204: end-class ( old-wid addr[size] size -- ) 205 swap ! set-current 206 search> drop \ pop struct builder wordlist 207; 208 209set-current previous 210\ E N D I N S T A N C E V A R I A B L E S 211 212 213\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 214\ D O - D O - I N S T A N C E 215\ Makes a class method that contains the code for an 216\ instance of the class. This word gets compiled into 217\ the wordlist of every class by the SUB method. 218\ PRECONDITION: current-class contains the class address 219\ 220: do-do-instance ( -- ) 221 s" : .do-instance does> [ current-class @ ] literal ;" 222 evaluate 223; 224 225\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 226\ ** M E T A C L A S S 227\ Every class is an instance of metaclass. This lets 228\ classes have methods that are different from those 229\ of their instances. 230\ Classes are IMMEDIATE to make early binding simpler 231\ See above... 232\ 233:noname 234 wordlist 235 create immediate 236 0 , \ NULL parent class 237 dup , \ wid 238 3 cells , \ instance size 239 ficl-set-current 240 does> dup 241; execute metaclass 242 243metaclass drop current-class ! 244do-do-instance 245 246\ 247\ C L A S S M E T H O D S 248\ 249instance-vars >search 250 251create .super ( class metaclass -- parent-class ) 252 0 cells , do-instance-var 253 254create .wid ( class metaclass -- wid ) \ return wid of class 255 1 cells , do-instance-var 256 257create .size ( class metaclass -- size ) \ return class's payload size 258 2 cells , do-instance-var 259 260previous 261 262: get-size metaclass => .size @ ; 263: get-wid metaclass => .wid @ ; 264: get-super metaclass => .super @ ; 265 266\ create an uninitialized instance of a class, leaving 267\ the address of the new instance and its class 268\ 269: instance ( class metaclass "name" -- instance class ) 270 locals| meta parent | 271 create 272 here parent --> .do-instance \ ( inst class ) 273 parent meta metaclass => get-size 274 allot \ allocate payload space 275; 276 277\ create an uninitialized array 278: array ( n class metaclass "name" -- n instance class ) 279 locals| meta parent nobj | 280 create nobj 281 here parent --> .do-instance \ ( nobj inst class ) 282 parent meta metaclass => get-size 283 nobj * allot \ allocate payload space 284; 285 286\ create an initialized instance 287\ 288: new \ ( class metaclass "name" -- ) 289 metaclass => instance --> init 290; 291 292\ create an initialized array of instances 293: new-array ( n class metaclass "name" -- ) 294 metaclass => array 295 --> array-init 296; 297 298\ create a proxy object with initialized payload address given 299: ref ( instance-addr class metaclass "name" -- ) 300 drop create , , 301 does> 2@ 302; 303 304\ create a subclass 305: sub ( class metaclass "name" -- old-wid addr[size] size ) 306 wordlist 307 locals| wid meta parent | 308 parent meta metaclass => get-wid 309 wid wid-set-super 310 create immediate 311 here current-class ! \ prep for do-do-instance 312 parent , \ save parent class 313 wid , \ save wid 314 here parent meta --> get-size dup , ( addr[size] size ) 315 metaclass => .do-instance 316 wid ficl-set-current -rot 317 do-do-instance 318 instance-vars >search \ push struct builder wordlist 319; 320 321\ OFFSET-OF returns the offset of an instance variable 322\ from the instance base address. If the next token is not 323\ the name of in instance variable method, you get garbage 324\ results -- there is no way at present to check for this error. 325: offset-of ( class metaclass "name" -- offset ) 326 drop find-method-xt nip >body @ ; 327 328\ ID returns the string name cell-pair of its class 329: id ( class metaclass -- c-addr u ) 330 drop body> >name ; 331 332\ list methods of the class 333: methods \ ( class meta -- ) 334 locals| meta class | 335 begin 336 class body> >name type ." methods:" cr 337 class meta --> get-wid >search words cr previous 338 class meta metaclass => get-super 339 dup to class 340 0= until cr 341; 342 343\ list class's ancestors 344: pedigree ( class meta -- ) 345 locals| meta class | 346 begin 347 class body> >name type space 348 class meta metaclass => get-super 349 dup to class 350 0= until cr 351; 352 353\ decompile a method 354: see ( class meta -- ) 355 metaclass => get-wid >search see previous ; 356 357set-current 358\ E N D M E T A C L A S S 359 360\ META is a nickname for the address of METACLASS... 361metaclass drop 362constant meta 363 364\ SUBCLASS is a nickname for a class's SUB method... 365\ Subclass compilation ends when you invoke end-class 366\ This method is late bound for safety... 367: subclass --> sub ; 368 369 370\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 371\ ** O B J E C T 372\ Root of all classes 373:noname 374 wordlist 375 create immediate 376 0 , \ NULL parent class 377 dup , \ wid 378 0 , \ instance size 379 ficl-set-current 380 does> meta 381; execute object 382 383object drop current-class ! 384do-do-instance 385 386\ O B J E C T M E T H O D S 387\ Convert instance cell-pair to class cell-pair 388\ Useful for binding class methods from an instance 389: class ( instance class -- class metaclass ) 390 nip meta ; 391 392\ default INIT method zero fills an instance 393: init ( instance class -- ) 394 meta 395 metaclass => get-size ( inst size ) 396 erase ; 397 398\ Apply INIT to an array of NOBJ objects... 399\ 400: array-init ( nobj inst class -- ) 401 0 dup locals| &init &next class inst | 402 \ 403 \ bind methods outside the loop to save time 404 \ 405 class s" init" lookup-method to &init 406 s" next" lookup-method to &next 407 drop 408 0 ?do 409 inst class 2dup 410 &init execute 411 &next execute drop to inst 412 loop 413; 414 415\ Instance aliases for common class methods 416\ Upcast to parent class 417: super ( instance class -- instance parent-class ) 418 meta metaclass => get-super ; 419 420: pedigree ( instance class -- ) 421 object => class 422 metaclass => pedigree ; 423 424: size ( instance class -- sizeof-instance ) 425 object => class 426 metaclass => get-size ; 427 428: methods ( instance class -- ) 429 object => class 430 metaclass => methods ; 431 432\ Array indexing methods... 433\ Usage examples: 434\ 10 object-array --> index 435\ obj --> next 436\ 437: index ( n instance class -- instance[n] class ) 438 locals| class inst | 439 inst class 440 object => class 441 metaclass => get-size * ( n*size ) 442 inst + class ; 443 444: next ( instance[n] class -- instance[n+1] class ) 445 locals| class inst | 446 inst class 447 object => class 448 metaclass => get-size 449 inst + 450 class ; 451 452: prev ( instance[n] class -- instance[n-1] class ) 453 locals| class inst | 454 inst class 455 object => class 456 metaclass => get-size 457 inst swap - 458 class ; 459 460set-current 461\ E N D O B J E C T 462 463 464previous definitions 465