usr/src/common/ficl/softcore/oo.fr

   1 S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
   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 .( loading ficl O-O extensions ) cr
   7 17 ficl-vocabulary oop
   8 also oop definitions
   9
  10 \ Design goals:
  11 \ 0. Traditional OOP: late binding by default for safety.
  12 \    Early binding if you ask for it.
  13 \ 1. Single inheritance
  14 \ 2. Object aggregation (has-a relationship)
  15 \ 3. Support objects in the dictionary and as proxies for
  16 \    existing structures (by reference):
  17 \    *** A ficl object can wrap a C struct ***
  18 \ 4. Separate name-spaces for methods - methods are
  19 \    only visible in the context of a class / object
  20 \ 5. Methods can be overridden, and subclasses can add methods.
  21 \    No limit on number of methods.
  22
  23 \ General info:
  24 \ Classes are objects, too: all classes are instances of METACLASS
  25 \ All classes are derived (by convention) from OBJECT. This
  26 \ base class provides a default initializer and superclass
  27 \ access method
  28
  29 \ A ficl object binds instance storage (payload) to a class.
  30 \ object  ( -- instance class )
  31 \ All objects push their payload address and class address when
  32 \ executed.
  33
  34 \ A ficl class consists of a parent class pointer, a wordlist
  35 \ ID for the methods of the class, and a size for the payload
  36 \ of objects created by the class. A class is an object.
  37 \ The NEW method creates and initializes an instance of a class.
  38 \ Classes have this footprint:
  39 \ cell 0: parent class address
  40 \ cell 1: wordlist ID
  41 \ cell 2: size of instance's payload
  42
  43 \ Methods expect an object couple ( instance class )
  44 \ on the stack. This is by convention - ficl has no way to
  45 \ police your code to make sure this is always done, but it
  46 \ happens naturally if you use the facilities presented here.
  47 \
  48 \ Overridden methods must maintain the same stack signature as
  49 \ their predecessors. Ficl has no way of enforcing this, either.
  50 \
  51 \ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
  52 \ has an extra field for the vtable method count. Hasvtable declares
  53 \ refs to vtable classes
  54 \
  55 \ Revised Nov 2001 - metaclass debug method now finds only metaclass methods
  56 \
  57 \ Planned: Ficl vtable support
  58 \ Each class has a vtable size parameter
  59 \ END-CLASS allocates and clears the vtable - then it walks class's method
  60 \ list and inserts all new methods into table. For each method, if the table
  61 \ slot is already nonzero, do nothing (overridden method). Otherwise fill
  62 \ vtable slot. Now do same check for parent class vtable, filling only
  63 \ empty slots in the new vtable.
  64 \ Methods are now structured as follows:
  65 \ - header
  66 \ - vtable index
  67 \ - xt
  68 \ :noname definition for code
  69 \
  70 \ : is redefined to check for override, fill in vtable index, increment method
  71 \ count if not an override, create header and fill in index. Allot code pointer
  72 \ and run :noname
  73 \ ; is overridden to fill in xt returned by :noname
  74 \ --> compiles code to fetch vtable address, offset by index, and execute
  75 \ => looks up xt in the vtable and compiles it directly
  76
  77
  78
  79 user current-class
  80 0 current-class !
  81
  82 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  83 \ ** L A T E   B I N D I N G
  84 \ Compile the method name, and code to find and
  85 \ execute it at run-time...
  86 \
  87
  88 \ p a r s e - m e t h o d
  89 \ compiles a method name so that it pushes
  90 \ the string base address and count at run-time.
  91
  92 : parse-method  \ name  run: ( -- c-addr u )
  93     parse-word
  94     postpone sliteral
  95 ; compile-only
  96
  97
  98
  99 : (lookup-method)  { class 2:name -- class 0 | class xt 1 | class xt -1  }
 100     class  name class cell+ @  ( class c-addr u wid )
 101     search-wordlist
 102 ;
 103
 104 \ l o o k u p - m e t h o d
 105 \ takes a counted string method name from the stack (as compiled
 106 \ by parse-method) and attempts to look this method up in the method list of
 107 \ the class that's on the stack. If successful, it leaves the class on the stack
 108 \ and pushes the xt of the method. If not, it aborts with an error message.
 109
 110 : lookup-method  { class 2:name -- class xt }
 111     class name (lookup-method)    ( 0 | xt 1 | xt -1 )
 112     0= if
 113         name type ."  not found in "
 114         class body> >name type
 115         cr abort
 116     endif
 117 ;
 118
 119 : find-method-xt   \ name ( class -- class xt )
 120     parse-word lookup-method
 121 ;
 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 \
 172 1 ficl-named-wordlist instance-vars
 173 instance-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 an 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 S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
 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 S" FICL_WANT_FLOAT" ENVIRONMENT? drop [if]
 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
 307 [endif] \ FICL_WANT_FLOAT
 308 [endif] \ FICL_WANT_VCALL
 309
 310 \ END-CLASS terminates construction of a class by storing
 311 \  the size of its instance variables in the class's size field
 312 \ ( -- old-wid addr[size] 0 )
 313 \
 314 : end-class  ( old-wid addr[size] size -- )
 315     swap ! set-current
 316     search> drop        \ pop struct builder wordlist
 317 ;
 318
 319 \ See resume-class (a metaclass method) below for usage
 320 \ This is equivalent to end-class for now, but that will change
 321 \ when we support vtable bindings.
 322 : suspend-class  ( old-wid addr[size] size -- )   end-class ;
 323
 324 set-current previous
 325 \ E N D   I N S T A N C E   V A R I A B L E S
 326
 327
 328 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 329 \ D O - D O - I N S T A N C E
 330 \ Makes a class method that contains the code for an
 331 \ instance of the class. This word gets compiled into
 332 \ the wordlist of every class by the SUB method.
 333 \ PRECONDITION: current-class contains the class address
 334 \ why use a state variable instead of the stack?
 335 \ >> Stack state is not well-defined during compilation (there are
 336 \ >> control structure match codes on the stack, of undefined size
 337 \ >> easiest way around this is use of this thread-local variable
 338 \
 339 : do-do-instance  ( -- )
 340     s" : .do-instance does> [ current-class @ ] literal ;"
 341     evaluate
 342 ;
 343
 344 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 345 \ ** M E T A C L A S S
 346 \ Every class is an instance of metaclass. This lets
 347 \ classes have methods that are different from those
 348 \ of their instances.
 349 \ Classes are IMMEDIATE to make early binding simpler
 350 \ See above...
 351 \
 352 :noname
 353     wordlist
 354     create
 355     immediate
 356     0       ,   \ NULL parent class
 357     dup     ,   \ wid
 358 [ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
 359     4 cells ,   \ instance size
 360 [else]
 361     3 cells ,   \ instance size
 362 [endif]
 363     ficl-set-current
 364     does> dup
 365 ;  execute metaclass
 366 \ now brand OBJECT's wordlist (so that ORDER can display it by name)
 367 metaclass drop cell+ @ brand-wordlist
 368
 369 metaclass drop current-class !
 370 do-do-instance
 371
 372 \
 373 \ C L A S S   M E T H O D S
 374 \
 375 instance-vars >search
 376
 377 create .super  ( class metaclass -- parent-class )
 378     0 cells , do-instance-var
 379
 380 create .wid    ( class metaclass -- wid ) \ return wid of class
 381     1 cells , do-instance-var
 382
 383 S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
 384 create .vtCount   \ Number of VTABLE methods, if any
 385     2 cells , do-instance-var
 386
 387 create  .size  ( class metaclass -- size ) \ return class's payload size
 388     3 cells , do-instance-var
 389
 390 [else]
 391
 392 create  .size  ( class metaclass -- size ) \ return class's payload size
 393     2 cells , do-instance-var
 394
 395 [endif]
 396
 397 : get-size    metaclass => .size  @ ;
 398 : get-wid     metaclass => .wid   @ ;
 399 : get-super   metaclass => .super @ ;
 400 S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
 401 : get-vtCount metaclass => .vtCount @ ;
 402 : get-vtAdd   metaclass => .vtCount ;
 403 [endif]
 404
 405 \ create an uninitialized instance of a class, leaving
 406 \ the address of the new instance and its class
 407 \
 408 : instance   ( class metaclass "name" -- instance class )
 409     locals| meta parent |
 410     create
 411     here parent --> .do-instance \ ( inst class )
 412     parent meta metaclass => get-size
 413     allot                        \ allocate payload space
 414 ;
 415
 416 \ create an uninitialized array
 417 : array   ( n class metaclass "name" -- n instance class )
 418     locals| meta parent nobj |
 419     create  nobj
 420     here parent --> .do-instance \ ( nobj inst class )
 421     parent meta metaclass => get-size
 422     nobj *  allot           \ allocate payload space
 423 ;
 424
 425 \ create an initialized instance
 426 \
 427 : new   \ ( class metaclass "name" -- )
 428     metaclass => instance --> init
 429 ;
 430
 431 \ create an initialized array of instances
 432 : new-array   ( n class metaclass "name" -- )
 433     metaclass => array
 434     --> array-init
 435 ;
 436
 437 \ Create an anonymous initialized instance from the heap
 438 : alloc   \ ( class metaclass -- instance class )
 439     locals| meta class |
 440     class meta metaclass => get-size allocate   ( -- addr fail-flag )
 441     abort" allocate failed "                    ( -- addr )
 442     class 2dup --> init
 443 ;
 444
 445 \ Create an anonymous array of initialized instances from the heap
 446 : alloc-array   \ ( n class metaclass -- instance class )
 447     locals| meta class nobj |
 448     class meta metaclass => get-size
 449     nobj * allocate                 ( -- addr fail-flag )
 450     abort" allocate failed "        ( -- addr )
 451     nobj over class --> array-init
 452     class
 453 ;
 454
 455 \ Create an anonymous initialized instance from the dictionary
 456 : allot   { 2:this -- 2:instance }
 457     here   ( instance-address )
 458     this my=> get-size  allot
 459     this drop 2dup --> init
 460 ;
 461
 462 \ Create an anonymous array of initialized instances from the dictionary
 463 : allot-array   { nobj 2:this -- 2:instance }
 464     here   ( instance-address )
 465     this my=> get-size  nobj * allot
 466     this drop 2dup     ( 2instance 2instance )
 467     nobj -rot --> array-init
 468 ;
 469
 470 \ create a proxy object with initialized payload address given
 471 : ref   ( instance-addr class metaclass "name" -- )
 472     drop create , ,
 473     does> 2@
 474 ;
 475
 476 \ suspend-class and resume-class help to build mutually referent classes.
 477 \ Example:
 478 \ object subclass c-akbar
 479 \ suspend-class   ( put akbar on hold while we define jeff )
 480 \ object subclass c-jeff
 481 \     c-akbar ref: .akbar
 482 \     ( and whatever else comprises this class )
 483 \ end-class    ( done with c-jeff )
 484 \ c-akbar --> resume-class
 485 \     c-jeff ref: .jeff
 486 \     ( and whatever else goes in c-akbar )
 487 \ end-class    ( done with c-akbar )
 488 \
 489 : resume-class   { 2:this -- old-wid addr[size] size }
 490     this --> .wid @ ficl-set-current  ( old-wid )
 491     this --> .size dup @   ( old-wid addr[size] size )
 492     instance-vars >search
 493 ;
 494
 495 \ create a subclass
 496 \ This method leaves the stack and search order ready for instance variable
 497 \ building. Pushes the instance-vars wordlist onto the search order,
 498 \ and sets the compilation wordlist to be the private wordlist of the
 499 \ new class. The class's wordlist is deliberately NOT in the search order -
 500 \ to prevent methods from getting used with wrong data.
 501 \ Postcondition: leaves the address of the new class in current-class
 502 : sub   ( class metaclass "name" -- old-wid addr[size] size )
 503     wordlist
 504     locals| wid meta parent |
 505     parent meta metaclass => get-wid
 506     wid wid-set-super       \ set superclass
 507     create  immediate       \ get the  subclass name
 508     wid brand-wordlist      \ label the subclass wordlist
 509     here current-class !    \ prep for do-do-instance
 510     parent ,                \ save parent class
 511     wid    ,                \ save wid
 512 [ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
 513     parent meta --> get-vtCount ,
 514 [endif]
 515     here parent meta --> get-size dup ,  ( addr[size] size )
 516     metaclass => .do-instance
 517     wid ficl-set-current -rot
 518     do-do-instance
 519     instance-vars >search \ push struct builder wordlist
 520 ;
 521
 522 \ OFFSET-OF returns the offset of an instance variable
 523 \ from the instance base address. If the next token is not
 524 \ the name of in instance variable method, you get garbage
 525 \ results -- there is no way at present to check for this error.
 526 : offset-of   ( class metaclass "name" -- offset )
 527     drop find-method-xt nip >body @ ;
 528
 529 \ ID returns the string name cell-pair of its class
 530 : id   ( class metaclass -- c-addr u )
 531     drop body> >name  ;
 532
 533 \ list methods of the class
 534 : methods \ ( class meta -- )
 535     locals| meta class |
 536     begin
 537         class body> >name type ."  methods:" cr
 538         class meta --> get-wid >search words cr previous
 539         class meta metaclass => get-super
 540         dup to class
 541     0= until  cr
 542 ;
 543
 544 \ list class's ancestors
 545 : pedigree  ( class meta -- )
 546     locals| meta class |
 547     begin
 548         class body> >name type space
 549         class meta metaclass => get-super
 550         dup to class
 551     0= until  cr
 552 ;
 553
 554 \ decompile an instance method
 555 : see  ( class meta -- )
 556     metaclass => get-wid >search see previous ;
 557
 558 \ debug a method of metaclass
 559 \ Eg: my-class --> debug my-method
 560 : debug  ( class meta -- )
 561         find-method-xt debug-xt ;
 562
 563 previous set-current
 564 \ E N D   M E T A C L A S S
 565
 566 \ ** META is a nickname for the address of METACLASS...
 567 metaclass drop
 568 constant meta
 569
 570 \ ** SUBCLASS is a nickname for a class's SUB method...
 571 \ Subclass compilation ends when you invoke end-class
 572 \ This method is late bound for safety...
 573 : subclass   --> sub ;
 574
 575 S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
 576 \ VTABLE Support extensions (Guy Carver)
 577 \ object --> sub mine hasvtable
 578 : hasvtable 4 + ; immediate
 579 [endif]
 580
 581
 582 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 583 \ ** O B J E C T
 584 \ Root of all classes
 585 :noname
 586     wordlist
 587     create  immediate
 588     0       ,   \ NULL parent class
 589     dup     ,   \ wid
 590     0       ,   \ instance size
 591 [ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
 592     0       ,   \ .vtCount
 593 [endif]
 594     ficl-set-current
 595     does> meta
 596 ;  execute object
 597 \ now brand OBJECT's wordlist (so that ORDER can display it by name)
 598 object drop cell+ @ brand-wordlist
 599
 600 object drop current-class !
 601 do-do-instance
 602 instance-vars >search
 603
 604 \ O B J E C T   M E T H O D S
 605 \ Convert instance cell-pair to class cell-pair
 606 \ Useful for binding class methods from an instance
 607 : class  ( instance class -- class metaclass )
 608     nip meta ;
 609
 610 \ default INIT method zero fills an instance
 611 : init   ( instance class -- )
 612     meta
 613     metaclass => get-size   ( inst size )
 614     erase ;
 615
 616 \ Apply INIT to an array of NOBJ objects...
 617 \
 618 : array-init   ( nobj inst class -- )
 619     0 dup locals| &init &next class inst |
 620     \
 621     \ bind methods outside the loop to save time
 622     \
 623     class s" init" lookup-method to &init
 624           s" next" lookup-method to &next
 625     drop
 626     0 ?do
 627         inst class 2dup
 628         &init execute
 629         &next execute  drop to inst
 630     loop
 631 ;
 632
 633 \ free storage allocated to a heap instance by alloc or alloc-array
 634 \ NOTE: not protected against errors like FREEing something that's
 635 \ really in the dictionary.
 636 : free   \ ( instance class -- )
 637     drop free
 638     abort" free failed "
 639 ;
 640
 641 \ Instance aliases for common class methods
 642 \ Upcast to parent class
 643 : super     ( instance class -- instance parent-class )
 644     meta  metaclass => get-super ;
 645
 646 : pedigree  ( instance class -- )
 647     object => class
 648     metaclass => pedigree ;
 649
 650 : size      ( instance class -- sizeof-instance )
 651     object => class
 652     metaclass => get-size ;
 653
 654 : methods   ( instance class -- )
 655     object => class
 656     metaclass => methods ;
 657
 658 \ Array indexing methods...
 659 \ Usage examples:
 660 \ 10 object-array --> index
 661 \ obj --> next
 662 \
 663 : index   ( n instance class -- instance[n] class )
 664     locals| class inst |
 665     inst class
 666     object => class
 667     metaclass => get-size  *   ( n*size )
 668     inst +  class ;
 669
 670 : next   ( instance[n] class -- instance[n+1] class )
 671     locals| class inst |
 672     inst class
 673     object => class
 674     metaclass => get-size
 675     inst +
 676     class ;
 677
 678 : prev   ( instance[n] class -- instance[n-1] class )
 679     locals| class inst |
 680     inst class
 681     object => class
 682     metaclass => get-size
 683     inst swap -
 684     class ;
 685
 686 : debug   ( 2this --  ?? )
 687     find-method-xt debug-xt ;
 688
 689 previous set-current
 690 \ E N D   O B J E C T
 691
 692 \ reset to default search order
 693 only definitions
 694
 695 \ redefine oop in default search order to put OOP words in the search order and make them
 696 \ the compiling wordlist...
 697
 698 : oo   only also oop definitions ;
 699
 700 [endif]