libs/uroof.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; slightly more complicated OO system than mini-oof
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (*
  10   internal class layout (somewhat confusingly called VMT):
  11     typeid-class   (just a typeid signature)
  12     parent-class   (ptr, can be 0)
  13     vocid          (vocabulary for this class)
  14     instance-size  (bytes)
  15     vmt-size       (bytes)
  16   then vmt data follows (so default vmt-size is 16)
  17   first field of each instance is classptr (so default instance-size is 4)
  18   VMT holds both method implementation pointers, and class vars.
  19   class VOCID may contain point to class word header -- it can be used to get class name.
  20
  21   class vocabulary contains all class variables and methods. pfa contains:
  22     offset
  23     typeid
  24
  25   interpreter is augmented via "interpret-wfind"
  26 *)
  27
  28 vocabulary oop
  29 also oop definitions
  30
  31 vocabulary oop-internal
  32
  33
  34 666_999 constant typeid-class
  35
  36 666_666 constant typeid-method
  37 666_667 constant typeid-variable
  38 666_668 constant typeid-field
  39 \ 666_669 constant typeid-ptr
  40
  41 669_666 constant typeid-class-method
  42 669_667 constant typeid-class-variable
  43 669_668 constant typeid-class-field
  44 \ 669_669 constant typeid-class-ptr
  45
  46 696_666 constant typeid-value
  47
  48 5 cells constant (class-header-size)
  49
  50 ;; used when defining a new class
  51 0 value (current-parent)  ;; saved class parent (we need it in "end-class:", but it is specified in "oop:class")
  52 0 var (current-vmtsize)   ;; VMT size -- VMT is an internal class representation (see above)
  53 0 var (current-instsize)  ;; instance (fields) size
  54 0 value (current-vocid)   ;; class vocabulary
  55
  56 ;; used when compiling a class method
  57 0 value (current-self)         ;; classid (VMT ptr); 0 means "not compiling a method"
  58 0 value (current-mtofs)        ;; offset of the current method
  59 false value (current-classmt)  ;; is current method a class method?
  60
  61
  62 : (cleanup-def)  ( -- )
  63   0 to (current-parent)
  64   (current-vmtsize) 0!
  65   (current-instsize) 0!
  66   0 to (current-vocid)
  67   0 to (current-self)
  68   0 to (current-mtofs)
  69   false to (current-classmt)
  70 ;
  71
  72 : defining-class?   ( -- flag ) (current-vocid) notnot ;
  73 : defining-method?  ( -- flag ) (current-self) notnot ;
  74
  75 ..: forth:(abort-cleanup)  ( -- )  0 (self!) (cleanup-def) ;..
  76
  77 ..: forth:(exc0!)  ( -- )  0 (self!) (cleanup-def) ;..
  78 ..: forth:(catch-saver)  ( -- )
  79   r> (self@) >r [: ( restoreflag ) ( self )  r> swap if r> (self!) else rdrop endif >r ;] >r >r
  80 ;.. (hidden)
  81
  82
  83 : (class->typeid)    ( class -- addr ) ; immediate
  84 : (class->parent)    ( class -- addr ) cell+ ;
  85 : (class->vocid)     ( class -- addr ) 2 +cells ;
  86 : (class->instsize)  ( class -- addr ) 3 +cells ;
  87 : (class->vmtsize)   ( class -- addr ) 4 +cells ;
  88
  89 : (class-typeid@)    ( class -- addr ) (class->typeid) @ ;
  90 : (class-parent@)    ( class -- addr ) (class->parent) @ ;
  91 : (class-vocid@)     ( class -- addr ) (class->vocid) @ ;
  92 : (class-instsize@)  ( class -- addr ) (class->instsize) @ ;
  93 : (class-vmtsize@)   ( class -- addr ) (class->vmtsize) @ ;
  94 : (class-name@)      ( class -- addr count ) (class->vocid) @ vocid-headnfa@ dup if id-count else drop NullString endif ;
  95
  96 : (xfind-vocid)  ( addr count voicid -- pfaaddr immflag // addr count false )
  97   (wflag-smudge) (wflag-vocab) or (wflag-codeblock) or (wflag-immediate) or
  98   forth:(voc-search-with-mask) dup if swap cfa->pfa swap endif
  99 ;
 100
 101 : (xfindres-typeid@)  ( pfaaddr -- typeid )  dup if cell+ @ endif ; (hidden)
 102
 103 : (xfind-in-class)  ( addr count classid -- pfaaddr typeid true // false )
 104   begin ?dup while
 105     dup >r (class-vocid@) (xfind-vocid) if rdrop dup (xfindres-typeid@) true exit endif
 106     r> (class-parent@)
 107   repeat
 108   2drop false
 109 ;
 110
 111 : (xfind-in-class-vofs)  ( addr count classid -- vofs typeid true // false )
 112   (xfind-in-class) if swap @ swap true else false endif
 113 ;
 114
 115 : (find-typed)  ( addr count classid type -- vmtofs/instofs true // false )
 116   >r (xfind-in-class-vofs) if r> = ifnot drop false else true endif
 117   else rdrop false endif
 118 ;
 119
 120 : find-method  ( addr count classid -- vmtofs true // false )  typeid-method (find-typed) ;
 121 : find-class-method  ( addr count classid -- vmtofs true // false )  typeid-class-method (find-typed) ;
 122
 123 : (xfind)  ( addr count -- addr true // false )
 124   (current-vocid) if (current-vocid) (xfind-vocid) if true exit endif endif
 125   (current-parent) (xfind-in-class) dup if nip endif
 126 ;
 127
 128 : (xcreate-str)  ( addr count vocid -- )
 129   get-current >r set-current ['] create-named catch r> set-current throw
 130 ;
 131
 132 ;; check if the given vocid looks like a valid class vocabulary
 133 : class?  ( classid -- flag )  dup if (class-typeid@) typeid-class = endif ;
 134 : inst->class  ( inst -- clsid//0 )  dup if dup class? ifnot @ endif endif ;
 135 : child-of?  ( subclassid superclassid -- flag )
 136   inst->class swap inst->class
 137   begin dup while 2dup = if 2drop true exit endif (class-parent@) repeat
 138   2drop false
 139 ;
 140 : class-name  ( classid -- addr count )  inst->class dup class? if (class-name@) else drop NullString endif ;
 141
 142 : (create-typed-str)  ( addr count ofsptr type -- )
 143   2over (xfind) if endcr ." duplicate class field \`" type ." \`" abort" class error" endif
 144   2swap (current-vocid) (xcreate-str) over @ , , cell swap +!
 145 ;
 146
 147 : (var-str)  ( addr count -- )  (current-instsize) typeid-variable (create-typed-str) ;
 148 : (field-str)  ( addr count -- )  (current-instsize) typeid-field (create-typed-str) ;
 149 : (method-str)  ( addr count -- )  (current-vmtsize) typeid-method (create-typed-str) ;
 150 : (class-var-str)  ( addr count -- )  (current-vmtsize) typeid-class-variable (create-typed-str) ;
 151 : (class-field-str)  ( addr count -- )  (current-vmtsize) typeid-class-field (create-typed-str) ;
 152 : (class-method-str)  ( addr count -- )  (current-vmtsize) typeid-class-method (create-typed-str) ;
 153
 154
 155 : class  ( parentclassid -- )  \ name
 156   defining-class? ?abort" cannot create nested class"
 157   defining-method? ?abort" cannot create class in method definition"
 158   dup if
 159     dup class? not-?abort" parent is not a class"
 160     dup (class-vmtsize@) over (class-instsize@)
 161   else
 162     (class-header-size) 0
 163   endif
 164   (current-instsize) ! (current-vmtsize) !
 165   forth:wordlist to (current-vocid)  ;; create anonymous wordlist
 166   dup to (current-parent)
 167   ;; create default field for empty class
 168   ifnot " my-class" (var-str) endif
 169   also oop-internal
 170 ;
 171
 172
 173 : (compile-var-addr) ( instofs -- )
 174   compiler:?comp
 175   (current-classmt) ?abort" cannot use instance vars in class method"
 176   compile forth:(self@) [compile] literal compile +
 177 ; (hidden)
 178
 179 : (compile-var-xto) ( instofs cfa -- )  swap (compile-var-addr) ?compile, ; (hidden)
 180
 181 : (compile-method)  ( vmtofs -- )
 182   compiler:?comp
 183   (current-classmt) ?abort" cannot use instance methods in class method"
 184   compile forth:(self@) compile @ [compile] literal compile + compile @execute
 185 ; (hidden)
 186
 187
 188 ;; in class method, `self` is classid
 189 : (compile-class-var-addr) ( instofs -- )
 190   compiler:?comp
 191   compile forth:(self@)
 192   (current-classmt) ifnot compile @ endif
 193   [compile] literal compile +
 194 ; (hidden)
 195
 196 : (compile-class-var-xto) ( instofs cfa -- )  swap (compile-class-var-addr) ?compile, ; (hidden)
 197
 198 ;; in class method, `self` is classid
 199 : (compile-class-method)  ( vmtofs -- )
 200   compiler:?comp
 201   compile forth:(self@)
 202   (current-classmt) ifnot compile @ compile (self@) compile >r compile dup compile (self!) endif
 203   [compile] literal compile + compile @execute
 204   (current-classmt) ifnot compile r> compile (self!) endif
 205 ; (hidden)
 206
 207
 208 : compile-something  ( vofs typeid -- )
 209   compiler:?comp case
 210     typeid-method of (compile-method) endof
 211     typeid-field of ['] @ (compile-var-xto) endof
 212     typeid-variable of (compile-var-addr) endof
 213     typeid-class-method of (compile-class-method) endof
 214     typeid-class-field of ['] @ (compile-class-var-xto) endof
 215     typeid-class-variable of (compile-class-var-addr) endof
 216     abort" wut?!"
 217   endcase
 218 ;
 219
 220 : compile-xto  ( vofs typeid cfa -- )
 221   swap compiler:?comp case
 222     typeid-field of (compile-var-xto) endof
 223     typeid-class-field of (compile-class-var-xto) endof
 224     typeid-variable of abort" cannot assign value to var" endof
 225     typeid-method of abort" cannot assign value to method" endof
 226     typeid-class-variable of abort" cannot assign value to class var" endof
 227     typeid-class-method of abort" cannot assign value to class method" endof
 228     abort" wut?!"
 229   endcase
 230 ;
 231
 232 : init-instance  ( classid instaddr -- instaddr )
 233   2dup swap (class-instsize@) erase
 234   dup nrot !
 235 ;
 236
 237 : new-allot  ( classid -- addr )
 238   dup class? not-?abort" not a class"
 239   dup (class-instsize@) n-allot init-instance
 240 ;
 241
 242
 243 ;; compiled into method code
 244 : (child-of-check) ( subclassid superclassid -- subclassid )
 245   over swap child-of? not-?abort" class/instance access violation"
 246 ;
 247
 248
 249 : (invoke-inst-check)  ( instance classid vmtofs -- vmtofs instance )
 250   nrot dup class? not-?abort" invalid invoke (bad class)"
 251   2dup child-of? not-?abort" invalid invoke (bad class)"
 252   drop dup class? ?abort" cannot invoke instance in class method"
 253 ;
 254
 255 : (invoke-class-check)  ( inst/clsid classid vmtofs -- vmtofs clsid )
 256   nrot swap inst->class dup class? not-?abort" invalid class invoke (bad class)"
 257   over child-of? not-?abort" invalid class invoke (bad class)"
 258 ;
 259
 260 ;; invoke instance method, common code
 261 : (invoke-common)  ( vmtofs inst/clsid instance -- )  (self@) >r over (self!) if @ endif + @execute r> [execute-tail] (self!) ; (hidden)
 262
 263 ;; invoke instance something
 264 : (invoke-method)  ( instance classid vmtofs -- )  (invoke-inst-check) true [execute-tail] (invoke-common) ; (hidden)
 265 : (invoke-var)  ( instance classid vmtofs -- )  (invoke-inst-check) [execute-tail] + ; (hidden)
 266 : (invoke-field)  ( instance classid vmtofs -- )  (invoke-inst-check) + [execute-tail] @ ; (hidden)
 267
 268 ;; invoke class something
 269 : (invoke-cmethod)  ( inst/clsid classid vmtofs -- )  (invoke-class-check) false [execute-tail] (invoke-common) ; (hidden)
 270 : (invoke-cvar)  ( inst/clsid classid vmtofs -- )  (invoke-class-check) [execute-tail] + ; (hidden)
 271 : (invoke-cfield)  ( inst/clsid classid vmtofs -- )  (invoke-class-check) + [execute-tail] @ ; (hidden)
 272
 273 : (invoke-get-parentclass)  ( instance/class -- )  inst->class dup class? if (class-parent@) else drop 0 endif ; (hidden)
 274
 275
 276 : (invoke-compiler-route)  ( -- )  \ wordname  word-to-route
 277   create smudge -find-required reladdr, smudge (hidden)
 278  does>  ( pfa )
 279   nip state @ if @ compile, else @execute-tail endif
 280 ;
 281
 282 (invoke-compiler-route) (invoke-compiler-class) inst->class
 283 (invoke-compiler-route) (invoke-compiler-parent-class) (invoke-get-parentclass)
 284 (invoke-compiler-route) (invoke-compiler-class-name) class-name
 285
 286 \ : (invoke-compiler-class)  ( cid -- )  ( instance )  drop ['] inst->class state @ if compile, else execute-tail endif ; (hidden)
 287 \ : (invoke-compiler-parent-class)  ( cid -- )  ( instance )  drop ['] (invoke-get-parentclass) state @ if compile, else execute-tail endif ; (hidden)
 288 \ : (invoke-compiler-class-name)  ( cid -- )  ( instance )  drop ['] class-name state @ if compile, else execute-tail endif ; (hidden)
 289
 290 : (invoke-compiler-child-of?)  ( cid -- )  ( instance )  drop state @ if compile swap compile child-of? else swap [execute-tail] child-of? endif ; (hidden)
 291 : (invoke-compiler-child-of:)  ( cid -- )  ( instance )  \ classname
 292   drop -find-required cfa->pfa dup class? not-?abort" not a class!"
 293   [compile] addrliteral ['] child-of? state @ if compile, else execute-tail endif
 294 ; (hidden)
 295
 296
 297 nested-vocabulary (invoke-specials) also (invoke-specials) definitions
 298 : self  ( inst/clsid cid -- )  drop ;
 299 : class  ( inst/clsid cid -- )  (invoke-compiler-class) ;
 300 : parent-class  ( inst/clsid cid -- )  (invoke-compiler-parent-class) ;
 301 : child-of:  ( inst/clsid cid -- )  (invoke-compiler-child-of:) ;
 302 : child-of?  ( inst/clsid cid -- )  (invoke-compiler-child-of?) ;
 303 : class-name  ( inst/clsid cid -- )  (invoke-compiler-class-name) ;
 304
 305 : (other) ( inst/clsid cid addr count -- )  rot >r  ;; save cid
 306   r@ (xfind-in-class-vofs) not-?abort" methor/field name expected"
 307   r> nrot case  ;; ( cid vmtofs )
 308     typeid-method of ['] (invoke-method) endof
 309     typeid-field of ['] (invoke-field) endof
 310     typeid-variable of ['] (invoke-var) endof
 311     typeid-class-method of ['] (invoke-cmethod) endof
 312     typeid-class-field of ['] (invoke-cfield) endof
 313     typeid-class-variable of ['] (invoke-cvar) endof
 314     abort" wut?!"
 315   endcase
 316   state @ if >r swap [compile] addrliteral [compile] literal r> compile, else execute-tail endif
 317 ; (hidden)
 318 previous definitions
 319
 320 : (invoke-compiler)  ( cid -- )  ( instance -- )  \ name
 321   inst->class dup class? not-?abort" not a class!"
 322   parse-name vocid: (invoke-specials) voc-search-noimm ifnot ['] (invoke-specials):(other) endif
 323   execute-tail
 324 ; (hidden)
 325
 326 ;; obj ::invoke classname methodname -- dynamic binding
 327 : ::invoke  ( instance -- )  \ classname methodname
 328   ' cfa->pfa [execute-tail] (invoke-compiler)
 329 ; immediate
 330
 331
 332 ;; worker word for string dispatch in the current instance
 333 : (dispatch-str)  ( addr count -- ... )
 334   2dup (self@) inst->class (xfind-in-class-vofs) ifnot
 335     " (unknown-dispatch)" (self@) @ (xfind-in-class-vofs) ifnot
 336       (abort-msg-reset) " cannot dispatch method \`" (abort-msg-type) (abort-msg-type) 34 (abort-msg-emit)
 337       err-dispatch-error (abort-with-built-msg-errcode)
 338     endif
 339   else 2swap 2drop endif
 340   case
 341     typeid-method of (self@) dup class? ?abort" cannot dispatch instance method in class" inst->class + @execute-tail endof
 342     typeid-field of (self@) dup class? ?abort" cannot dispatch instance field in class" + @ endof
 343     typeid-variable of (self@) dup class? ?abort" cannot dispatch instance variable in class" + endof
 344     typeid-class-method of (self@) inst->class + @execute-tail endof
 345     typeid-class-field of (self@) inst->class + @ endof
 346     typeid-class-variable of (self@) inst->class + endof
 347     abort" wut?!"
 348   endcase
 349 ; (hidden)
 350
 351 ;; obj invoke name -- dynamic binding by name
 352 : dispatch-str  ( instance addr count -- ... )
 353   (self@) >r rot (self!) (dispatch-str) r> [execute-tail] (self!)
 354 ;
 355
 356
 357 : method:  ( classid -- )  \ name
 358   defining-class? ?abort" cannot define method while defining a class"
 359   defining-method? ?abort" cannot define method while defining a method"
 360   dup class? not-?abort" cannot define method for something that is not a class"
 361   dup parse-name 2dup 2>r rot oop:find-method ifnot
 362     ;; class method?
 363     dup 2r@ rot oop:find-class-method not-?abort" unknown method"
 364     true to (current-classmt)
 365   else false to (current-classmt) endif
 366   to oop:(current-mtofs) to oop:(current-self)
 367   \ :noname
 368   ;; make it named
 369   " (" pad c1s:copy-counted
 370   oop:(current-self) (class-name@) pad c1s:cat-counted
 371   [char] : pad c1s:cat-char
 372   2r> pad c1s:cat-counted [char] ) pad c1s:cat-char pad bcount (:noname-named)
 373   also oop:oop-internal
 374 ;
 375
 376 ;; value that holds object instance
 377 ;; data: typeid inst clsid
 378 : value  ( inst -- )  \ name classname
 379   create typeid-value , , smudge
 380   -find-required cfa->pfa dup class? not-?abort" not a class!" ,
 381   smudge immediate
 382  does>  ( pfa )
 383   dup @ typeid-value = not-?abort" instance value is corrupted"
 384   dup cell+ state @ if [compile] addrliteral compile @ 2 +cells @
 385   else @ dup not-?abort" cannot call method of null object" swap 2 +cells @ endif
 386   [execute-tail] (invoke-compiler)
 387 ;
 388
 389 : to  ( inst -- )  \ name
 390   -find-required cfa->pfa
 391   dup @ typeid-value = not-?abort" instance value expected"
 392   cell+ [compile] addrliteral ['] ! state @ if compile, else execute-tail endif
 393 ; immediate
 394
 395 : value@  ( -- inst )  \ name
 396   -find-required cfa->pfa
 397   dup @ typeid-value = not-?abort" instance value expected"
 398   cell+ @ [compile] addrliteral
 399 ; immediate
 400
 401
 402 : (expect-defining-class)  ( -- )  defining-class? not-?abort" outside of class definition" ; (hidden)
 403 : (expect-defining-method)  ( -- )  defining-method? not-?abort" outside of method definition" ; (hidden)
 404
 405
 406 ;; this vocabulary is used inside class/method definition
 407 also oop-internal definitions
 408
 409 : end-class:  ( -- )  \ name
 410   oop:(expect-defining-class)
 411   previous
 412   parse-name 2dup 2>r create-named smudge
 413   here >r ;; will be used later
 414   typeid-class ,
 415   (current-parent) ,
 416   (current-vocid) ,
 417   (current-instsize) @ ,
 418   (current-vmtsize) @ ,
 419   (current-vmtsize) @ (class-header-size) - dup 0< ?abort" invalid class data size" n-allot
 420   ;; put class name (nope, we will use vocid field for that)
 421   ;; r> 2r@ rot >r dup 1+ n-allot c1s:copy-counted
 422   ;; copy vmt from the parent, leave new-vmt-addr on the stack
 423   (current-parent) if  >r
 424     (current-parent) (class-vmtsize@) (class-header-size) -
 425     (current-parent) (class-header-size) +
 426     over r@ swap 0 max cmove r> swap
 427   else (class-header-size) endif
 428   over (current-vmtsize) @ + nrot + ?do ['] forth:(notimpl) , cell +loop
 429   smudge create;
 430   latest-nfa (current-vocid) vocid-headnfa!
 431   (cleanup-def)
 432   ;; create "classname::" word too
 433   r> 2r> pad c4s:copy-counted " ::" pad c4s:cat-counted pad count create-named , immediate
 434  does> ( pfa )  ;; does invoke
 435   @ [execute-tail] oop:(invoke-compiler)
 436 ;
 437
 438 : var  ( -- )  (( name ))  oop:(expect-defining-class) parse-name (var-str) ;
 439 : field  ( -- )  (( name ))  oop:(expect-defining-class) parse-name (field-str) ;
 440 : method  ( -- )  (( name ))  oop:(expect-defining-class) parse-name (method-str) ;
 441 : buffer:  ( size -- )  (( name ))  dup 1 < ?abort" invalid buffer size" oop:(expect-defining-class) parse-name (var-str) cell- (current-instsize) +! ;
 442
 443 : class-var  ( -- )  (( name ))  oop:(expect-defining-class) parse-name (class-var-str) ;
 444 : class-field  ( -- )  (( name ))  oop:(expect-defining-class) parse-name (class-field-str) ;
 445 : class-method  ( -- )  (( name ))  oop:(expect-defining-class) parse-name (class-method-str) ;
 446
 447
 448 : self  ( -- )
 449   oop:(expect-defining-method) compiler:?comp
 450   compile (self@)
 451 ; immediate
 452
 453 : class-name  ( -- )
 454   oop:(expect-defining-method) compiler:?comp
 455   compile (self@) compile oop:class-name
 456 ; immediate
 457
 458 ;; runtime vmt call by method name
 459 : dispatch-str  ( addr count -- ... )
 460   oop:(expect-defining-method) compiler:?comp
 461   compile oop:(dispatch-str)
 462 ; immediate
 463
 464 : ::invoke  ( instance -- )  \ classname methodname
 465   oop:(expect-defining-method) compiler:?comp
 466   [compile] oop:::invoke
 467 ; immediate
 468
 469 : invoke  ( instance -- )  \ methodname
 470   oop:(expect-defining-method) compiler:?comp
 471   (current-self) oop:(invoke-compiler)
 472 ; immediate
 473
 474 ;; does no sanity checks!
 475 : var^  ( instance -- )  \ varname
 476   oop:(expect-defining-method) compiler:?comp
 477   parse-name (current-self) (xfind-in-class-vofs) not-?abort" var/field name expected"
 478   dup typeid-class-field = if drop typeid-class-variable endif
 479   dup typeid-class-variable = if compile inst->class drop typeid-variable endif
 480   dup typeid-field = if drop typeid-variable endif
 481   typeid-variable = not-?abort" cannot take address of something that is not a var/field"
 482   (current-self) [compile] addrliteral compile oop:(child-of-check)
 483   [compile] literal compile +
 484 ; immediate
 485
 486 ;; call current inherited method
 487 : call-super  ( -- )
 488   oop:(expect-defining-method) compiler:?comp
 489   (current-self) (class-parent@) dup not-?abort" no parent class"
 490   dup (class-vocid@) [:
 491     dup nfa->ffa ffa@ [ (wflag-smudge) (wflag-hidden) or ] literal and if
 492       drop false
 493     else
 494       nfa->cfa cfa->pfa dup cell+ @
 495       (current-classmt) if typeid-class-method else typeid-method endif
 496       = if @ (current-mtofs) = else drop false endif
 497     endif
 498   ;] foreach-word not-?abort" no supermethod found"
 499   (current-mtofs) + [compile] addrliteral compile @execute
 500 ; immediate
 501
 502 ;; call inherited method
 503 : inherited  ( -- )  \ name
 504   oop:(expect-defining-method) compiler:?comp
 505   (current-self) (class-parent@) dup not-?abort" no parent class"
 506   (current-classmt) if
 507     dup parse-name rot find-class-method not-?abort" unknown method"
 508     + [compile] addrliteral compile @execute
 509   else
 510     dup parse-name 2dup 2>r rot find-method ifnot
 511       ;; class method?
 512       dup 2r> rot find-class-method not-?abort" unknown method"
 513       compile (self@) compile >r over [compile] addrliteral compile (self!)
 514       + [compile] addrliteral compile @execute
 515       compile r> compile (self!)
 516     else
 517       ;; instance method
 518       2rdrop + [compile] addrliteral compile @execute
 519     endif
 520   endif
 521 ; immediate
 522
 523 ;; compiles class name of the defining method
 524 : static-class-name  ( -- )
 525   oop:(expect-defining-method) compiler:?comp
 526   (current-self) (class-name@) [compile] sliteral
 527 ; immediate
 528
 529 ;; compiles class ptr of the defining method
 530 : static-class  ( -- )
 531   oop:(expect-defining-method) compiler:?comp
 532   (current-self) [compile] addrliteral
 533 ; immediate
 534
 535
 536 vocabulary (interpret-specials) also (interpret-specials) definitions
 537 ;; all normal methods: ( -- addr count false // true )
 538
 539 \ : addr:  parse-name (current-self) (xfind-in-class-vofs) not-?abort" field/var name expected" 0 compile-xto true ;
 540
 541 : (other)  ( addr count -- addr count false // true )
 542   2dup (current-self) (xfind-in-class-vofs) dup if drop 2swap 2drop compile-something true endif
 543 ; (hidden)
 544 previous definitions
 545
 546 ..: value-xto-schook  ( value type addr count -- true // unchanged )
 547   state @ defining-method? logand if
 548     2dup (current-self) (xfind-in-class-vofs) if
 549       ( type addr count vofs typeid )
 550       2swap 2drop rot forth:(value-xto-type->cfa) compile-xto true exit
 551     endif
 552   endif
 553 <;..
 554
 555 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
 556 ;; scattered extensions should simply pass "addr count" unchanged (or changed ;-)
 557 ..: interpret-wfind  ( addr count -- cfa 1 // cfa -1 // addr count false )
 558   state @ defining-method? logand if
 559     vocid: (interpret-specials) ['] (interpret-specials):(other) (intepret-voc-call-helper) if exit endif
 560   endif
 561 ;..
 562
 563
 564 ;; redefine ";"
 565 : ;
 566     \ endcr ." UROOF: semi: " latest-nfa id. cr
 567   oop:(expect-defining-method) compiler:?comp
 568   previous
 569   " ;" wfind dup not-?abort" semicolon not found"
 570   +if execute else compile, endif
 571   \ [compile] forth:;
 572   (current-self) (current-mtofs) + !  ;; put noname cfa to vmt
 573   (cleanup-def)
 574 ; immediate
 575
 576
 577 previous previous definitions
 578
 579
 580 alias oop:method: method:
 581 alias oop:::invoke ::invoke
 582 alias oop:dispatch-str ::dispatch-str