urflibs/uroof.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; slightly more complicated OO system than mini-oof
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10
  11 (*
  12   each class has inheritance table (16 items; more than enough).
  13   tbl[level] points to self.
  14   maximum number of methods is 128.
  15
  16   internal class layout:
  17     typeid-class   (signature)
  18     instance-size  (bytes)
  19     level          (inheritance level)
  20     class-word-pfa (created class word)
  21     vocid          (class vocid)
  22     <inheritance-table>
  23     <vmt-table>
  24
  25   VMT layout:
  26     method-count (number of methods in VMT)
  27     method-cfas
  28
  29   internal object layout:
  30     typeid-instance (signature)
  31     class-info-addr (pointer to class info above)
  32
  33   class vocabulary contains all class variables and methods.
  34
  35   class word pfa contains:
  36     typeid-class-word (signature)
  37     info-addr         (address of class info table)
  38
  39   field word pfa contains:
  40     typeid-field-word (signature)
  41     info-addr         (address of class info table)
  42     offset            (field offset in instance, in bytes)
  43
  44   method word pfa contains:
  45     typeid-method-word (signature)
  46     info-addr          (address of class info table)
  47     offset             (method offset in VMT, in bytes)
  48
  49   usage:
  50     oof:class: MyClass [ extends: OtherClass ]
  51       field: fld
  52       method: mth
  53     end-class [ MyClass ]
  54
  55     MyClass oof:method: ... ;
  56
  57     field/method read inside a method: simply using the name.
  58     field write inside a method: "TO name"
  59     field address inside a method: "-> name"
  60
  61     special predefined fields:
  62       @class -- get info-addr
  63
  64     call inherited methods (inside a method, of course):
  65       inherited -- with the same name
  66
  67     special fields inside a method:
  68       self -- pointer to instance or to a class info
  69
  70     checks:
  71       cls-or-inst cls-or-inst oof:isa?
  72         check if the first arg is a second or its subclass
  73       cls-or-inst oof:invoke-dyn <mtname>
  74         invoke method
  75       cls-or-inst addr count oof:invoke-str
  76
  77     special object values:
  78       classname oof:obj-value <name> -- immediate
  79       <name> method
  80     using such values performs type checking on assignment, and
  81     method calling is much faster (dispatched by index, not by name string).
  82     to get the contents (including 0, which is NULL), use: "oof:value-of: <name>".
  83     to get the bound class, use: "oof:class-of: <name>".
  84     to rebind to the new class, use: "<class> oof:bind: <name>". note that
  85     rebinding will fail with fatal error if the value already bound.
  86
  87     obj-value fields:
  88       classname obj-value: <field>
  89     here we have one problem: defining a reference to the class which is
  90     not defined yet. it is done by using "0" instead of class name, and
  91     later bind it with:
  92       bind-class classname oof:bind-field: <field>
  93 *)
  94
  95 vocabulary oof
  96 also-defs: oof
  97
  98  16 constant max-inheritance-level
  99 128 constant max-vmt-methods
 100
 101 vocabulary oof-internal
 102 also-defs: oof-internal
 103
 104 ;; various typeids
 105 666_666 enum-from{
 106   def: typeid-class           ;; first cell of class definition holds this
 107   def: typeid-instance        ;; first cell of instance holds this
 108   def: typeid-class-word      ;; first pfa cell of class name word holds this
 109   def: typeid-field-word      ;; first pfa cell of class field word holds this
 110   def: typeid-method-word     ;; first pfa cell of class method word holds this
 111   def: typeid-objfield-word   ;; first pfa cell of class obj-value field word holds this
 112   def: typeid-@class-word     ;; first pfa cell of class @class word holds this
 113   def: typeid-objval-word     ;; first pfa cell of oof:obj-value word holds this
 114 }
 115
 116 ;; field or objval-field?
 117 : field-typeid?  ( typeid -- bool )
 118   dup typeid-field-word = swap typeid-objfield-word = or
 119 ;
 120
 121 ;; are we defining class method? (holds info-addr)
 122 0 value curr-method-def-class
 123 0 value curr-method-def-vmtofs
 124 0 value current-class-def
 125
 126
 127 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128 ;; create class info accessor words
 129 ;;
 130
 131 define-accessors class
 132   def: typeid
 133   def: inst-size
 134   def: level
 135   def: def-pfa
 136   def: vocid
 137 end-accessors
 138
 139 : class->iht  ( info-addr -- iht-addr )  class-size + ;
 140 : class->vmt  ( info-addr -- vmt-addr )
 141   [ class-size max-inheritance-level +cells ] imm-literal +
 142 ;
 143
 144 : class->name@  ( class -- addr count )  class->def-pfa@ pfa->nfa id-count ;
 145
 146 : inst->class  ( instance -- info-addr-addr )  cell+ ;
 147 : inst->class@ ( instance -- info-addr )  inst->class @ ;
 148 : inst->class! ( info-addr instance -- )  inst->class ! ;
 149
 150 2 cells constant initial-inst-size
 151
 152 ;; field/method word offsets
 153 define-accessors fword
 154   def: typeid
 155   def: info-addr
 156   def: ofs
 157   def: doer-cfa
 158   def: objval-info-addr
 159 end-accessors
 160
 161 ;; for obj-values
 162 alias-for fword->ofs is fword->value
 163
 164
 165 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 166 ;; class info creation
 167 ;;
 168
 169 : ?class-info  ( info-addr -- info-addr )
 170   dup " class id expected" ?not-error
 171   dup class->typeid@ typeid-class <> " class id expected" ?error
 172 ;
 173
 174 : ?inst-addr  ( addr -- addr )
 175   dup " object expected" ?not-error
 176   dup @ typeid-instance <> " object expected" ?error
 177 ;
 178
 179 : ?in-class-def  ( -- )
 180   current-class-def " not defining a class" ?not-error
 181 ;
 182
 183 ;; convert instance or class-info address to class-info address
 184 : (inst->info-addr)  ( instance/info -- info-addr )
 185   dup @ dup typeid-instance = if drop inst->class@ dup @ endif
 186   typeid-class <> " not instance/class" ?error
 187 ;
 188
 189 ;; create new class info record
 190 : create-class-info  ( vocid -- info-addr )
 191  $IF 0
 192   ;; create in dictionary
 193   here swap  ( info-addr vocid )
 194   ;; create the header struct
 195   typeid-class ,      ;; signature
 196   initial-inst-size , ;; initial instance size
 197   0 ,                 ;; inheritance level
 198   0 ,                 ;; def-pfa
 199   ,                   ;; vocid
 200   ;; create inheritance table
 201   dup , max-inheritance-level 1- for 0 , endfor
 202   ;; create VMT
 203   0 , max-vmt-methods 1- for ['] (notimpl) , endfor
 204  $ELSE
 205   ;; create in dynamic memory
 206   class-size max-inheritance-level max-vmt-methods + cells + over handle:new-alloc
 207   swap  ( info-addr vocid )
 208   a>r over >a
 209   ;; create the header struct
 210   typeid-class !+4>a      ;; signature
 211   initial-inst-size !+4>a ;; initial instance size
 212   0 !+4>a                 ;; inheritance level
 213   0 !+4>a                 ;; def-pfa
 214   !+4>a                   ;; vocid
 215   ;; create inheritance table
 216   dup !+4>a max-inheritance-level 1- for 0 !+4>a endfor
 217   ;; create VMT
 218   0 !+4>a max-vmt-methods 1- for ['] (notimpl) !+4>a endfor
 219   r>a
 220  $ENDIF
 221 ;
 222
 223 : class-link-wordlist-to-parent  ( my-info-addr -- )
 224   dup class->level@ " bad inherit-from call" ?not-error  ;; "my" should not be at level 0
 225   dup class->vocid@  ( my myvocid )
 226   over class->level@ 1-  ( my myvocid parent-level )
 227   cells rot class->iht + @  ( myvocid inh-ofs parent-info-addr )
 228   class->vocid@  ( myvocid parentvocid )
 229   swap (vocid-parent!)
 230 ;
 231
 232 ;; use only on newly created classes
 233 ;; make "my" subclass of "super"
 234 : class-inherit-from  ( super-info-addr my-info-addr -- )
 235   dup class->level@ " bad inherit-from call" ?error  ;; "my" should be at level 0
 236   ;; check instance size
 237   dup class->inst-size@ initial-inst-size <> " cannot inherit to non-empty class" ?error
 238   ;; copy instance size
 239   over class->inst-size@ over class->inst-size!
 240   >r  ( super-info-addr | my-info-addr )
 241   ;; check maximum inheritance level
 242   dup class->level@ 1+ max-inheritance-level = " inheritance level too deep" ?error
 243   ;; copy tables (they're all consecutive, use this fact)
 244   dup  class->iht  r@ class->iht
 245   max-inheritance-level max-vmt-methods + cmove-cells
 246   ;; now fix inheritance level
 247   class->level@ 1+ dup r@ class->level!  ( level | my )
 248   ;; and put ourself into inheritance table
 249   cells r@ class->iht + r@ swap!
 250   r> class-link-wordlist-to-parent
 251 ;
 252
 253
 254 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 255 ;; field accessor words
 256 ;;
 257
 258 : (isa?)  ( my-instance/info other-instance/info -- my-isa-other? )
 259   (inst->info-addr) swap (inst->info-addr) swap
 260   ;; easy check: our inheritance table should have other-info-addr at its level
 261   ( my other )
 262   dup class->level@  ( my other other-level )
 263   cells rot class->iht + @ =
 264 ;
 265
 266 : (find-field-word)  ( addr count info-addr -- pfa )
 267   ?class-info  ( addr count info-addr )
 268   >r 2dup r>  ( addr count addr count info-addr )
 269   class->vocid@ find-word-in-voc-and-parents ifnot ( addr count )
 270     endcr space xtype ." ? -- method/field not found" cr " method/field not found" error
 271   else ( addr count cfa ) nrot 2drop
 272   endif
 273   cfa->pfa
 274 ;
 275
 276 : (find-method-vmtofs)  ( addr count info-addr -- vmtofs )
 277   (find-field-word)
 278   dup fword->typeid @ typeid-method-word <> " trying to invoke non-method" ?error
 279   fword->ofs @
 280 ;
 281
 282 : (find-method)  ( addr count info-addr -- cfa )
 283   dup >r (find-method-vmtofs)
 284   r> class->vmt + @  ( cfa )
 285 ;
 286
 287 : (vmt-call)  ( inst-addr vmtofs -- )
 288   over " trying to use NULL object" ?not-error
 289   over inst->class@ class->vmt + @  ( inst-addr method-cfa )
 290   (self@) >r swap (self!) execute r> (self!)
 291 ;
 292
 293 : (field-read)  ( inst-addr instofs -- )
 294   over " trying to use NULL object" ?not-error
 295   + @
 296 ;
 297
 298 : (obj-value-!)  ( value pfa+4 -- )
 299   over if
 300     over @ typeid-instance <> " trying to assign non-object" ?error
 301     2dup @ (isa?) " invalid assignment (type)" ?not-error
 302     cell+ !
 303   else  ;; 0 is always allowed
 304     cell+ 0! drop
 305   endif
 306 ;
 307
 308 : (self@+)  ( ofs -- @self+ofs )  (self@) + ;
 309
 310 ;; accessor for "->field"
 311 : (field-acc-addr)  ( pfa -- addr )
 312   ;; (self@) ofs +
 313   fword->ofs @ literal  compile (self@+)
 314 ;
 315
 316 ;; accessor for "field"
 317 : (field-acc-@)  ( pfa -- value )
 318   ;; (self@) ofs + @
 319   (field-acc-addr) compile @
 320 ;
 321
 322 ;; accessor for "field!"
 323 : (field-acc-!)  ( value pfa -- )
 324   ;; (self@) ofs + !
 325   (field-acc-addr) compile !
 326 ;
 327
 328 ;; accessor for obj-value "field"
 329 : (objval-acc-run)  ( pfa -- )  \ name
 330   ;; first check if it is bound
 331   dup fword->objval-info-addr @ dup " obj-value field is not bound to anything" ?not-error
 332   >r  ( pfa | info-addr )
 333   parse-name dup " method name expected" ?not-error
 334   ( pfa addr count | info-addr )
 335   r> (find-field-word)  ( pfa word-pfa )
 336   ;; check type
 337   dup fword->typeid @  ( pfa word-pfa typeid )
 338   dup typeid-method-word <> over field-typeid? not and " trying to access something wrong" ?error
 339   ( pfa word-pfa typeid )
 340   swap fword->ofs @ rot   ( typeid ofs pfa )
 341   (field-acc-@) literal ( typeid )
 342   typeid-method-word = if compile (vmt-call) else compile (field-read) endif
 343 ;
 344
 345 ;; this is what compiled to the method body
 346 : (objval-do-!)  ( value info-addr inst-ofs -- )
 347   >r over if 2dup (isa?) " invalid type for obj-value field" ?not-error endif drop
 348   r> (self@) + !
 349 ;
 350
 351 ;; accessor for obj-value "field!"
 352 : (objval-acc-!)  ( pfa -- )
 353   ;; first check if it is bound
 354   dup fword->objval-info-addr @ dup " obj-value field is not bound to anything" ?not-error ( pfa info-addr )
 355   literal fword->ofs @ literal compile (objval-do-!)
 356 ;
 357
 358 : create-field-accessor  ( addr count doer-cfa -- )
 359   ;; field word layout:
 360   ;;   typeid-field-word (signature)
 361   ;;   info-addr         (address of owner class info table)
 362   ;;   ofs               (offset in the instance)
 363   ;;   doer-cfa          (compile this doer if not 0)
 364   nrot (create) immediate
 365   typeid-field-word ,  ;; signature
 366   current-class-def ,  ;; info-addr
 367   current-class-def class->inst-size@ ,  ;; offset
 368   ,                    ;; doer-cfa
 369  does>  ( pfa )
 370   compiler:?comp
 371   curr-method-def-class " not in method definition" ?not-error
 372   dup fword->doer-cfa @execute-tail
 373 ;
 374
 375 : (finish-objval-field-accessor)  ( info-addr -- )
 376   ,   ;; compile bound class to field word
 377   typeid-objfield-word latest-pfa fword->typeid !  ;; patch word type
 378 ;
 379
 380 : bump-inst-size  ( delta -- )
 381   current-class-def class->inst-size@ +
 382   current-class-def class->inst-size!
 383 ;
 384
 385 : (self-@class)  ( -- info-addr )  (self@) inst->class@ ;
 386 : (self-vmtidx@)  ( idx -- cfa ) (self-@class) class->vmt + @ ;
 387
 388 ;; call inherited method for "self"
 389 : (self-call-inh-vmtofs)  ( vmtofs -- ... )
 390   (self-@class) dup class->level@ 1- dup 0< " inherited without parent" ?error
 391   ( vmtofs info-addr level-1 )
 392   cells swap class->iht + @  ( vmtofs parent-info-addr )
 393   class->vmt + @execute-tail
 394 ;
 395
 396 : create-method  ( addr count -- )
 397   ;; method word layout:
 398   ;;   typeid-method-word (signature)
 399   ;;   info-addr          (address of owner class info table)
 400   ;;   ofs                (offset in VMT, in bytes)
 401   ;; fix method counter first, and use as offset in VMT later
 402   current-class-def class->vmt 1+!
 403   (create) immediate
 404   typeid-method-word ,  ;; signature
 405   current-class-def ,   ;; info-addr
 406   current-class-def class->vmt @ cells ,  ;; offset
 407  does>  ( pfa )
 408   compiler:?comp
 409   curr-method-def-class " not in method definition" ?not-error
 410   ;; no need to compile any checks, "self" should be valid here
 411   fword->ofs @ literal compile (self-vmtidx@) compile execute
 412 ;
 413
 414 ;; save some state on rstack, and setup new
 415 : start-class-compiling  ( -- )
 416   r>
 417   current @ >r  ;; save old CURRENT
 418   forth:(new-word-flags) @ dup >r  ;; save old flags
 419   compiler:word-redefine-warn-mode @ >r
 420   compiler:(wflag-protected) or forth:(new-word-flags) !
 421   current-class-def class->vocid@ current !
 422   compiler:(redefine-warn-parents) compiler:word-redefine-warn-mode !
 423   >r
 424 ;
 425
 426 ;; restore some state from rstack
 427 : finish-class-compiling  ( -- )
 428   r>
 429   r> compiler:word-redefine-warn-mode !
 430   r> forth:(new-word-flags) !
 431   r> current !
 432   >r
 433 ;
 434
 435 : create-@class-accessor ( -- )
 436   " @class" (create) immediate
 437   typeid-@class-word , ;; signature
 438   current-class-def ,  ;; info-addr
 439  does>  ( pfa )
 440   compiler:?comp
 441   curr-method-def-class " not in method definition" ?not-error
 442   drop compile (self-@class)
 443 ;
 444
 445 ;; invoke method by name
 446 : (invoke-str)  ( inst-addr addr count -- ... )
 447   rot ?inst-addr  dup >r inst->class@ (find-method)  ( cfa | inst-addr )
 448   (self@) r> (self!) >r execute r> (self!)
 449 ;
 450
 451 : (obj-value-rebind)  ( info-addr pfa -- )
 452   dup fword->value @ " cannot rebind non-empty obj-value" ?error
 453   dup fword->info-addr @ " cannot rebind already bound obj-value" ?error
 454   fword->info-addr !
 455 ;
 456
 457 ;; with class binding
 458 : (class-invoke) ( inst-addr vmtofs info-addr -- )
 459   ?class-info rot ?inst-addr  ( vmtofs info-addr inst-addr )
 460   dup >r swap (isa?) " invalid object type" ?not-error  ( vmtofs | inst-addr )
 461   r@ inst->class@ class->vmt + @  ( cfa | inst-addr )
 462   (self@) r> (self!) >r execute r> (self!)
 463 ;
 464
 465 ;; with class binding
 466 : (field-invoke) ( inst-addr instofs info-addr -- )
 467   ?class-info rot ?inst-addr  ( instofs info-addr inst-addr )
 468   dup >r swap (isa?) " invalid object type" ?not-error  ( instofs | inst-addr )
 469   r> + @
 470 ;
 471
 472 : (clx-invoke)  ( inst-addr ofs info-addr invoker-cfa )
 473   compiler:comp? if rot literal swap literal compile,
 474   else execute-tail
 475   endif
 476 ;
 477
 478
 479 ;; "TO" for obj-values
 480 ..: FORTH:(TO-EXTENDER-FOUND)  ( cfa FALSE -- cfa FALSE / TRUE )
 481   ?dup ifnot
 482     dup cfa->pfa fword->typeid @ typeid-objval-word = if
 483       cfa->pfa cell+
 484       compiler:comp? if literal compile (obj-value-!)
 485       else (obj-value-!)
 486       endif
 487       true
 488     else false
 489     endif
 490   endif
 491 ;.. (hidden)
 492
 493 ;; "TO" for simple fields
 494 ..: FORTH:(TO-EXTENDER-FOUND)  ( cfa FALSE -- cfa FALSE / TRUE )
 495   ?dup ifnot
 496     dup cfa->pfa fword->typeid @ typeid-field-word = if
 497       compiler:?comp
 498       curr-method-def-class " not in method definition" ?not-error
 499       cfa->pfa (field-acc-!)
 500       true
 501     else false
 502     endif
 503   endif
 504 ;.. (hidden)
 505
 506 ;; "TO" for obj-value fields
 507 ..: FORTH:(TO-EXTENDER-FOUND)  ( cfa FALSE -- cfa FALSE / TRUE )
 508   ?dup ifnot
 509     dup cfa->pfa fword->typeid @ typeid-objfield-word = if
 510       compiler:?comp
 511       curr-method-def-class " not in method definition" ?not-error
 512       cfa->pfa (objval-acc-!)
 513       true
 514     else false
 515     endif
 516   endif
 517 ;.. (hidden)
 518
 519
 520 prev-defs  ;; at OOF
 521 also oof-internal
 522
 523
 524 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 525 ;; vocabulary used in class definition
 526 ;;
 527
 528 simple-vocabulary oof-creatori
 529 also-defs: oof-creatori
 530
 531 ;; finish class definition
 532 : end-class  ( -- )
 533   ?in-class-def
 534   ;; if we are at 0th level, create "self" word
 535   current-class-def class->level@ ifnot
 536     start-class-compiling
 537     create-@class-accessor
 538     finish-class-compiling
 539   endif
 540   previous  ;; remove "oof-creatori"
 541   0 to current-class-def
 542 ;
 543
 544 ;; extend class definition
 545 : extends:  ( -- )  \ parent-name
 546   ?in-class-def -find-required cfa->pfa  ( other-pfa )
 547   dup fword->typeid @ typeid-class-word <> " extend what?" ?error
 548   dup current-class-def class->def-pfa@ = " cannot extend self" ?error
 549   fword->info-addr @
 550   current-class-def class-inherit-from
 551 ;
 552 alias-for extends: is extend:
 553
 554
 555 ;; create field access word (immediate)
 556 ;;   "name" -- get field value
 557 : field:  ( -- )  \ name
 558   ?in-class-def
 559   parse-name dup " field name expected" ?not-error
 560   start-class-compiling
 561   ['] (field-acc-@) create-field-accessor
 562   cell bump-inst-size
 563   finish-class-compiling
 564 ;
 565
 566 ;; this trashes PAD
 567 ;; create field access word (immediate)
 568 ;;   "name" -- use as obj-value
 569 : obj-value:  ( info-addr -- )  \ name
 570   ?in-class-def
 571   dup if ?class-info endif
 572   parse-name dup " field name expected" ?not-error
 573   start-class-compiling rot >r
 574   ;; "field"
 575   ['] (objval-acc-run) create-field-accessor
 576   r> (finish-objval-field-accessor)
 577   cell bump-inst-size
 578   finish-class-compiling
 579 ;
 580
 581 ;; create method call words (immediate)
 582 ;;   "name" -- execute method
 583 : method:  ( -- )  \ name
 584   ?in-class-def
 585   parse-name dup " method name expected" ?not-error
 586   current-class-def class->vmt @ 1+ max-vmt-methods = " too many methods" ?error
 587   start-class-compiling
 588   create-method
 589   finish-class-compiling
 590 ;
 591
 592 previous prev-defs  ;; at OOF
 593
 594
 595 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 596 ;; vocabulary used in method definition
 597 ;;
 598
 599 simple-vocabulary oof-mtdef
 600 also-defs: oof-mtdef
 601 also oof-internal
 602
 603 : self  ( -- )
 604   compiler:?comp
 605   curr-method-def-class " not defining a method" ?not-error
 606   compile (self@)
 607 ; immediate
 608
 609 : @class  ( -- )
 610   compiler:?comp
 611   curr-method-def-class " not defining a method" ?not-error
 612   compile (self-@class)
 613 ; immediate
 614
 615 ;; call inherited method
 616 ;; dynamic binding
 617 : inherited  ( -- )
 618   compiler:?comp
 619   curr-method-def-class " not defining a method" ?not-error
 620   curr-method-def-class class->level@ " inherited without parent" ?not-error
 621   curr-method-def-vmtofs literal compile (self-call-inh-vmtofs)
 622 ; immediate
 623
 624 ;; field address
 625 : ->  ( -- addr ) \ name
 626   compiler:?comp
 627   curr-method-def-class " not defining a method" ?not-error
 628   -find-required cfa->pfa dup fword->typeid @ field-typeid? " address of what?" ?not-error
 629   (field-acc-addr)
 630 ; immediate
 631
 632 ;; must be the last one in this vocabulary
 633 : ;
 634   compiler:?comp
 635   curr-method-def-class " not defining a method" ?not-error
 636   false to curr-method-def-class
 637   previous previous [compile] forth:;
 638 ; immediate
 639
 640
 641 previous prev-defs  ;; at OOF
 642 also oof-internal
 643
 644
 645 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 646 ;; high-level class creation words
 647 ;;
 648
 649 ;; this trashes PAD
 650 : class:  ( -- )  \ name
 651   ;; class word layout:
 652   ;;   typeid-class-word  (signature)
 653   ;;   info-addr           (address of class info table)
 654   compiler:?exec
 655   current-class-def " previous class definition is not finished" ?error
 656   parse-name dup " class name expected" ?not-error
 657   ;; create class wordlist (without a hashtable)
 658   0 FALSE forth:(new-wordlist)
 659   create-class-info  ( addr count info-addr )
 660   nrot (create)  ( info-addr )
 661   here over class->def-pfa!
 662   typeid-class-word ,  ;; signature
 663   dup ,                ;; info-addr
 664   ;; we're defining this class
 665   to current-class-def
 666   ;; activate definition dictionary
 667   also oof-creatori
 668  does> ( pfa )
 669   fword->info-addr @
 670 ;
 671
 672 : method:  ( info-addr -- )  \ name
 673   compiler:?exec
 674   current-class-def " finish class definition first" ?error
 675   curr-method-def-class " already defining a method" ?error
 676   ?class-info
 677   ;; checks complete
 678   >r parse-name dup " method name expected" ?not-error
 679   ( addr count | info-addr )
 680   r@ class->vocid@ find-word-in-voc-and-parents " method not found" ?not-error
 681   ( cfa | info-addr )
 682   cfa->pfa dup fword->typeid @ typeid-method-word <> " trying to define non-method" ?error
 683   fword->ofs @
 684   dup to curr-method-def-vmtofs
 685   >r  ( | info-addr vmt-ofs )
 686   :noname swap  ( colon-id cfa | info-addr vmt-ofs )
 687   r> r@ class->vmt + ! r>  ( info-addr )
 688   to curr-method-def-class
 689   also oof-mtdef
 690   also curr-method-def-class class->vocid@ context !
 691 ;
 692
 693 : method-cfa:  ( info-addr -- cfa )  \ name
 694   ?class-info
 695   ;; checks complete
 696   >r parse-name dup " method name expected" ?not-error
 697   r> (find-method)
 698   compiler:comp? if cfaliteral endif
 699 ; immediate
 700
 701
 702 : invoke-str  ( inst-addr addr count -- )
 703   compiler:comp? if compile (invoke-str)
 704   else (invoke-str)
 705   endif
 706 ; immediate
 707
 708 : invoke-dyn:  ( inst-addr -- )  \ name
 709   parse-name dup " method name expected" ?not-error
 710   compiler:comp? if strliteral endif
 711   [compile] invoke-str
 712 ; immediate
 713
 714 : invoke:  ( inst-addr -- )  \ classname name
 715   -find-required cfa->pfa dup fword->typeid @ typeid-class-word <> " class name expected" ?error
 716   fword->info-addr @ >r  ( inst-addr | info-addr )
 717   parse-name dup " method/field name expected" ?not-error
 718   r@ (find-field-word)  ( inst-addr pfa | info-addr )
 719   dup fword->ofs @ swap fword->typeid @  ( inst ofs typeid | info )
 720   r> swap ( inst ofs info typeid )
 721   dup typeid-method-word = if drop ['] (class-invoke)
 722   else field-typeid? " invoke what?" ?not-error ['] (field-invoke)
 723   endif
 724   (clx-invoke)
 725 ; immediate
 726
 727 \ bind-class classname oof:bind-field: <field>
 728 : bind-field:  ( bind-class info-addr -- )  \ name
 729   compiler:?exec
 730   current-class-def " finish class definition first" ?error
 731   curr-method-def-class " already defining a method" ?error
 732   ?class-info  over ?class-info drop
 733   parse-name dup " field name expected" ?not-error ( bc ia addr count )
 734   rot (find-field-word)  ( bc pfa )
 735   dup fword->typeid @ typeid-objfield-word <> " trying to bind non-objval field" ?error
 736   fword->objval-info-addr dup @ " already bound" ?error
 737   !
 738 ; immediate
 739
 740 : size-of  ( info-addr -- instance-size )
 741   ?class-info class->inst-size@
 742 ;
 743
 744 : name-of  ( info-addr -- addr count )
 745   ?class-info class->name@
 746 ;
 747
 748 : parent-of  ( info-addr -- info-addr / 0 )
 749   ?class-info
 750   dup class->level@ dup if  ( info-addr level )
 751     1- cells swap class->iht + @
 752   else nip
 753   endif
 754 ;
 755
 756 ;; init internal fields, zero other
 757 : emplace  ( info-addr addr -- )
 758   >r dup size-of  ( info-addr inst-size | addr )
 759   r@ swap erase
 760   typeid-instance r@ !  ;; signatire
 761   r> cell+ !            ;; info-addr
 762 ;
 763
 764 : allot  ( info-addr -- addr )
 765   dup size-of n-allot  ( info-addr addr )
 766   dup >r emplace r>
 767 ;
 768
 769 : new  ( info-addr -- addr )
 770   dup size-of swap dup >r handle:new-alloc
 771   r> over emplace
 772 ;
 773
 774 ;; check if instance/class-0 is a valid child of instance/class-1.
 775 ;; equal classes are valid children too.
 776 : isa?  ( i/c-0 i/c-1 -- bool )  oof-internal:(isa?) ;
 777
 778
 779 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 780 ;; obj-value
 781 ;;
 782
 783 : obj-value  ( info-addr -- )  \ name
 784   dup if ?class-info endif
 785   create immediate
 786   ;; info-addr is second to keep it in line with other words
 787   typeid-objval-word ,  ;; signature
 788   ,                     ;; info-addr
 789   0 ,                   ;; value
 790  does> ( pfa )  \ name
 791   >r parse-name dup " method name expected" ?not-error
 792   r@ fword->info-addr @ (find-field-word)  ( word-pfa | pfa )
 793   ;; check type
 794   dup fword->typeid @  ( word-pfa typeid | pfa )
 795   dup typeid-method-word <> over field-typeid? not and " trying to access something wrong" ?error
 796   ( word-pfa typeid | pfa )
 797   swap fword->ofs @ r> fword->value  ( typeid ofs value-addr )
 798   compiler:comp? if
 799     literal compile @  ;; get value
 800     literal            ;; vmtofs
 801     typeid-method-word = if compile (vmt-call) else compile (field-read) endif
 802   else
 803     @ swap rot typeid-method-word = if ['] (vmt-call) else ['] (field-read) endif
 804     execute-tail
 805   endif
 806 ;
 807
 808 \ classname oof:bind: <obj-value>
 809 : bind:  ( info-addr -- )  \ name
 810   ?class-info -find-required ( ia cfa )
 811   cfa->pfa dup fword->typeid @ typeid-objval-word <> " trying to bind non-obj-value" ?error
 812   compiler:comp? if literal compile (obj-value-rebind)
 813   else (obj-value-rebind)
 814   endif
 815 ; immediate
 816
 817 : value-of:  ( -- value )  \ name
 818   -find-required ( ia cfa )
 819   cfa->pfa dup fword->typeid @ typeid-objval-word <> " trying to query non-obj-value" ?error
 820   fword->value compiler:comp? if literal compile @ else @ endif
 821 ; immediate
 822
 823 : class-of:  ( -- value )  \ name
 824   -find-required ( ia cfa )
 825   cfa->pfa dup fword->typeid @ typeid-objval-word <> " trying to query non-obj-value" ?error
 826   fword->info-addr compiler:comp? if literal compile @ else @ endif
 827 ; immediate
 828
 829
 830 previous prev-defs  ;; at original