OOP: implementing multiple inheritance.

Multiple inheritance is too useful to ignore any longer.

* lib.c (subtypep): Perform subtypep calculation between two
struct types via the new struct_subtype_p function.
It's too complicated now to do with ad hoc code outside of
struct.c.

* share/txr/stdlib/struct.tl (defstruct): This macro now needs
to deal with the super argument being possibly a list of base
types instead of a single one.

* strut.c (struct struct_type): Member super and super_handle
are removed. New member nsupers, supers, and sus.
(struct_init): The super function re-registered; it has an
optional argument.
(call_stinitfun_chain): The compat code here must now access
the supertype differently. We don't bother dealing with
multiple inheritance in the compat case; programs requesting
compatibility with TXR 151 shoudn't be trying to use multiple
inheritance.
(get_struct_handles, count_super_stslots, get_super_slots,
find_super_for_slot): New static functions, to off-load some
new complexity from make_struct_type.
(make_struct_type): Handle the increased complexity due to
multiple inheritance.
(super): Takes an additional argument now, to request which
supertype to retrieve. Defaults to zero: the first one.
(struct_type_destroy): Free the sus array.
(struct_type_mark): Mark the supers slot.
(call_initfun_chain): Call init functions of all bases, in
right-to-left order.
(call_postinitfun_chain): Likewise for postinit functions.
(call_super_method, call_super_fun, super_method): Use the
first base as the supertype.  This requirement feels bad; it
needs to be revisited.
(do_struct_subtype_p): New static function.
(struct_subtype_p): New function.
(ancestor_with_static_slot): New static function.
(method_name): Revised for multiple inheritance; now relies on
ancestor_with_static_slot to find the original ancestor that
has brought in a method, so we can use that type in the
method name.

* struct.h (super): Declaration updated.
(struct_subtype_p): Declared.

* tests/012/oop-mi.expected: New file.

* tests/012/oop-mi.tl: New test cases.

* txr.1: Revised in order to document multiple inheritance.

1 files changed, 11 insertions, 8 deletions

diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
index 71bcf45b..0461cd05 100644
--- a/share/txr/stdlib/struct.tl
+++ b/share/txr/stdlib/struct.tl
@@ -33,7 +33,7 @@
                     (not init-form-present)))
              slot-init-forms))
 
-(defmacro defstruct (:form form name-spec super . slot-specs)
+(defmacro defstruct (:form form name-spec super-spec . slot-specs)
   (tree-bind (name args) (tree-case name-spec
                            ((atom . args) (list atom args))
                            (atom (list atom nil)))
@@ -111,12 +111,9 @@
                                   ^(:instance ,name nil))
                                 (name
                                   ^(:instance ,name nil)))))
-           (super-type (if super
-                         (or (find-struct-type super)
-                             (compile-defr-warning form ^(struct-type . ,super)
-                                                   "inheritance base ~s \
-                                                   \ does not name a struct type"
-                                                   super))))
+           (supers (if (and super-spec (atom super-spec))
+                     (list super-spec)
+                     super-spec))
            (stat-si-forms [keep-if (op member @1 '(:static :function))
                                    slot-init-forms car])
            (pruned-si-forms (sys:prune-missing-inits stat-si-forms))
@@ -132,6 +129,12 @@
                          "slot name ~s isn't a bindable symbol"
                          "invalid slot specifier syntax: ~s")
                        bad))
+      (each ((s supers))
+        (or (find-struct-type s)
+            (compile-defr-warning form ^(struct-type . ,s)
+                                  "inheritance base ~s \
+                                  \ does not name a struct type"
+                                  s)))
       (let ((arg-sym (gensym))
             (type-sym (gensym)))
         (register-tentative-def ^(struct-type . ,name))
@@ -140,7 +143,7 @@
         (each ((s inst-slots))
           (register-tentative-def ^(slot . ,s)))
         ^(sys:make-struct-type
-           ',name ',super ',stat-slots ',inst-slots
+           ',name ',supers ',stat-slots ',inst-slots
            ,(if (or func-si-forms val-si-forms)
                ^(lambda (,arg-sym)
                   ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)