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