1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; and now
for something completely different
...
3 ;; UrForth
/C Forth Engine
!
4 ;; Copyright
(C
) 2023 Ketmar Dark
// Invisible Vector
6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 ;; slightly more complicated OO system than mini
-oof
8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 each class has inheritance table
(16 items
; more than enough
).
13 tbl
[level
] points
to self
.
14 maximum number of methods is
128.
16 internal class layout
:
17 typeid
-class
(signature
)
19 level
(inheritance level
)
20 class
-word
-pfa
(created class word
)
26 method
-count
(number of methods in VMT
)
29 internal object layout
:
30 typeid
-instance
(signature
)
31 class
-info
-addr
(pointer
to class info above
)
33 class vocabulary contains all class variables and methods
.
35 class word pfa contains
:
36 typeid
-class
-word
(signature
)
37 info
-addr
(address of class info table
)
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
)
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
)
50 oof
:class
: MyClass
[ extends
: OtherClass
]
55 MyClass oof
:method
: ... ;
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"
61 special predefined fields
:
62 @class
-- get info
-addr
64 call inherited methods
(inside a method
, of course
):
65 inherited
-- with the same name
67 special fields inside a method
:
68 self
-- pointer
to instance or
to a class info
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
>
75 cls
-or
-inst addr count oof
:invoke
-str
77 special object values
:
78 classname oof
:obj
-value
<name
> -- immediate
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
.
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
92 bind
-class classname oof
:bind
-field
: <field
>
98 16 constant max
-inheritance
-level
99 128 constant max
-vmt
-methods
101 vocabulary oof
-internal
102 also
-defs
: oof
-internal
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
116 ;; field or objval
-field?
117 : field
-typeid?
( typeid
-- bool
)
118 dup typeid
-field
-word
= swap typeid
-objfield
-word
= or
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
127 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128 ;; create class info accessor words
131 define
-accessors class
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
+
144 : class
->name@
( class
-- addr count
) class
->def
-pfa@ pfa
->nfa id
-count
;
146 : inst
->class
( instance
-- info
-addr
-addr
) cell
+ ;
147 : inst
->class@
( instance
-- info
-addr
) inst
->class @
;
148 : inst
->class
! ( info
-addr instance
-- ) inst
->class
! ;
150 2 cells constant initial
-inst
-size
152 ;; field
/method word offsets
153 define
-accessors fword
158 def
: objval
-info
-addr
162 alias
-for fword
->ofs is fword
->value
165 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166 ;; class info creation
169 : ?class
-info
( info
-addr
-- info
-addr
)
170 dup
" class id expected" ?not
-error
171 dup class
->typeid@ typeid
-class
<> " class id expected" ?error
174 : ?inst
-addr
( addr
-- addr
)
175 dup
" object expected" ?not
-error
176 dup @ typeid
-instance
<> " object expected" ?error
179 : ?in
-class
-def
( -- )
180 current
-class
-def
" not defining a class" ?not
-error
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
189 ;; create new class info record
190 : create
-class
-info
( vocid
-- info
-addr
)
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
200 ;; create inheritance table
201 dup
, max
-inheritance
-level
1- for 0 , endfor
203 0 , max
-vmt
-methods
1- for ['] (notimpl) , endfor
205 ;; create in dynamic memory
206 class-size max-inheritance-level max-vmt-methods + cells + over handle:new-alloc
207 swap ( info-addr vocid )
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
215 ;; create inheritance table
216 dup !+4>a max-inheritance-level 1- for 0 !+4>a endfor
218 0 !+4>a max-vmt-methods 1- for ['] (notimpl
) !+4>a endfor
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
)
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
254 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 ;; field accessor words
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
262 dup class->level@ ( my other other-level )
263 cells rot class->iht + @ =
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
276 : (find-method-vmtofs) ( addr count info-addr -- vmtofs )
278 dup fword->typeid @ typeid-method-word <> " trying to invoke non-method" ?error
282 : (find-method) ( addr count info-addr -- cfa )
283 dup >r (find-method-vmtofs)
284 r> class->vmt + @ ( cfa )
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!)
293 : (field-read) ( inst-addr instofs -- )
294 over " trying to use NULL object" ?not-error
298 : (obj-value-!) ( value pfa+4 -- )
300 over @ typeid-instance <> " trying to assign non-object" ?error
301 2dup @ (isa?) " invalid assignment (type)" ?not-error
303 else ;; 0 is always allowed
308 : (self@+) ( ofs -- @self+ofs ) (self@) + ;
310 ;; accessor for "->field"
311 : (field-acc-addr) ( pfa -- addr )
313 fword->ofs @ literal compile (self@+)
316 ;; accessor for "field"
317 : (field-acc-@) ( pfa -- value )
319 (field-acc-addr) compile @
322 ;; accessor for "field!"
323 : (field-acc-!) ( value pfa -- )
325 (field-acc-addr) compile !
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 )
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
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
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-!)
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
371 curr-method-def-class " not in method definition" ?not-error
372 dup fword->doer-cfa @execute-tail
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
380 : bump-inst-size ( delta -- )
381 current-class-def class->inst-size@ +
382 current-class-def class->inst-size!
385 : (self-@class) ( -- info-addr ) (self@) inst->class@ ;
386 : (self-vmtidx@) ( idx -- cfa ) (self-@class) class->vmt + @ ;
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
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+!
404 typeid-method-word , ;; signature
405 current-class-def , ;; info-addr
406 current-class-def class->vmt @ cells , ;; offset
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
414 ;; save some state on rstack, and setup new
415 : start-class-compiling ( -- )
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 !
426 ;; restore some state from rstack
427 : finish-class-compiling ( -- )
429 r> compiler:word-redefine-warn-mode !
430 r> forth:(new-word-flags) !
435 : create-@class-accessor ( -- )
436 " @class" (create) immediate
437 typeid-@class-word , ;; signature
438 current-class-def , ;; info-addr
441 curr-method-def-class " not in method definition" ?not-error
442 drop compile (self-@class)
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!)
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
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!)
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 )
472 : (clx-invoke) ( inst-addr ofs info-addr invoker-cfa )
473 compiler:comp? if rot literal swap literal compile,
479 ;; "TO" for obj-values
480 ..: FORTH:(TO-EXTENDER-FOUND) ( cfa FALSE -- cfa FALSE / TRUE )
482 dup cfa->pfa fword->typeid @ typeid-objval-word = if
484 compiler:comp? if literal compile (obj-value-!)
493 ;; "TO" for simple fields
494 ..: FORTH:(TO-EXTENDER-FOUND) ( cfa FALSE -- cfa FALSE / TRUE )
496 dup cfa->pfa fword->typeid @ typeid-field-word = if
498 curr-method-def-class " not in method definition" ?not-error
499 cfa->pfa (field-acc-!)
506 ;; "TO" for obj-value fields
507 ..: FORTH:(TO-EXTENDER-FOUND) ( cfa FALSE -- cfa FALSE / TRUE )
509 dup cfa->pfa fword->typeid @ typeid-objfield-word = if
511 curr-method-def-class " not in method definition" ?not-error
512 cfa->pfa (objval-acc-!)
524 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
525 ;; vocabulary used in class definition
528 simple-vocabulary oof-creatori
529 also-defs: oof-creatori
531 ;; finish class definition
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
540 previous ;; remove "oof-creatori"
541 0 to current-class-def
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
550 current-class-def class-inherit-from
552 alias-for extends: is extend:
555 ;; create field access word (immediate)
556 ;; "name" -- get field value
557 : field: ( -- ) \ name
559 parse-name dup " field name expected" ?not-error
560 start-class-compiling
561 ['] (field
-acc
-@
) create
-field
-accessor
563 finish
-class
-compiling
567 ;; create field access word
(immediate
)
568 ;; "name" -- use as obj
-value
569 : obj
-value
: ( info
-addr
-- ) \ name
571 dup
if ?class
-info
endif
572 parse
-name dup
" field name expected" ?not
-error
573 start
-class
-compiling rot
>r
575 ['] (objval-acc-run) create-field-accessor
576 r> (finish-objval-field-accessor)
578 finish-class-compiling
581 ;; create method call words (immediate)
582 ;; "name" -- execute method
583 : method: ( -- ) \ name
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
589 finish-class-compiling
592 previous prev-defs ;; at OOF
595 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
596 ;; vocabulary used in method definition
599 simple-vocabulary oof-mtdef
605 curr-method-def-class " not defining a method" ?not-error
611 curr-method-def-class " not defining a method" ?not-error
612 compile (self-@class)
615 ;; call inherited method
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)
625 : -> ( -- addr ) \ name
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
632 ;; must be the last one in this vocabulary
635 curr-method-def-class " not defining a method" ?not-error
636 false to curr-method-def-class
637 previous previous [compile] forth:;
641 previous prev-defs ;; at OOF
645 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
646 ;; high-level class creation words
650 : class: ( -- ) \ name
651 ;; class word layout:
652 ;; typeid-class-word (signature)
653 ;; info-addr (address of class info table)
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
664 ;; we're defining this class
666 ;; activate definition dictionary
672 : method
: ( info
-addr
-- ) \ name
674 current
-class
-def
" finish class definition first" ?error
675 curr
-method
-def
-class
" already defining a method" ?error
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
682 cfa
->pfa dup fword
->typeid @ typeid
-method
-word
<> " trying to define non-method" ?error
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
690 also curr
-method
-def
-class class
->vocid@ context
!
693 : method
-cfa
: ( info
-addr
-- cfa
) \ name
696 >r parse
-name dup
" method name expected" ?not
-error
698 compiler
:comp?
if cfaliteral
endif
702 : invoke
-str
( inst
-addr addr count
-- )
703 compiler
:comp?
if compile
(invoke
-str
)
708 : invoke
-dyn
: ( inst
-addr
-- ) \ name
709 parse
-name dup
" method name expected" ?not
-error
710 compiler
:comp?
if strliteral
endif
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
)
727 \ bind
-class classname oof
:bind
-field
: <field
>
728 : bind
-field
: ( bind
-class info
-addr
-- ) \ name
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
740 : size
-of
( info
-addr
-- instance
-size
)
741 ?class
-info class
->inst
-size@
744 : name
-of
( info
-addr
-- addr count
)
745 ?class
-info class
->name@
748 : parent
-of
( info
-addr
-- info
-addr
/ 0 )
750 dup class
->level@ dup
if ( info
-addr level
)
751 1- cells swap class
->iht
+ @
756 ;; init internal fields
, zero other
757 : emplace
( info
-addr addr
-- )
758 >r dup size
-of
( info
-addr inst
-size | addr
)
760 typeid
-instance r@
! ;; signatire
761 r
> cell
+ ! ;; info
-addr
764 : allot
( info
-addr
-- addr
)
765 dup size
-of n
-allot
( info
-addr addr
)
769 : new
( info
-addr
-- addr
)
770 dup size
-of swap dup
>r handle
:new
-alloc
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?
) ;
779 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
783 : obj
-value
( info
-addr
-- ) \ name
784 dup
if ?class
-info
endif
786 ;; info
-addr is second
to keep it in line with other words
787 typeid
-objval
-word
, ;; signature
791 >r parse
-name dup
" method name expected" ?not
-error
792 r@ fword
->info
-addr @
(find
-field
-word
) ( word
-pfa | pfa
)
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
)
799 literal compile @
;; get value
801 typeid
-method
-word
= if compile
(vmt
-call) else compile
(field
-read) endif
803 @ swap rot typeid
-method
-word
= if ['] (vmt-call) else ['] (field
-read) endif
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
)
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
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
830 previous prev
-defs
;; at original