summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2019-12-12 18:10:17 -0800
committerKaz Kylheku <kaz@kylheku.com>2019-12-13 08:19:53 -0800
commitb1fe95fef05b7e8d26ff82645d373c2ef0b5c449 (patch)
tree7220391285ce26f06a969d7087396275e50d2e46
parent2eaa8bdbb3a6d426a9de4d916dad63f77fd54092 (diff)
downloadtxr-b1fe95fef05b7e8d26ff82645d373c2ef0b5c449.tar.gz
txr-b1fe95fef05b7e8d26ff82645d373c2ef0b5c449.tar.bz2
txr-b1fe95fef05b7e8d26ff82645d373c2ef0b5c449.zip
multiple-inheritance: super-method loose ends.
* struct.c (do_super): New function. Now the common implementation for call_super_method, call_super_fun and super_method. (call_super_method, call_super_fun): Reduced to small wrappers around do_super. (super_method): Drill into the object to geet the struct_type handle, and then use do_super to get the method. * tests/012/oop-mi.tl: New tests for call-super-fun and call-super-method. * tests/012/oop-mi.expected: Updated. * txr.1: Updated.
-rw-r--r--struct.c71
-rw-r--r--tests/012/oop-mi.expected6
-rw-r--r--tests/012/oop-mi.tl24
-rw-r--r--txr.127
4 files changed, 87 insertions, 41 deletions
diff --git a/struct.c b/struct.c
index d549a869..f68585e3 100644
--- a/struct.c
+++ b/struct.c
@@ -1396,39 +1396,56 @@ val static_slot_home(val stype, val sym)
no_such_static_slot(self, stype, sym);
}
-static val call_super_method(val inst, val sym, struct args *args)
+static val do_super(struct struct_type *st,
+ val inst, val sym, val self,
+ struct args *args)
{
- val type = struct_type(inst);
- val suptype = super(type, zero);
+ val type = st->self;
+ cnum i;
- if (suptype) {
- val meth = static_slot(suptype, sym);
- args_decl(args_copy, max(args->fill + 1, ARGS_MIN));
- args_add(args_copy, inst);
- args_cat_zap(args_copy, args);
- return generic_funcall(meth, args_copy);
+ for (i = 0; i < st->nsupers; i++) {
+ struct struct_type *su = st->sus[i];
+ loc ptr = lookup_static_slot_load(su, sym);
+ if (!nullocp(ptr)) {
+ val meth = deref(ptr);
+ if (inst == t) {
+ return meth;
+ } else if (inst) {
+ args_decl(args_copy, max(args->fill + 1, ARGS_MIN));
+ args_add(args_copy, inst);
+ args_cat_zap(args_copy, args);
+ return generic_funcall(meth, args_copy);
+ } else {
+ return generic_funcall(meth, args);
+ }
+ }
}
- uw_throwf(error_s, lit("call-super-method: ~s has no supertype"),
- suptype, nao);
+ if (st->nsupers)
+ if (bindable(sym))
+ uw_throwf(error_s, lit("~s: slot ~s not found among supertypes of ~s"),
+ self, sym, type, nao);
+ else
+ uw_throwf(error_s, lit("~s: ~s isn't a valid slot name"),
+ self, sym);
+ else
+ uw_throwf(error_s, lit("~s: ~s has no supertype"),
+ type, nao);
+}
+
+static val call_super_method(val inst, val sym, struct args *args)
+{
+ val type = struct_type(inst);
+ val self = lit("call-super-method");
+ struct struct_type *st = stype_handle(&type, self);
+ return do_super(st, inst, sym, self, args);
}
static val call_super_fun(val type, val sym, struct args *args)
{
val self = lit("call-super-fun");
struct struct_type *st = stype_handle(&type, self);
-
- if (st->nsupers) {
- val suptype = st->sus[0]->self;
-
- if (suptype) {
- val fun = static_slot(suptype, sym);
- return generic_funcall(fun, args);
- }
- }
-
- uw_throwf(error_s, lit("~a: ~s has no supertype"),
- self, type, nao);
+ return do_super(st, nil, sym, self, args);
}
val slotp(val type, val sym)
@@ -1540,11 +1557,13 @@ val method_args(val strct, val slotsym, struct args *args)
cons(slot(strct, slotsym), strct)), method_args_fun);
}
-
val super_method(val strct, val slotsym)
{
- val super_slot = static_slot(super(struct_type(strct), zero), slotsym);
- return func_f0v(cons(super_slot, strct), method_fun);
+ val type = struct_type(strct);
+ val self = lit("super-method");
+ struct struct_type *st = stype_handle(&type, self);
+ val meth = do_super(st, t, slotsym, self, 0);
+ return func_f0v(cons(meth, strct), method_fun);
}
static val uslot_fun(val sym, val strct)
diff --git a/tests/012/oop-mi.expected b/tests/012/oop-mi.expected
index 91bc05df..301c7460 100644
--- a/tests/012/oop-mi.expected
+++ b/tests/012/oop-mi.expected
@@ -6,3 +6,9 @@ gs0
gs1-b1
(meth base3 b3m0)
(meth der1 b3m1)
+m1
+m2
+gm
+m1
+m2
+gm
diff --git a/tests/012/oop-mi.tl b/tests/012/oop-mi.tl
index 162c0243..7561d096 100644
--- a/tests/012/oop-mi.tl
+++ b/tests/012/oop-mi.tl
@@ -4,17 +4,21 @@
(gx 'gx)
(gy 'gy)
(:static gs0 'gs0)
- (:static gs1 'gs1))
+ (:static gs1 'gs1)
+ (:method gm (me) 'gm))
-(defstruct base0 nil)
+(defstruct base0 nil
+ (:method m (me) 'm0))
(defstruct base1 grand
(x 'b1x)
- (:static gs1 'gs1-b1))
+ (:static gs1 'gs1-b1)
+ (:method m (me) 'm1))
(defstruct base2 grand
(y 'b2y)
- (:static gs1 'gs1-b2))
+ (:static gs1 'gs1-b2)
+ (:method m (me) 'm2))
(defstruct base3 nil
(x 'b3x)
@@ -45,3 +49,15 @@
(prinl (func-get-name d0.b3m0))
(prinl (func-get-name d1.b3m1))
+
+(defstruct der2 (base3 base1 base2))
+(defstruct der3 (base3 base2 base1))
+
+(prinl (call-super-method (new der2) 'm))
+(prinl (call-super-method (new der3) 'm))
+(prinl (call-super-method (new der3) 'gm))
+(prinl (call-super-fun 'der2 'm nil))
+(prinl (call-super-fun 'der3 'm nil))
+(prinl (call-super-fun 'der3 'gm nil))
+
+
diff --git a/txr.1 b/txr.1
index 1954eaf5..46e81355 100644
--- a/txr.1
+++ b/txr.1
@@ -27442,7 +27442,7 @@ the slot name isn't a computed value.
The
.code super-method
function retrieves a function from a static
-slot belonging to the supertype of the structure type of
+slot belonging to one of the direct supertypes of the structure type of
.metn struct-obj .
It then returns a function which binds
@@ -27450,11 +27450,14 @@ that function's left argument to the structure.
The
.meta struct-obj
-argument must be a structure which has a supertype, and
+argument must be a structure which has at least one supertype, and
.meta slot-name
-must be a symbol denoting a static slot in that supertype.
+must be a symbol denoting a static slot in one of those supertypes.
The slot must hold a function of at least one
-argument.
+argument. The supertypes are searched from left to right for a static
+slot named
+.metn slot-name ;
+when the first such slot is found, its value is used.
The
.code super-method
@@ -27768,9 +27771,9 @@ should be reworked in terms of
The
.code call-super-method
-retrieves the function stored in the slot
+retrieves the function stored in the static slot
.meta name
-of the supertype of
+of one of the direct supertypes of
.meta struct-obj
and invokes it, passing to that function
.meta struct-obj
@@ -27781,10 +27784,11 @@ if any.
The
.meta struct-obj
argument must be of structure type. Moreover,
-that structure type must be derived from another structure type,
+that structure type must be derived from one or more supertypes,
and
.meta name
-must name a static slot of that structure type.
+must name a static slot available from at least one of those supertypes.
+The supertypes are searched left to right in search of this slot.
The object retrieved from that static slot must be
callable as a function, and accept the arguments.
@@ -27808,7 +27812,7 @@ The
.code call-super-fun
retrieves the function stored in the slot
.meta name
-of the supertype of
+of one of the supertypes of
.meta type
and invokes it, passing to that function the given
.metn argument -s,
@@ -27817,10 +27821,11 @@ if any.
The
.meta type
argument must be a structure type. Moreover,
-that structure type must be derived from another structure type,
+that structure type must be derived from one or more supertypes,
and
.meta name
-must name a static slot of that structure type.
+must name a static slot available from at least one of those supertypes.
+The supertypes are searched left to right in search of this slot.
The object retrieved from that static slot must be
callable as a function, and accept the arguments.