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