sys/boot/ficl/softwords/oo.fr

   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: src/sys/boot/ficl/softwords/oo.fr,v 1.4 2002/04/09 17:45:28 dcs Exp $
   7 \ $DragonFly: src/sys/boot/ficl/softwords/oo.fr,v 1.3 2003/11/10 06:08:34 dillon Exp $
   8
   9 17 ficl-vocabulary oop
  10 also oop definitions
  11
  12 \ Design goals:
  13 \ 0. Traditional OOP: late binding by default for safety.
  14 \    Early binding if you ask for it.
  15 \ 1. Single inheritance
  16 \ 2. Object aggregation (has-a relationship)
  17 \ 3. Support objects in the dictionary and as proxies for
  18 \    existing structures (by reference):
  19 \    *** A ficl object can wrap a C struct ***
  20 \ 4. Separate name-spaces for methods - methods are
  21 \    only visible in the context of a class / object
  22 \ 5. Methods can be overridden, and subclasses can add methods.
  23 \    No limit on number of methods.
  24
  25 \ General info:
  26 \ Classes are objects, too: all classes are instances of METACLASS
  27 \ All classes are derived (by convention) from OBJECT. This
  28 \ base class provides a default initializer and superclass
  29 \ access method
  30
  31 \ A ficl object binds instance storage (payload) to a class.
  32 \ object  ( -- instance class )
  33 \ All objects push their payload address and class address when
  34 \ executed.
  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 )
  46 \ on the stack. This is by convention - ficl has no way to
  47 \ police your code to make sure this is always done, but it
  48 \ happens naturally if you use the facilities presented here.
  49 \
  50 \ Overridden methods must maintain the same stack signature as
  51 \ their predecessors. Ficl has no way of enforcing this, either.
  52 \
  53 \ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
  54 \ has an extra field for the vtable method count. Hasvtable declares
  55 \ refs to vtable classes
  56 \
  57 \ Revised Nov 2001 - metaclass debug method now finds only metaclass methods
  58 \
  59 \ Planned: Ficl vtable support
  60 \ Each class has a vtable size parameter
  61 \ END-CLASS allocates and clears the vtable - then it walks class's method
  62 \ list and inserts all new methods into table. For each method, if the table
  63 \ slot is already nonzero, do nothing (overridden method). Otherwise fill
  64 \ vtable slot. Now do same check for parent class vtable, filling only
  65 \ empty slots in the new vtable.
  66 \ Methods are now structured as follows:
  67 \ - header
  68 \ - vtable index
  69 \ - xt
  70 \ :noname definition for code
  71 \
  72 \ : is redefined to check for override, fill in vtable index, increment method
  73 \ count if not an override, create header and fill in index. Allot code pointer
  74 \ and run :noname
  75 \ ; is overridden to fill in xt returned by :noname
  76 \ --> compiles code to fetch vtable address, offset by index, and execute
  77 \ => looks up xt in the vtable and compiles it directly
  78
  79
  80
  81 user current-class
  82 0 current-class !
  83
  84 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  85 \ ** L A T E   B I N D I N G
  86 \ Compile the method name, and code to find and
  87 \ execute it at run-time...
  88 \
  89
  90 hide
  91
  92 \ p a r s e - m e t h o d
  93 \ compiles a method name so that it pushes
  94 \ the string base address and count at run-time.
  95
  96 : parse-method  \ name  run: ( -- c-addr u )
  97     parse-word
  98     postpone sliteral
  99 ; compile-only
 100
 101 \ l o o k u p - m e t h o d
 102 \ takes a counted string method name from the stack (as compiled
 103 \ by parse-method) and attempts to look this method up in the method list of
 104 \ the class that's on the stack. If successful, it leaves the class on the stack
 105 \ and pushes the xt of the method. If not, it aborts with an error message.
 106
 107 : lookup-method  { class 2:name -- class xt }
 108     name class cell+ @  ( c-addr u wid )
 109     search-wordlist     ( 0 | xt 1 | xt -1 )
 110     0= if
 111         name type ."  not found in "
 112         class body> >name type
 113         cr abort
 114     endif
 115     class swap
 116 ;
 117
 118 : find-method-xt   \ name ( class -- class xt )
 119     parse-word lookup-method
 120 ;
 121
 122 set-current  ( stop hiding definitions )
 123
 124 : catch-method  ( instance class c-addr u -- <method-signature> exc-flag )
 125     lookup-method catch
 126 ;
 127
 128 : exec-method  ( instance class c-addr u -- <method-signature> )
 129     lookup-method execute
 130 ;
 131
 132 \ Method lookup operator takes a class-addr and instance-addr
 133 \ and executes the method from the class's wordlist if
 134 \ interpreting. If compiling, bind late.
 135 \
 136 : -->   ( instance class -- ??? )
 137     state @ 0= if
 138         find-method-xt execute
 139     else
 140         parse-method  postpone exec-method
 141     endif
 142 ; immediate
 143
 144 \ Method lookup with CATCH in case of exceptions
 145 : c->   ( instance class -- ?? exc-flag )
 146     state @ 0= if
 147         find-method-xt catch
 148     else
 149         parse-method  postpone catch-method
 150     endif
 151 ; immediate
 152
 153 \ METHOD  makes global words that do method invocations by late binding
 154 \ in case you prefer this style (no --> in your code)
 155 \ Example: everything has next and prev for array access, so...
 156 \ method next
 157 \ method prev
 158 \ my-instance next ( does whatever next does to my-instance by late binding )
 159
 160 : method   create does> body> >name lookup-method execute ;
 161
 162
 163 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 164 \ ** E A R L Y   B I N D I N G
 165 \ Early binding operator compiles code to execute a method
 166 \ given its class at compile time. Classes are immediate,
 167 \ so they leave their cell-pair on the stack when compiling.
 168 \ Example:
 169 \   : get-wid   metaclass => .wid @ ;
 170 \ Usage
 171 \   my-class get-wid  ( -- wid-of-my-class )
 172 \
 173 1 ficl-named-wordlist instance-vars
 174 instance-vars dup >search ficl-set-current
 175
 176 : =>   \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
 177     drop find-method-xt compile, drop
 178 ; immediate compile-only
 179
 180 : my=>   \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
 181     current-class @ dup postpone =>
 182 ; immediate compile-only
 183
 184 \ Problem: my=[ assumes that each method except the last is am obj: member
 185 \ which contains its class as the first field of its parameter area. The code
 186 \ detects non-obect members and assumes the class does not change in this case.
 187 \ This handles methods like index, prev, and next correctly, but does not deal
 188 \ correctly with CLASS.
 189 : my=[   \ same as my=> , but binds a chain of methods
 190     current-class @
 191     begin
 192         parse-word 2dup             ( class c-addr u c-addr u )
 193         s" ]" compare while         ( class c-addr u )
 194         lookup-method               ( class xt )
 195         dup compile,                ( class xt )
 196         dup ?object if        \ If object member, get new class. Otherwise assume same class
 197            nip >body cell+ @        ( new-class )
 198         else
 199            drop                     ( class )
 200         endif
 201     repeat 2drop drop
 202 ; immediate compile-only
 203
 204
 205 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 206 \ ** I N S T A N C E   V A R I A B L E S
 207 \ Instance variables (IV) are represented by words in the class's
 208 \ private wordlist. Each IV word contains the offset
 209 \ of the IV it represents, and runs code to add that offset
 210 \ to the base address of an instance when executed.
 211 \ The metaclass SUB method, defined below, leaves the address
 212 \ of the new class's offset field and its initial size on the
 213 \ stack for these words to update. When a class definition is
 214 \ complete, END-CLASS saves the final size in the class's size
 215 \ field, and restores the search order and compile wordlist to
 216 \ prior state. Note that these words are hidden in their own
 217 \ wordlist to prevent accidental use outside a SUB END-CLASS pair.
 218 \
 219 : do-instance-var
 220     does>   ( instance class addr[offset] -- addr[field] )
 221         nip @ +
 222 ;
 223
 224 : addr-units:  ( offset size "name" -- offset' )
 225     create over , +
 226     do-instance-var
 227 ;
 228
 229 : chars:    \ ( offset nCells "name" -- offset' ) Create n char member.
 230    chars addr-units: ;
 231
 232 : char:     \ ( offset nCells "name" -- offset' ) Create 1 char member.
 233    1 chars: ;
 234
 235 : cells:  ( offset nCells "name" -- offset' )
 236     cells >r aligned r> addr-units:
 237 ;
 238
 239 : cell:   ( offset nCells "name" -- offset' )
 240     1 cells: ;
 241
 242 \ Aggregate an object into the class...
 243 \ Needs the class of the instance to create
 244 \ Example: object obj: m_obj
 245 \
 246 : do-aggregate
 247     objectify
 248     does>   ( instance class pfa -- a-instance a-class )
 249     2@          ( inst class a-class a-offset )
 250     2swap drop  ( a-class a-offset inst )
 251     + swap      ( a-inst a-class )
 252 ;
 253
 254 : obj:   { offset class meta -- offset' }  \ "name"
 255     create  offset , class ,
 256     class meta --> get-size  offset +
 257     do-aggregate
 258 ;
 259
 260 \ Aggregate an array of objects into a class
 261 \ Usage example:
 262 \ 3 my-class array: my-array
 263 \ Makes an instance variable array of 3 instances of my-class
 264 \ named my-array.
 265 \
 266 : array:   ( offset n class meta "name" -- offset' )
 267     locals| meta class nobjs offset |
 268     create offset , class ,
 269     class meta --> get-size  nobjs * offset +
 270     do-aggregate
 271 ;
 272
 273 \ Aggregate a pointer to an object: REF is a member variable
 274 \ whose class is set at compile time. This is useful for wrapping
 275 \ data structures in C, where there is only a pointer and the type
 276 \ it refers to is known. If you want polymorphism, see c_ref
 277 \ in classes.fr. REF is only useful for pre-initialized structures,
 278 \ since there's no supported way to set one.
 279 : ref:   ( offset class meta "name" -- offset' )
 280     locals| meta class offset |
 281     create offset , class ,
 282     offset cell+
 283     does>    ( inst class pfa -- ptr-inst ptr-class )
 284     2@       ( inst class ptr-class ptr-offset )
 285     2swap drop + @ swap
 286 ;
 287
 288 \ #if FICL_WANT_VCALL
 289 \ vcall extensions contributed by Guy Carver
 290 : vcall:  ( paramcnt "name" -- )
 291     current-class @ 8 + dup @ dup 1+ rot !  \ Kludge fix to get to .vtCount before it's defined.
 292     create , ,                              \ ( paramcnt index -- )
 293     does>                                   \ ( inst class pfa -- ptr-inst ptr-class )
 294    nip 2@ vcall                             \ ( params offset inst class offset -- )
 295 ;
 296
 297 : vcallr: 0x80000000 or vcall: ;            \ Call with return address desired.
 298
 299 \ #if FICL_WANT_FLOAT
 300 : vcallf:                                   \ ( paramcnt -<name>- f: r )
 301     0x80000000 or
 302     current-class @ 8 + dup @ dup 1+ rot !  \ Kludge fix to get to .vtCount before it's defined.
 303     create , ,                              \ ( paramcnt index -- )
 304     does>                                   \ ( inst class pfa -- ptr-inst ptr-class )
 305     nip 2@ vcall f>                         \ ( params offset inst class offset -- f: r )
 306 ;
 307 \ #endif /* FLOAT */
 308 \ #endif /* 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 \ #if FICL_WANT_VCALL
 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 \ #if FICL_WANT_VCALL
 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 \ #else
 390 create  .size  ( class metaclass -- size ) \ return class's payload size
 391     2 cells , do-instance-var
 392 \ #endif
 393
 394 : get-size    metaclass => .size  @ ;
 395 : get-wid     metaclass => .wid   @ ;
 396 : get-super   metaclass => .super @ ;
 397 \ #if FICL_WANT_VCALL
 398 : get-vtCount metaclass => .vtCount @ ;
 399 : get-vtAdd   metaclass => .vtCount ;
 400 \ #endif
 401
 402 \ create an uninitialized instance of a class, leaving
 403 \ the address of the new instance and its class
 404 \
 405 : instance   ( class metaclass "name" -- instance class )
 406     locals| meta parent |
 407     create
 408     here parent --> .do-instance \ ( inst class )
 409     parent meta metaclass => get-size
 410     allot                        \ allocate payload space
 411 ;
 412
 413 \ create an uninitialized array
 414 : array   ( n class metaclass "name" -- n instance class )
 415     locals| meta parent nobj |
 416     create  nobj
 417     here parent --> .do-instance \ ( nobj inst class )
 418     parent meta metaclass => get-size
 419     nobj *  allot           \ allocate payload space
 420 ;
 421
 422 \ create an initialized instance
 423 \
 424 : new   \ ( class metaclass "name" -- )
 425     metaclass => instance --> init
 426 ;
 427
 428 \ create an initialized array of instances
 429 : new-array   ( n class metaclass "name" -- )
 430     metaclass => array
 431     --> array-init
 432 ;
 433
 434 \ Create an anonymous initialized instance from the heap
 435 : alloc   \ ( class metaclass -- instance class )
 436     locals| meta class |
 437     class meta metaclass => get-size allocate   ( -- addr fail-flag )
 438     abort" allocate failed "                    ( -- addr )
 439     class 2dup --> init
 440 ;
 441
 442 \ Create an anonymous array of initialized instances from the heap
 443 : alloc-array   \ ( n class metaclass -- instance class )
 444     locals| meta class nobj |
 445     class meta metaclass => get-size
 446     nobj * allocate                 ( -- addr fail-flag )
 447     abort" allocate failed "        ( -- addr )
 448     nobj over class --> array-init
 449     class
 450 ;
 451
 452 \ Create an anonymous initialized instance from the dictionary
 453 : allot   { 2:this -- 2:instance }
 454     here   ( instance-address )
 455     this my=> get-size  allot
 456     this drop 2dup --> init
 457 ;
 458
 459 \ Create an anonymous array of initialized instances from the dictionary
 460 : allot-array   { nobj 2:this -- 2:instance }
 461     here   ( instance-address )
 462     this my=> get-size  nobj * allot
 463     this drop 2dup     ( 2instance 2instance )
 464     nobj -rot --> array-init
 465 ;
 466
 467 \ create a proxy object with initialized payload address given
 468 : ref   ( instance-addr class metaclass "name" -- )
 469     drop create , ,
 470     does> 2@
 471 ;
 472
 473 \ suspend-class and resume-class help to build mutually referent classes.
 474 \ Example:
 475 \ object subclass c-akbar
 476 \ suspend-class   ( put akbar on hold while we define jeff )
 477 \ object subclass c-jeff
 478 \     c-akbar ref: .akbar
 479 \     ( and whatever else comprises this class )
 480 \ end-class    ( done with c-jeff )
 481 \ c-akbar --> resume-class
 482 \     c-jeff ref: .jeff
 483 \     ( and whatever else goes in c-akbar )
 484 \ end-class    ( done with c-akbar )
 485 \
 486 : resume-class   { 2:this -- old-wid addr[size] size }
 487     this --> .wid @ ficl-set-current  ( old-wid )
 488     this --> .size dup @   ( old-wid addr[size] size )
 489     instance-vars >search
 490 ;
 491
 492 \ create a subclass
 493 \ This method leaves the stack and search order ready for instance variable
 494 \ building. Pushes the instance-vars wordlist onto the search order,
 495 \ and sets the compilation wordlist to be the private wordlist of the
 496 \ new class. The class's wordlist is deliberately NOT in the search order -
 497 \ to prevent methods from getting used with wrong data.
 498 \ Postcondition: leaves the address of the new class in current-class
 499 : sub   ( class metaclass "name" -- old-wid addr[size] size )
 500     wordlist
 501     locals| wid meta parent |
 502     parent meta metaclass => get-wid
 503     wid wid-set-super       \ set superclass
 504     create  immediate       \ get the  subclass name
 505     wid brand-wordlist      \ label the subclass wordlist
 506     here current-class !    \ prep for do-do-instance
 507     parent ,                \ save parent class
 508     wid    ,                \ save wid
 509 \ #if FICL_WANT_VCALL
 510     parent meta --> get-vtCount ,
 511 \ #endif
 512     here parent meta --> get-size dup ,  ( addr[size] size )
 513     metaclass => .do-instance
 514     wid ficl-set-current -rot
 515     do-do-instance
 516     instance-vars >search \ push struct builder wordlist
 517 ;
 518
 519 \ OFFSET-OF returns the offset of an instance variable
 520 \ from the instance base address. If the next token is not
 521 \ the name of in instance variable method, you get garbage
 522 \ results -- there is no way at present to check for this error.
 523 : offset-of   ( class metaclass "name" -- offset )
 524     drop find-method-xt nip >body @ ;
 525
 526 \ ID returns the string name cell-pair of its class
 527 : id   ( class metaclass -- c-addr u )
 528     drop body> >name  ;
 529
 530 \ list methods of the class
 531 : methods \ ( class meta -- )
 532     locals| meta class |
 533     begin
 534         class body> >name type ."  methods:" cr
 535         class meta --> get-wid >search words cr previous
 536         class meta metaclass => get-super
 537         dup to class
 538     0= until  cr
 539 ;
 540
 541 \ list class's ancestors
 542 : pedigree  ( class meta -- )
 543     locals| meta class |
 544     begin
 545         class body> >name type space
 546         class meta metaclass => get-super
 547         dup to class
 548     0= until  cr
 549 ;
 550
 551 \ decompile an instance method
 552 : see  ( class meta -- )
 553     metaclass => get-wid >search see previous ;
 554
 555 \ debug a method of metaclass
 556 \ Eg: my-class --> debug my-method
 557 : debug  ( class meta -- )
 558         find-method-xt debug-xt ;
 559
 560 previous set-current
 561 \ E N D   M E T A C L A S S
 562
 563 \ ** META is a nickname for the address of METACLASS...
 564 metaclass drop
 565 constant meta
 566
 567 \ ** SUBCLASS is a nickname for a class's SUB method...
 568 \ Subclass compilation ends when you invoke end-class
 569 \ This method is late bound for safety...
 570 : subclass   --> sub ;
 571
 572 \ #if FICL_WANT_VCALL
 573 \ VTABLE Support extensions (Guy Carver)
 574 \ object --> sub mine hasvtable
 575 : hasvtable 4 + ; immediate
 576 \ #endif
 577
 578
 579 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 580 \ ** O B J E C T
 581 \ Root of all classes
 582 :noname
 583     wordlist
 584     create  immediate
 585     0       ,   \ NULL parent class
 586     dup     ,   \ wid
 587     0       ,   \ instance size
 588     ficl-set-current
 589     does> meta
 590 ;  execute object
 591 \ now brand OBJECT's wordlist (so that ORDER can display it by name)
 592 object drop cell+ @ brand-wordlist
 593
 594 object drop current-class !
 595 do-do-instance
 596 instance-vars >search
 597
 598 \ O B J E C T   M E T H O D S
 599 \ Convert instance cell-pair to class cell-pair
 600 \ Useful for binding class methods from an instance
 601 : class  ( instance class -- class metaclass )
 602     nip meta ;
 603
 604 \ default INIT method zero fills an instance
 605 : init   ( instance class -- )
 606     meta
 607     metaclass => get-size   ( inst size )
 608     erase ;
 609
 610 \ Apply INIT to an array of NOBJ objects...
 611 \
 612 : array-init   ( nobj inst class -- )
 613     0 dup locals| &init &next class inst |
 614     \
 615     \ bind methods outside the loop to save time
 616     \
 617     class s" init" lookup-method to &init
 618           s" next" lookup-method to &next
 619     drop
 620     0 ?do
 621         inst class 2dup
 622         &init execute
 623         &next execute  drop to inst
 624     loop
 625 ;
 626
 627 \ free storage allocated to a heap instance by alloc or alloc-array
 628 \ NOTE: not protected against errors like FREEing something that's
 629 \ really in the dictionary.
 630 : free   \ ( instance class -- )
 631     drop free
 632     abort" free failed "
 633 ;
 634
 635 \ Instance aliases for common class methods
 636 \ Upcast to parent class
 637 : super     ( instance class -- instance parent-class )
 638     meta  metaclass => get-super ;
 639
 640 : pedigree  ( instance class -- )
 641     object => class
 642     metaclass => pedigree ;
 643
 644 : size      ( instance class -- sizeof-instance )
 645     object => class
 646     metaclass => get-size ;
 647
 648 : methods   ( instance class -- )
 649     object => class
 650     metaclass => methods ;
 651
 652 \ Array indexing methods...
 653 \ Usage examples:
 654 \ 10 object-array --> index
 655 \ obj --> next
 656 \
 657 : index   ( n instance class -- instance[n] class )
 658     locals| class inst |
 659     inst class
 660     object => class
 661     metaclass => get-size  *   ( n*size )
 662     inst +  class ;
 663
 664 : next   ( instance[n] class -- instance[n+1] class )
 665     locals| class inst |
 666     inst class
 667     object => class
 668     metaclass => get-size
 669     inst +
 670     class ;
 671
 672 : prev   ( instance[n] class -- instance[n-1] class )
 673     locals| class inst |
 674     inst class
 675     object => class
 676     metaclass => get-size
 677     inst swap -
 678     class ;
 679
 680 : debug   ( 2this --  ?? )
 681     find-method-xt debug-xt ;
 682
 683 previous set-current
 684 \ E N D   O B J E C T
 685
 686 \ reset to default search order
 687 only definitions
 688
 689 \ redefine oop in default search order to put OOP words in the search order and make them
 690 \ the compiling wordlist...
 691
 692 : oo   only also oop definitions ;
 693
 694 \ #endif