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 ;; 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
) @
+
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
145 : (create
-peek
-accessor
) ( addr count ofs
-acc
-cfa
-- )
146 ['] @ [char] @ (create-accessor)
149 : (create-poke-accessor) ( addr count ofs-acc-cfa -- )
150 ['] ! [char
] ! (create
-accessor
)
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
)
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)
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
+
175 : class
->name@
( class
-- addr count
) class
->def
-pfa@ pfa
->nfa id
-count
;
177 : inst
->class
( instance
-- info
-addr
-addr
) cell
+ ;
178 : inst
->class@
( instance
-- info
-addr
) inst
->class @
;
179 : inst
->class
! ( info
-addr instance
-- ) inst
->class
! ;
181 2 cells constant initial
-inst
-size
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
;
190 : fword
->value
( pfa
-- addr
) 2 +cells
;
193 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
194 ;; class info creation
197 : ?class
-info
( info
-addr
-- info
-addr
)
198 dup
" class id expected" ?not
-error
199 dup class
->typeid@ typeid
-class
<> " class id expected" ?error
202 : ?inst
-addr
( addr
-- addr
)
203 dup
" object expected" ?not
-error
204 dup @ typeid
-instance
<> " object expected" ?error
207 : ?in
-class
-def
( -- )
208 current
-class
-def
" not defining a class" ?not
-error
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
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
226 ;; create inheritance table
227 dup
, max
-inheritance
-level
1- for 0 , endfor
229 0 , max
-vmt
-methods
1- for ['] (notimpl) , endfor
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 )
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
263 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264 ;; field accessor words
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
271 dup class
->level@
( my other other
-level
)
272 cells rot class
->iht
+ @
=
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
285 : (find
-method
-vmtofs
) ( addr count info
-addr
-- vmtofs
)
287 dup fword
->typeid @ typeid
-method
-word
<> " trying to invoke non-method" ?error
291 : (find
-method
) ( addr count info
-addr
-- cfa
)
292 dup
>r
(find
-method
-vmtofs
)
293 r
> class
->vmt
+ @
( cfa
)
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
!)
302 : (field
-read) ( inst
-addr instofs
-- )
303 over
" trying to use NULL object" ?not
-error
307 : (obj
-value
-!) ( value pfa
+4 -- )
309 over @ typeid
-instance
<> " trying to assign non-object" ?error
310 2dup @
(isa?
) " invalid assignment (type)" ?not
-error
312 else ;; 0 is always allowed
317 : (self@
+) ( ofs
-- @self
+ofs
) (self@
) + ;
319 ;; accessor
for "->field"
320 : (field
-acc
-addr
) ( pfa
-- addr
)
322 fword
->ofs @ literal compile
(self@
+)
325 ;; accessor
for "field"
326 : (field
-acc
-@
) ( pfa
-- value
)
328 (field
-acc
-addr
) compile @
331 ;; accessor
for "field!"
332 : (field
-acc
-!) ( value pfa
-- )
334 (field
-acc
-addr
) compile
!
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
)
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
354 ;; this is what compiled
to the method body
355 : (objval
-do-!) ( value info
-addr inst
-ofs
-- )
357 2dup
(isa?
) " invalid type for obj-value field" ?not
-error
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-!)
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
382 curr
-method
-def
-class
" not in method definition" ?not
-error
383 dup fword
->doer
-cfa @execute
-tail
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
391 : bump
-inst
-size
( delta
-- )
392 current
-class
-def class
->inst
-size@
+
393 current
-class
-def class
->inst
-size
!
396 : (self
-@class
) ( -- info
-addr
) (self@
) inst
->class@
;
397 : (self
-vmtidx@
) ( idx
-- cfa
) (self
-@class
) class
->vmt
+ @
;
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
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+!
415 typeid
-method
-word
, ;; signature
416 current
-class
-def
, ;; info
-addr
417 current
-class
-def class
->vmt @ cells
, ;; offset
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
425 ;; save some state on rstack
, and setup new
426 : start
-class
-compiling
( -- )
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
!
437 ;; restore some state from rstack
438 : finish
-class
-compiling
( -- )
440 r
> compiler
:word
-redefine
-warn
-mode
!
441 r
> forth
:(new
-word
-flags
) !
446 : create
-@class
-accessor
( -- )
447 " @class" (create
) immediate
448 typeid
-@class
-word
, ;; signature
449 current
-class
-def
, ;; info
-addr
452 curr
-method
-def
-class
" not in method definition" ?not
-error
453 drop compile
(self
-@class
)
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
!)
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
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
!)
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
)
483 : (clx
-invoke
) ( inst
-addr ofs info
-addr invoker
-cfa
)
484 state @
if rot literal swap literal compile
,
490 ;; "TO" for obj
-values
491 ..: FORTH
:(TO-EXTENDER
-FOUND
) ( cfa FALSE
-- cfa FALSE
/ TRUE
)
493 dup cfa
->pfa fword
->typeid @ typeid
-objval
-word
= if
495 state @
if literal compile
(obj
-value
-!)
504 ;; "TO" for simple fields
505 ..: FORTH
:(TO-EXTENDER
-FOUND
) ( cfa FALSE
-- cfa FALSE
/ TRUE
)
507 dup cfa
->pfa fword
->typeid @ typeid
-field
-word
= if
509 curr
-method
-def
-class
" not in method definition" ?not
-error
510 cfa
->pfa
(field
-acc
-!)
517 ;; "TO" for obj
-value fields
518 ..: FORTH
:(TO-EXTENDER
-FOUND
) ( cfa FALSE
-- cfa FALSE
/ TRUE
)
520 dup cfa
->pfa fword
->typeid @ typeid
-objfield
-word
= if
522 curr
-method
-def
-class
" not in method definition" ?not
-error
523 cfa
->pfa
(objval
-acc
-!)
535 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
536 ;; vocabulary used in class definition
539 simple
-vocabulary oof
-creatori
540 also
-defs
: oof
-creatori
542 ;; finish class definition
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
551 previous
;; remove
"oof-creatori"
552 0 to current
-class
-def
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
561 current
-class
-def class
-inherit
-from
563 alias extends
: extend
:
566 ;; create field access word
(immediate
)
567 ;; "name" -- get field value
568 : field
: ( -- ) \ name
570 parse
-name dup
" field name expected" ?not
-error
571 start
-class
-compiling
572 ['] (field-acc-@) create-field-accessor
574 finish-class-compiling
578 ;; create field access word (immediate)
579 ;; "name" -- use as obj-value
580 : obj-value: ( info-addr -- ) \ name
582 dup if ?class-info endif
583 parse-name dup " field name expected" ?not-error
584 start-class-compiling rot >r
586 ['] (objval
-acc
-run
) create
-field
-accessor
587 r
> (finish
-objval
-field
-accessor
)
589 finish
-class
-compiling
592 ;; create method
call words
(immediate
)
593 ;; "name" -- execute method
594 : method
: ( -- ) \ name
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
600 finish
-class
-compiling
603 previous prev
-defs
;; at OOF
606 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
607 ;; vocabulary used in method definition
610 simple
-vocabulary oof
-mtdef
616 curr
-method
-def
-class
" not defining a method" ?not
-error
622 curr
-method
-def
-class
" not defining a method" ?not
-error
623 compile
(self
-@class
)
626 ;; call inherited method
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
)
636 : -> ( -- addr
) \ name
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
643 ;; must be the last one in this vocabulary
646 curr
-method
-def
-class
" not defining a method" ?not
-error
647 false
to curr
-method
-def
-class
648 previous previous
[compile
] forth
:;
652 previous prev
-defs
;; at OOF
656 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
657 ;; high
-level class creation words
661 : class
: ( -- ) \ name
662 ;; class word layout
:
663 ;; typeid
-class
-word
(signature
)
664 ;; info
-addr
(address of class info table
)
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
675 ;; we
're defining this class
677 ;; activate definition dictionary
683 : method: ( info-addr -- ) \ name
685 current-class-def " finish class definition first" ?error
686 curr-method-def-class " already defining a method" ?error
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
693 cfa->pfa dup fword->typeid @ typeid-method-word <> " trying to define non-method" ?error
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
701 also curr-method-def-class class->vocid@ context !
704 : method-cfa: ( info-addr -- cfa ) \ name
707 >r parse-name dup " method name expected" ?not-error
709 state @ if cfaliteral endif
713 : invoke-str ( inst-addr addr count -- )
714 state @ if compile (invoke-str)
719 : invoke-dyn: ( inst-addr -- ) \ name
720 parse-name dup " method name expected" ?not-error
721 state @ if strliteral endif
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)
738 \ bind-class classname oof:bind-field: <field>
739 : bind-field: ( bind-class info-addr -- ) \ name
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
751 : size-of ( info-addr -- instance-size )
752 ?class-info class->inst-size@
755 : name-of ( info-addr -- addr count )
756 ?class-info class->name@
759 : parent-of ( info-addr -- info-addr / 0 )
761 dup class->level@ dup if ( info-addr level )
762 1- cells swap class->iht + @
767 ;; init internal fields, zero other
768 : emplace ( info-addr addr -- )
769 >r dup size-of ( info-addr inst-size | addr )
771 typeid-instance r@ ! ;; signatire
772 r> cell+ ! ;; info-addr
775 : allot ( info-addr -- addr )
776 dup size-of n-allot ( info-addr addr )
780 : new ( info-addr -- addr )
781 dup size-of swap dup >r handle:new-alloc
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?) ;
790 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
794 : obj-value ( info-addr -- ) \ name
795 dup if ?class-info endif
797 ;; info-addr is second to keep it in line with other words
798 typeid-objval-word , ;; signature
802 >r parse-name dup " method name expected" ?not-error
803 r@ fword->info-addr @ (find-field-word) ( word-pfa | pfa )
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 )
810 literal compile @ ;; get value
812 typeid-method-word = if compile (vmt-call) else compile (field-read) endif
814 @ swap rot typeid-method-word = if ['] (vmt
-call) else ['] (field-read) endif
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)
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
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
841 previous prev-defs ;; at original