sys/boot/ficl/softwords/oo.fr

   1 \ ** ficl/softwords/oo.fr
   2 \ ** F I C L   O - O   E X T E N S I O N S
   3 \ ** john sadler aug 1998
   4 \
   5 \ $FreeBSD: src/sys/boot/ficl/softwords/oo.fr,v 1.1.6.1 2000/07/06 23:51:46 obrien Exp $
   6 \ $DragonFly: src/sys/boot/ficl/softwords/oo.fr,v 1.2 2003/06/17 04:28:18 dillon Exp $
   7
   8
   9 .( loading ficl O-O extensions ) cr
  10 7 ficl-vocabulary oop
  11 also oop definitions
  12
  13 \ Design goals:
  14 \ 0. Traditional OOP: late binding by default for safety.
  15 \    Early binding if you ask for it.
  16 \ 1. Single inheritance
  17 \ 2. Object aggregation (has-a relationship)
  18 \ 3. Support objects in the dictionary and as proxies for
  19 \    existing structures (by reference):
  20 \    *** A ficl object can wrap a C struct ***
  21 \ 4. Separate name-spaces for methods - methods are
  22 \    only visible in the context of a class / object
  23 \ 5. Methods can be overridden, and subclasses can add methods.
  24 \    No limit on number of methods.
  25
  26 \ General info:
  27 \ Classes are objects, too: all classes are instances of METACLASS
  28 \ All classes are derived (by convention) from OBJECT. This
  29 \ base class provides a default initializer and superclass
  30 \ access method
  31
  32 \ A ficl object binds instance storage (payload) to a class.
  33 \ object  ( -- instance class )
  34 \ All objects push their payload address and class address when
  35 \ executed. All objects have this footprint:
  36 \ cell 0: first payload cell
  37
  38 \ A ficl class consists of a parent class pointer, a wordlist
  39 \ ID for the methods of the class, and a size for the payload
  40 \ of objects created by the class. A class is an object.
  41 \ The NEW method creates and initializes an instance of a class.
  42 \ Classes have this footprint:
  43 \ cell 0: parent class address
  44 \ cell 1: wordlist ID
  45 \ cell 2: size of instance's payload
  46
  47 \ Methods expect an object couple ( instance class )
  48 \ on the stack.
  49 \ Overridden methods must maintain the same stack signature as
  50 \ their predecessors. Ficl has no way of enforcing this, though.
  51
  52 user current-class
  53 0 current-class !
  54
  55 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  56 \ ** L A T E   B I N D I N G
  57 \ Compile the method name, and code to find and
  58 \ execute it at run-time...
  59 \ parse-method compiles the method name so that it pushes
  60 \ the string base address and count at run-time.
  61 \
  62 : parse-method  \ name  run: ( -- c-addr u )
  63     parse-word
  64         postpone sliteral
  65 ; compile-only
  66
  67 : lookup-method  ( class c-addr u -- class xt )
  68         2dup
  69         local u
  70         local c-addr
  71         end-locals
  72         2 pick cell+ @          ( -- class c-addr u wid )
  73         search-wordlist         ( -- class 0 | xt 1 | xt -1 )
  74         0= if
  75                 c-addr u type ."  not found in "
  76         body> >name type
  77         cr abort
  78         endif
  79 ;
  80
  81 : exec-method  ( instance class c-addr u -- <method-signature> )
  82     lookup-method execute
  83 ;
  84
  85 : find-method-xt   \ name ( class -- class xt )
  86         parse-word lookup-method
  87 ;
  88
  89
  90 \ Method lookup operator takes a class-addr and instance-addr
  91 \ and executes the method from the class's wordlist if
  92 \ interpreting. If compiling, bind late.
  93 \
  94 : -->   ( instance class -- ??? )
  95     state @ 0= if
  96                 find-method-xt execute
  97     else
  98                 parse-method  postpone exec-method
  99     endif
 100 ; immediate
 101
 102
 103 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 104 \ ** E A R L Y   B I N D I N G
 105 \ Early binding operator compiles code to execute a method
 106 \ given its class at compile time. Classes are immediate,
 107 \ so they leave their cell-pair on the stack when compiling.
 108 \ Example:
 109 \   : get-wid   metaclass => .wid @ ;
 110 \ Usage
 111 \   my-class get-wid  ( -- wid-of-my-class )
 112 \
 113 : =>   \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
 114         drop find-method-xt compile, drop
 115 ; immediate compile-only
 116
 117
 118 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 119 \ ** I N S T A N C E   V A R I A B L E S
 120 \ Instance variables (IV) are represented by words in the class's
 121 \ private wordlist. Each IV word contains the offset
 122 \ of the IV it represents, and runs code to add that offset
 123 \ to the base address of an instance when executed.
 124 \ The metaclass SUB method, defined below, leaves the address
 125 \ of the new class's offset field and its initial size on the
 126 \ stack for these words to update. When a class definition is
 127 \ complete, END-CLASS saves the final size in the class's size
 128 \ field, and restores the search order and compile wordlist to
 129 \ prior state. Note that these words are hidden in their own
 130 \ wordlist to prevent accidental use outside a SUB END-CLASS pair.
 131 \
 132 wordlist
 133 dup constant instance-vars
 134 dup >search ficl-set-current
 135 : do-instance-var
 136     does>   ( instance class addr[offset] -- addr[field] )
 137                 nip @ +
 138 ;
 139
 140 : addr-units:  ( offset size "name" -- offset' )
 141     create over , +
 142     do-instance-var
 143 ;
 144
 145 : chars:        \ ( offset nCells "name" -- offset' ) Create n char member.
 146    chars addr-units: ;
 147
 148 : char:         \ ( offset nCells "name" -- offset' ) Create 1 char member.
 149    1 chars: ;
 150
 151 : cells:  ( offset nCells "name" -- offset' )
 152         cells >r aligned r> addr-units:
 153 ;
 154
 155 : cell:   ( offset nCells "name" -- offset' )
 156     1 cells: ;
 157
 158 \ Aggregate an object into the class...
 159 \ Needs the class of the instance to create
 160 \ Example: object obj: m_obj
 161 \
 162 : do-aggregate
 163         does>   ( instance class pfa -- a-instance a-class )
 164         2@          ( inst class a-class a-offset )
 165         2swap drop  ( a-class a-offset inst )
 166         + swap          ( a-inst a-class )
 167 ;
 168
 169 : obj:   ( offset class meta "name" -- offset' )
 170     locals| meta class offset |
 171     create  offset , class ,
 172         class meta --> get-size  offset +
 173         do-aggregate
 174 ;
 175
 176 \ Aggregate an array of objects into a class
 177 \ Usage example:
 178 \ 3 my-class array: my-array
 179 \ Makes an instance variable array of 3 instances of my-class
 180 \ named my-array.
 181 \
 182 : array:   ( offset n class meta "name" -- offset' )
 183         locals| meta class nobjs offset |
 184         create offset , class ,
 185         class meta --> get-size  nobjs * offset +
 186         do-aggregate
 187 ;
 188
 189 \ Aggregate a pointer to an object: REF is a member variable
 190 \ whose class is set at compile time. This is useful for wrapping
 191 \ data structures in C, where there is only a pointer and the type
 192 \ it refers to is known. If you want polymorphism, see c_ref
 193 \ in classes.fr. REF is only useful for pre-initialized structures,
 194 \ since there's no supported way to set one.
 195 : ref:   ( offset class meta "name" -- offset' )
 196         locals| meta class offset |
 197         create offset , class ,
 198         offset cell+
 199         does>    ( inst class pfa -- ptr-inst ptr-class )
 200         2@       ( inst class ptr-class ptr-offset )
 201         2swap drop + @ swap
 202 ;
 203
 204 \ END-CLASS terminates construction of a class by storing
 205 \  the size of its instance variables in the class's size field
 206 \ ( -- old-wid addr[size] 0 )
 207 \
 208 : end-class  ( old-wid addr[size] size -- )
 209     swap ! set-current
 210         search> drop            \ pop struct builder wordlist
 211 ;
 212
 213 set-current previous
 214 \ E N D   I N S T A N C E   V A R I A B L E S
 215
 216
 217 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 218 \ D O - D O - I N S T A N C E
 219 \ Makes a class method that contains the code for an
 220 \ instance of the class. This word gets compiled into
 221 \ the wordlist of every class by the SUB method.
 222 \ PRECONDITION: current-class contains the class address
 223 \ why use a state variable instead of the stack?
 224 \ >> Stack state is not well-defined during compilation (there are
 225 \ >> control structure match codes on the stack, of undefined size
 226 \ >> easiest way around this is use of this thread-local variable
 227 \
 228 : do-do-instance  ( -- )
 229     s" : .do-instance does> [ current-class @ ] literal ;"
 230     evaluate
 231 ;
 232
 233 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 234 \ ** M E T A C L A S S
 235 \ Every class is an instance of metaclass. This lets
 236 \ classes have methods that are different from those
 237 \ of their instances.
 238 \ Classes are IMMEDIATE to make early binding simpler
 239 \ See above...
 240 \
 241 :noname
 242         wordlist
 243         create
 244     immediate
 245         0       ,       \ NULL parent class
 246         dup     ,       \ wid
 247         3 cells ,       \ instance size
 248         ficl-set-current
 249         does> dup
 250 ;  execute metaclass
 251
 252 metaclass drop current-class !
 253 do-do-instance
 254
 255 \
 256 \ C L A S S   M E T H O D S
 257 \
 258 instance-vars >search
 259
 260 create .super  ( class metaclass -- parent-class )
 261     0 cells , do-instance-var
 262
 263 create .wid    ( class metaclass -- wid ) \ return wid of class
 264     1 cells , do-instance-var
 265
 266 create  .size  ( class metaclass -- size ) \ return class's payload size
 267     2 cells , do-instance-var
 268
 269 previous
 270
 271 : get-size    metaclass => .size  @ ;
 272 : get-wid     metaclass => .wid   @ ;
 273 : get-super   metaclass => .super @ ;
 274
 275 \ create an uninitialized instance of a class, leaving
 276 \ the address of the new instance and its class
 277 \
 278 : instance   ( class metaclass "name" -- instance class )
 279     locals| meta parent |
 280         create
 281     here parent --> .do-instance \ ( inst class )
 282     parent meta metaclass => get-size
 283     allot                        \ allocate payload space
 284 ;
 285
 286 \ create an uninitialized array
 287 : array   ( n class metaclass "name" -- n instance class )
 288     locals| meta parent nobj |
 289         create  nobj
 290     here parent --> .do-instance \ ( nobj inst class )
 291     parent meta metaclass => get-size
 292         nobj *  allot                   \ allocate payload space
 293 ;
 294
 295 \ create an initialized instance
 296 \
 297 : new   \ ( class metaclass "name" -- )
 298     metaclass => instance --> init
 299 ;
 300
 301 \ create an initialized array of instances
 302 : new-array   ( n class metaclass "name" -- )
 303         metaclass => array
 304         --> array-init
 305 ;
 306
 307 \ Create an anonymous initialized instance from the heap
 308 : alloc   \ ( class metaclass -- instance class )
 309     locals| meta class |
 310     class meta metaclass => get-size allocate   ( -- addr fail-flag )
 311     abort" allocate failed "                    ( -- addr )
 312     class 2dup --> init
 313 ;
 314
 315 \ Create an anonymous array of initialized instances from the heap
 316 : alloc-array   \ ( n class metaclass -- instance class )
 317     locals| meta class nobj |
 318     class meta metaclass => get-size
 319     nobj * allocate                 ( -- addr fail-flag )
 320     abort" allocate failed "        ( -- addr )
 321     nobj over class --> array-init
 322     class
 323 ;
 324
 325 \ create a proxy object with initialized payload address given
 326 : ref   ( instance-addr class metaclass "name" -- )
 327     drop create , ,
 328     does> 2@
 329 ;
 330
 331 \ create a subclass
 332 : sub   ( class metaclass "name" -- old-wid addr[size] size )
 333     wordlist
 334         locals| wid meta parent |
 335         parent meta metaclass => get-wid
 336         wid wid-set-super
 337         create  immediate
 338         here current-class !    \ prep for do-do-instance
 339         parent ,        \ save parent class
 340         wid    ,        \ save wid
 341         here parent meta --> get-size dup ,  ( addr[size] size )
 342         metaclass => .do-instance
 343         wid ficl-set-current -rot
 344         do-do-instance
 345         instance-vars >search   \ push struct builder wordlist
 346 ;
 347
 348 \ OFFSET-OF returns the offset of an instance variable
 349 \ from the instance base address. If the next token is not
 350 \ the name of in instance variable method, you get garbage
 351 \ results -- there is no way at present to check for this error.
 352 : offset-of   ( class metaclass "name" -- offset )
 353     drop find-method-xt nip >body @ ;
 354
 355 \ ID returns the string name cell-pair of its class
 356 : id   ( class metaclass -- c-addr u )
 357         drop body> >name  ;
 358
 359 \ list methods of the class
 360 : methods \ ( class meta -- )
 361         locals| meta class |
 362         begin
 363                 class body> >name type ."  methods:" cr
 364                 class meta --> get-wid >search words cr previous
 365                 class meta metaclass => get-super
 366                 dup to class
 367         0= until  cr
 368 ;
 369
 370 \ list class's ancestors
 371 : pedigree  ( class meta -- )
 372         locals| meta class |
 373         begin
 374                 class body> >name type space
 375                 class meta metaclass => get-super
 376                 dup to class
 377         0= until  cr
 378 ;
 379
 380 \ decompile a method
 381 : see  ( class meta -- )
 382     metaclass => get-wid >search see previous ;
 383
 384 set-current
 385 \ E N D   M E T A C L A S S
 386
 387 \ META is a nickname for the address of METACLASS...
 388 metaclass drop
 389 constant meta
 390
 391 \ SUBCLASS is a nickname for a class's SUB method...
 392 \ Subclass compilation ends when you invoke end-class
 393 \ This method is late bound for safety...
 394 : subclass   --> sub ;
 395
 396
 397 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 398 \ ** O B J E C T
 399 \ Root of all classes
 400 :noname
 401         wordlist
 402         create  immediate
 403         0       ,       \ NULL parent class
 404         dup     ,       \ wid
 405         0       ,       \ instance size
 406         ficl-set-current
 407         does> meta
 408 ;  execute object
 409
 410 object drop current-class !
 411 do-do-instance
 412
 413 \ O B J E C T   M E T H O D S
 414 \ Convert instance cell-pair to class cell-pair
 415 \ Useful for binding class methods from an instance
 416 : class  ( instance class -- class metaclass )
 417         nip meta ;
 418
 419 \ default INIT method zero fills an instance
 420 : init   ( instance class -- )
 421     meta
 422     metaclass => get-size   ( inst size )
 423     erase ;
 424
 425 \ Apply INIT to an array of NOBJ objects...
 426 \
 427 : array-init   ( nobj inst class -- )
 428         0 dup locals| &init &next class inst |
 429         \
 430         \ bind methods outside the loop to save time
 431         \
 432         class s" init" lookup-method to &init
 433               s" next" lookup-method to &next
 434         drop
 435         0 ?do
 436                 inst class 2dup
 437                 &init execute
 438                 &next execute  drop to inst
 439         loop
 440 ;
 441
 442 \ free storage allocated to a heap instance by alloc or alloc-array
 443 \ NOTE: not protected against errors like FREEing something that's
 444 \ really in the dictionary.
 445 : free   \ ( instance class -- )
 446         drop free
 447         abort" free failed "
 448 ;
 449
 450 \ Instance aliases for common class methods
 451 \ Upcast to parent class
 452 : super     ( instance class -- instance parent-class )
 453     meta  metaclass => get-super ;
 454
 455 : pedigree  ( instance class -- )
 456         object => class
 457     metaclass => pedigree ;
 458
 459 : size      ( instance class -- sizeof-instance )
 460         object => class
 461     metaclass => get-size ;
 462
 463 : methods   ( instance class -- )
 464         object => class
 465     metaclass => methods ;
 466
 467 \ Array indexing methods...
 468 \ Usage examples:
 469 \ 10 object-array --> index
 470 \ obj --> next
 471 \
 472 : index   ( n instance class -- instance[n] class )
 473         locals| class inst |
 474         inst class
 475     object => class
 476         metaclass => get-size  *   ( n*size )
 477         inst +  class ;
 478
 479 : next   ( instance[n] class -- instance[n+1] class )
 480         locals| class inst |
 481         inst class
 482     object => class
 483         metaclass => get-size
 484         inst +
 485         class ;
 486
 487 : prev   ( instance[n] class -- instance[n-1] class )
 488         locals| class inst |
 489         inst class
 490     object => class
 491         metaclass => get-size
 492         inst swap -
 493         class ;
 494
 495 set-current
 496 \ E N D   O B J E C T
 497
 498
 499 previous definitions