| oo.fr (76116) | oo.fr (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\ | 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 76116 2001-04-29 02:36:36Z dcs $ | 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 --- 10 unchanged lines hidden (view full) --- 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 | 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 --- 10 unchanged lines hidden (view full) --- 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. All objects have this footprint: 34\ cell 0: first payload cell | 33\ executed. |
| 35 36\ A ficl class consists of a parent class pointer, a wordlist 37\ ID for the methods of the class, and a size for the payload 38\ of objects created by the class. A class is an object. 39\ The NEW method creates and initializes an instance of a class. 40\ Classes have this footprint: 41\ cell 0: parent class address 42\ cell 1: wordlist ID 43\ cell 2: size of instance's payload 44 45\ Methods expect an object couple ( instance class ) | 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 ) |
| 46\ on the stack. | 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\ |
| 47\ Overridden methods must maintain the same stack signature as | 49\ Overridden methods must maintain the same stack signature as |
| 48\ their predecessors. Ficl has no way of enforcing this, though. | 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 |
| 49 | 77 |
| 78 79 |
|
| 50user current-class 510 current-class ! 52 53\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 54\ ** L A T E B I N D I N G 55\ Compile the method name, and code to find and 56\ execute it at run-time... | 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... |
| 57\ parse-method compiles the method name so that it pushes 58\ the string base address and count at run-time. | |
| 59\ 60 61hide 62 | 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 |
|
| 63: parse-method \ name run: ( -- c-addr u ) 64 parse-word | 95: parse-method \ name run: ( -- c-addr u ) 96 parse-word |
| 65 postpone sliteral | 97 postpone sliteral |
| 66; compile-only 67 | 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 |
|
| 68: lookup-method { class 2:name -- class xt } | 106: lookup-method { class 2:name -- class xt } |
| 69 name class cell+ @ ( c-addr u wid ) 70 search-wordlist ( 0 | xt 1 | xt -1 ) 71 0= if 72 name type ." not found in " | 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 " |
| 73 class body> >name type 74 cr abort | 111 class body> >name type 112 cr abort |
| 75 endif | 113 endif |
| 76 class swap 77; 78 79: find-method-xt \ name ( class -- class xt ) | 114 class swap 115; 116 117: find-method-xt \ name ( class -- class xt ) |
| 80 parse-word lookup-method | 118 parse-word lookup-method |
| 81; 82 83set-current ( stop hiding definitions ) 84 85: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) 86 lookup-method catch 87; 88 89: exec-method ( instance class c-addr u -- <method-signature> ) 90 lookup-method execute 91; 92 93\ Method lookup operator takes a class-addr and instance-addr 94\ and executes the method from the class's wordlist if 95\ interpreting. If compiling, bind late. 96\ 97: --> ( instance class -- ??? ) 98 state @ 0= if | 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 |
| 99 find-method-xt execute | 137 find-method-xt execute |
| 100 else | 138 else |
| 101 parse-method postpone exec-method | 139 parse-method postpone exec-method |
| 102 endif 103; immediate 104 105\ Method lookup with CATCH in case of exceptions 106: c-> ( instance class -- ?? exc-flag ) 107 state @ 0= if | 140 endif 141; immediate 142 143\ Method lookup with CATCH in case of exceptions 144: c-> ( instance class -- ?? exc-flag ) 145 state @ 0= if |
| 108 find-method-xt catch | 146 find-method-xt catch |
| 109 else | 147 else |
| 110 parse-method postpone catch-method | 148 parse-method postpone catch-method |
| 111 endif 112; immediate 113 114\ METHOD makes global words that do method invocations by late binding 115\ in case you prefer this style (no --> in your code) | 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 |
|
| 116: method create does> body> >name lookup-method execute ; 117 118 119\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 120\ ** E A R L Y B I N D I N G 121\ Early binding operator compiles code to execute a method 122\ given its class at compile time. Classes are immediate, 123\ so they leave their cell-pair on the stack when compiling. 124\ Example: 125\ : get-wid metaclass => .wid @ ; 126\ Usage 127\ my-class get-wid ( -- wid-of-my-class ) 128\ 1291 ficl-named-wordlist instance-vars 130instance-vars dup >search ficl-set-current 131 132: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method | 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 |
| 133 drop find-method-xt compile, drop | 176 drop find-method-xt compile, drop |
| 134; immediate compile-only 135 136: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class 137 current-class @ dup postpone => 138; immediate compile-only 139 | 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. |
|
| 140: my=[ \ same as my=> , but binds a chain of methods 141 current-class @ 142 begin | 188: my=[ \ same as my=> , but binds a chain of methods 189 current-class @ 190 begin |
| 143 parse-word 2dup 144 s" ]" compare while ( class c-addr u ) 145 lookup-method nip dup ( xt xt ) 146 compile, >body cell+ @ ( class' ) | 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 |
| 147 repeat 2drop drop 148; immediate compile-only 149 150 151\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 152\ ** I N S T A N C E V A R I A B L E S 153\ Instance variables (IV) are represented by words in the class's 154\ private wordlist. Each IV word contains the offset --- 4 unchanged lines hidden (view full) --- 159\ stack for these words to update. When a class definition is 160\ complete, END-CLASS saves the final size in the class's size 161\ field, and restores the search order and compile wordlist to 162\ prior state. Note that these words are hidden in their own 163\ wordlist to prevent accidental use outside a SUB END-CLASS pair. 164\ 165: do-instance-var 166 does> ( instance class addr[offset] -- addr[field] ) | 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 --- 4 unchanged lines hidden (view full) --- 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] ) |
| 167 nip @ + | 220 nip @ + |
| 168; 169 170: addr-units: ( offset size "name" -- offset' ) 171 create over , + 172 do-instance-var 173; 174 | 221; 222 223: addr-units: ( offset size "name" -- offset' ) 224 create over , + 225 do-instance-var 226; 227 |
| 175: chars: \ ( offset nCells "name" -- offset' ) Create n char member. | 228: chars: \ ( offset nCells "name" -- offset' ) Create n char member. |
| 176 chars addr-units: ; 177 | 229 chars addr-units: ; 230 |
| 178: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. | 231: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. |
| 179 1 chars: ; 180 181: cells: ( offset nCells "name" -- offset' ) | 232 1 chars: ; 233 234: cells: ( offset nCells "name" -- offset' ) |
| 182 cells >r aligned r> addr-units: | 235 cells >r aligned r> addr-units: |
| 183; 184 185: cell: ( offset nCells "name" -- offset' ) 186 1 cells: ; 187 188\ Aggregate an object into the class... 189\ Needs the class of the instance to create 190\ Example: object obj: m_obj 191\ 192: do-aggregate | 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 |
| 193 does> ( instance class pfa -- a-instance a-class ) 194 2@ ( inst class a-class a-offset ) 195 2swap drop ( a-class a-offset inst ) 196 + swap ( a-inst a-class ) | 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 ) |
| 197; 198 | 251; 252 |
| 199: obj: ( offset class meta "name" -- offset' ) 200 locals| meta class offset | | 253: obj: { offset class meta -- offset' } \ "name" |
| 201 create offset , class , | 254 create offset , class , |
| 202 class meta --> get-size offset + 203 do-aggregate | 255 class meta --> get-size offset + 256 do-aggregate |
| 204; 205 206\ Aggregate an array of objects into a class 207\ Usage example: 208\ 3 my-class array: my-array 209\ Makes an instance variable array of 3 instances of my-class 210\ named my-array. 211\ 212: array: ( offset n class meta "name" -- offset' ) | 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' ) |
| 213 locals| meta class nobjs offset | 214 create offset , class , 215 class meta --> get-size nobjs * offset + 216 do-aggregate | 266 locals| meta class nobjs offset | 267 create offset , class , 268 class meta --> get-size nobjs * offset + 269 do-aggregate |
| 217; 218 219\ Aggregate a pointer to an object: REF is a member variable 220\ whose class is set at compile time. This is useful for wrapping 221\ data structures in C, where there is only a pointer and the type 222\ it refers to is known. If you want polymorphism, see c_ref 223\ in classes.fr. REF is only useful for pre-initialized structures, 224\ since there's no supported way to set one. 225: ref: ( offset class meta "name" -- offset' ) | 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' ) |
| 226 locals| meta class offset | 227 create offset , class , 228 offset cell+ 229 does> ( inst class pfa -- ptr-inst ptr-class ) 230 2@ ( inst class ptr-class ptr-offset ) 231 2swap drop + @ swap | 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 |
| 232; 233 | 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 |
|
| 234\ END-CLASS terminates construction of a class by storing 235\ the size of its instance variables in the class's size field 236\ ( -- old-wid addr[size] 0 ) 237\ 238: end-class ( old-wid addr[size] size -- ) 239 swap ! set-current | 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 |
| 240 search> drop \ pop struct builder wordlist | 315 search> drop \ pop struct builder wordlist |
| 241; 242 243\ See resume-class (a metaclass method) below for usage 244\ This is equivalent to end-class for now, but that will change 245\ when we support vtable bindings. 246: suspend-class ( old-wid addr[size] size -- ) end-class ; 247 248set-current previous 249\ E N D I N S T A N C E V A R I A B L E S 250 251 252\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 253\ D O - D O - I N S T A N C E 254\ Makes a class method that contains the code for an 255\ instance of the class. This word gets compiled into 256\ the wordlist of every class by the SUB method. 257\ PRECONDITION: current-class contains the class address 258\ why use a state variable instead of the stack? | 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? |
| 259\ >> Stack state is not well-defined during compilation (there are | 334\ >> Stack state is not well-defined during compilation (there are |
| 260\ >> control structure match codes on the stack, of undefined size 261\ >> easiest way around this is use of this thread-local variable 262\ 263: do-do-instance ( -- ) 264 s" : .do-instance does> [ current-class @ ] literal ;" 265 evaluate 266; 267 268\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 269\ ** M E T A C L A S S 270\ Every class is an instance of metaclass. This lets 271\ classes have methods that are different from those 272\ of their instances. 273\ Classes are IMMEDIATE to make early binding simpler 274\ See above... 275\ 276:noname | 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 |
| 277 wordlist 278 create | 352 wordlist 353 create |
| 279 immediate | 354 immediate |
| 280 0 , \ NULL parent class 281 dup , \ wid 282 3 cells , \ instance size 283 ficl-set-current 284 does> dup | 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 |
| 285; execute metaclass 286\ now brand OBJECT's wordlist (so that ORDER can display it by name) 287metaclass drop cell+ @ brand-wordlist 288 289metaclass drop current-class ! 290do-do-instance 291 292\ 293\ C L A S S M E T H O D S 294\ 295instance-vars >search 296 297create .super ( class metaclass -- parent-class ) 298 0 cells , do-instance-var 299 300create .wid ( class metaclass -- wid ) \ return wid of class 301 1 cells , do-instance-var 302 | 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 |
|
| 303create .size ( class metaclass -- size ) \ return class's payload size | 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 |
|
| 304 2 cells , do-instance-var | 390 2 cells , do-instance-var |
| 391\ #endif |
|
| 305 306: get-size metaclass => .size @ ; 307: get-wid metaclass => .wid @ ; 308: get-super metaclass => .super @ ; | 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 |
|
| 309 310\ create an uninitialized instance of a class, leaving 311\ the address of the new instance and its class 312\ 313: instance ( class metaclass "name" -- instance class ) 314 locals| meta parent | | 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 | |
| 315 create | 406 create |
| 316 here parent --> .do-instance \ ( inst class ) 317 parent meta metaclass => get-size 318 allot \ allocate payload space 319; 320 321\ create an uninitialized array 322: array ( n class metaclass "name" -- n instance class ) 323 locals| meta parent nobj | | 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 | |
| 324 create nobj | 415 create nobj |
| 325 here parent --> .do-instance \ ( nobj inst class ) 326 parent meta metaclass => get-size | 416 here parent --> .do-instance \ ( nobj inst class ) 417 parent meta metaclass => get-size |
| 327 nobj * allot \ allocate payload space | 418 nobj * allot \ allocate payload space |
| 328; 329 330\ create an initialized instance 331\ 332: new \ ( class metaclass "name" -- ) 333 metaclass => instance --> init 334; 335 336\ create an initialized array of instances 337: new-array ( n class metaclass "name" -- ) | 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" -- ) |
| 338 metaclass => array 339 --> array-init | 429 metaclass => array 430 --> array-init |
| 340; 341 342\ Create an anonymous initialized instance from the heap 343: alloc \ ( class metaclass -- instance class ) 344 locals| meta class | 345 class meta metaclass => get-size allocate ( -- addr fail-flag ) 346 abort" allocate failed " ( -- addr ) 347 class 2dup --> init --- 53 unchanged lines hidden (view full) --- 401\ This method leaves the stack and search order ready for instance variable 402\ building. Pushes the instance-vars wordlist onto the search order, 403\ and sets the compilation wordlist to be the private wordlist of the 404\ new class. The class's wordlist is deliberately NOT in the search order - 405\ to prevent methods from getting used with wrong data. 406\ Postcondition: leaves the address of the new class in current-class 407: sub ( class metaclass "name" -- old-wid addr[size] size ) 408 wordlist | 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 --- 53 unchanged lines hidden (view full) --- 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 |
| 409 locals| wid meta parent | 410 parent meta metaclass => get-wid 411 wid wid-set-super \ set superclass 412 create immediate \ get the subclass name | 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 |
| 413 wid brand-wordlist \ label the subclass wordlist | 504 wid brand-wordlist \ label the subclass wordlist |
| 414 here current-class ! \ prep for do-do-instance 415 parent , \ save parent class 416 wid , \ save wid 417 here parent meta --> get-size dup , ( addr[size] size ) 418 metaclass => .do-instance 419 wid ficl-set-current -rot 420 do-do-instance 421 instance-vars >search \ push struct builder 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 |
| 422; 423 424\ OFFSET-OF returns the offset of an instance variable 425\ from the instance base address. If the next token is not 426\ the name of in instance variable method, you get garbage 427\ results -- there is no way at present to check for this error. 428: offset-of ( class metaclass "name" -- offset ) 429 drop find-method-xt nip >body @ ; 430 431\ ID returns the string name cell-pair of its class 432: id ( class metaclass -- c-addr u ) | 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 ) |
| 433 drop body> >name ; | 527 drop body> >name ; |
| 434 435\ list methods of the class 436: methods \ ( class meta -- ) | 528 529\ list methods of the class 530: methods \ ( class meta -- ) |
| 437 locals| meta class | 438 begin 439 class body> >name type ." methods:" cr 440 class meta --> get-wid >search words cr previous 441 class meta metaclass => get-super 442 dup to class 443 0= until cr | 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 |
| 444; 445 446\ list class's ancestors 447: pedigree ( class meta -- ) | 538; 539 540\ list class's ancestors 541: pedigree ( class meta -- ) |
| 448 locals| meta class | 449 begin 450 class body> >name type space 451 class meta metaclass => get-super 452 dup to class 453 0= until cr | 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 |
| 454; 455 | 548; 549 |
| 456\ decompile a method | 550\ decompile an instance method |
| 457: see ( class meta -- ) 458 metaclass => get-wid >search see previous ; 459 | 551: see ( class meta -- ) 552 metaclass => get-wid >search see previous ; 553 |
| 460previous set-current | 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 |
| 461\ E N D M E T A C L A S S 462 463\ ** META is a nickname for the address of METACLASS... 464metaclass drop 465constant meta 466 467\ ** SUBCLASS is a nickname for a class's SUB method... 468\ Subclass compilation ends when you invoke end-class 469\ This method is late bound for safety... 470: subclass --> sub ; 471 | 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 |
|
| 472 | 576 |
| 577 |
|
| 473\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 474\ ** O B J E C T 475\ Root of all classes 476:noname | 578\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 579\ ** O B J E C T 580\ Root of all classes 581:noname |
| 477 wordlist 478 create immediate 479 0 , \ NULL parent class 480 dup , \ wid 481 0 , \ instance size 482 ficl-set-current 483 does> meta | 582 wordlist 583 create immediate 584 0 , \ NULL parent class 585 dup , \ wid 586 0 , \ instance size 587 ficl-set-current 588 does> meta |
| 484; execute object 485\ now brand OBJECT's wordlist (so that ORDER can display it by name) 486object drop cell+ @ brand-wordlist 487 488object drop current-class ! 489do-do-instance 490instance-vars >search 491 492\ O B J E C T M E T H O D S 493\ Convert instance cell-pair to class cell-pair 494\ Useful for binding class methods from an instance 495: class ( instance class -- class metaclass ) | 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 ) |
| 496 nip meta ; | 601 nip meta ; |
| 497 498\ default INIT method zero fills an instance 499: init ( instance class -- ) 500 meta 501 metaclass => get-size ( inst size ) 502 erase ; 503 504\ Apply INIT to an array of NOBJ objects... 505\ 506: array-init ( nobj inst class -- ) | 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 -- ) |
| 507 0 dup locals| &init &next class inst | 508 \ 509 \ bind methods outside the loop to save time 510 \ 511 class s" init" lookup-method to &init 512 s" next" lookup-method to &next 513 drop 514 0 ?do 515 inst class 2dup 516 &init execute 517 &next execute drop to inst 518 loop | 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 |
| 519; 520 521\ free storage allocated to a heap instance by alloc or alloc-array 522\ NOTE: not protected against errors like FREEing something that's 523\ really in the dictionary. 524: free \ ( instance class -- ) | 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 -- ) |
| 525 drop free 526 abort" free failed " | 630 drop free 631 abort" free failed " |
| 527; 528 529\ Instance aliases for common class methods 530\ Upcast to parent class 531: super ( instance class -- instance parent-class ) 532 meta metaclass => get-super ; 533 534: pedigree ( instance class -- ) | 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 -- ) |
| 535 object => class | 640 object => class |
| 536 metaclass => pedigree ; 537 538: size ( instance class -- sizeof-instance ) | 641 metaclass => pedigree ; 642 643: size ( instance class -- sizeof-instance ) |
| 539 object => class | 644 object => class |
| 540 metaclass => get-size ; 541 542: methods ( instance class -- ) | 645 metaclass => get-size ; 646 647: methods ( instance class -- ) |
| 543 object => class | 648 object => class |
| 544 metaclass => methods ; 545 546\ Array indexing methods... 547\ Usage examples: 548\ 10 object-array --> index 549\ obj --> next 550\ 551: index ( n instance class -- instance[n] 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 ) |
| 552 locals| class inst | 553 inst class | 657 locals| class inst | 658 inst class |
| 554 object => class | 659 object => class |
| 555 metaclass => get-size * ( n*size ) 556 inst + class ; | 660 metaclass => get-size * ( n*size ) 661 inst + class ; |
| 557 558: next ( instance[n] class -- instance[n+1] class ) | 662 663: next ( instance[n] class -- instance[n+1] class ) |
| 559 locals| class inst | 560 inst class | 664 locals| class inst | 665 inst class |
| 561 object => class | 666 object => class |
| 562 metaclass => get-size 563 inst + 564 class ; | 667 metaclass => get-size 668 inst + 669 class ; |
| 565 566: prev ( instance[n] class -- instance[n-1] class ) | 670 671: prev ( instance[n] class -- instance[n-1] class ) |
| 567 locals| class inst | 568 inst class | 672 locals| class inst | 673 inst class |
| 569 object => class | 674 object => class |
| 570 metaclass => get-size 571 inst swap - 572 class ; | 675 metaclass => get-size 676 inst swap - 677 class ; |
| 573 574: debug ( 2this -- ?? ) 575 find-method-xt debug-xt ; 576 577previous set-current 578\ E N D O B J E C T 579 | 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 |
| 580 | 685\ reset to default search order |
| 581only definitions | 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 |
|
| 582\ #endif | 693\ #endif |