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