Sun Aug 30 16:12:44 CEST 2009  Tobias Rautenkranz <tobias@rautenkranz.ch>
  * Allow deriving from multiple C++ classes.
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp	2014-10-30 08:10:53.000000000 +0100
+++ new-smoke/src/clos.lisp	2014-10-30 08:10:53.000000000 +0100
@@ -121,6 +121,10 @@
   ()
   (:documentation "Metaclass to extend Smoke Objects."))
 
+(defclass smoke-multi-superclass-mixin ()
+  ((extra-objects :reader extra-objects
+                  :initarg :extra-objects)))
+
 (defmethod closer-mop:validate-superclass ((class smoke-standard-class)
                                            (superclass standard-class))
   t)
@@ -147,22 +151,40 @@
 
 
 (defun init-cxx-class (class next-method &rest args &key direct-superclasses
-                       &allow-other-keys)
+                       direct-default-initargs &allow-other-keys)
   (assert (not (null direct-superclasses))
           (direct-superclasses)
-          "No superclass sup-lied for class ~A" class)
-  (let ((superclass (first direct-superclasses)))
-    (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))
+          "No superclass supplied for class ~A" class)
+  (let ((superclass (first direct-superclasses))
+        (extra-superclasses (remove-if-not #'(lambda (class)
+                                               (typep class 'smoke-standard-class))
+                                           (rest direct-superclasses))))
+    (assert (typep superclass 'smoke-standard-class)
             ((first direct-superclasses))
-            "The first superclass must be an subclass of an smoke class.")
+            "The first superclass ~A must be an subclass of an Smoke class."
+            class)
     (assert (virtual-destructor-p superclass)
             ()
-            "The class ~A has a non virtual destructor." superclass)
+            "The superclass ~A of ~A has a non virtual destructor."
+            superclass class)
+    (when extra-superclasses
+      (dolist (superclass extra-superclasses)
+        (unless (virtual-destructor-p superclass)
+          (cerror "Continue anyway"
+                  "The superclass ~A of ~A has a non virtual destructor."
+                  superclass class)))
+      (setf direct-superclasses
+            (append direct-superclasses
+                    (list (find-class 'smoke-multi-superclass-mixin))))
+      (push `(:extra-objects ,extra-superclasses ,#'(lambda ()
+                                                      extra-superclasses))
+            direct-default-initargs))
     (apply
      next-method class
      :id (id superclass)
      :smoke (smoke superclass)
      :direct-superclasses direct-superclasses
+     :direct-default-initargs direct-default-initargs
      args)))
 
 (defmethod reinitialize-instance :around ((class cxx:class) &rest args)
@@ -177,7 +199,6 @@
       (class-name (find-smoke-class smoke-class))
       (lispify (name smoke-class))))
 
-
 (defun make-smoke-classes (package smoke)
   "Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE."
   (declare (optimize (speed 3)))
@@ -300,7 +321,7 @@
            (optimize (speed 3)))
   (symbol-function (lispify (name smoke-method) "CXX")))
 
-;; Receive virutal function calls.
+;; Receive virtual function calls.
 (defcallback dispatch-method :boolean
     ((binding :pointer)
      (method smoke-index)
@@ -386,16 +407,28 @@
         nil))))
 
 ;;FIXME use CHANGE-CLASS instead?
-(defun cast (object class)
-  "Returns a pointer of type CLASS to the C++ object of OBJECT."
+(defgeneric cast (object class)
   (declare (optimize (speed 3)))
-  (assert (derived-p (class-of object) class)
-          ()
-          "Can not cast object ~A of class ~A to class ~A."
-          object (name (class-of object)) (name class))
-  (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)
-              (id (class-of object)) (id class)))
-
+  (:documentation "Returns a pointer of type CLASS to the C++ object of OBJECT.")
+  (:method (object class)
+    (declare (optimize (speed 3)))
+    (assert (derived-p (class-of object) class)
+            ()
+            "Can not cast object ~A of class ~A to class ~A."
+            object (name (class-of object)) (name class))
+    (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)
+                (id (class-of object)) (id class)))
+  (:method ((object smoke-multi-superclass-mixin) class)
+    (if (derived-p (class-of object) class)
+        (call-next-method)
+        (let ((extra-object (find-if #'(lambda (o)
+                                         (derived-p (class-of o) class))
+                                     (extra-objects object))))
+          (assert extra-object
+                  ()
+                  "Can not cast object ~A to class ~A."
+                  object (name class))
+          (cast extra-object class)))))
 
 (defun upcast (object class)
   (assert (derived-p class (class-of object))
@@ -413,25 +446,18 @@
         (subseq (name class) (+ name-start 2))
         (name class))))
 
-(defun call-constructor (object arguments)
-  (if (null arguments)
-      (let ((method (find-smoke-method (class-of object)
-                                       (constructor-name (class-of object)))))
-        (assert (valid-p method)
-                (method)
-                "No constructor for ~A." object)
-        (pointer-call method (null-pointer)))
-      (multiple-value-bind (method sequence)
-          (find-best-viable-function (constructor-name (class-of object))
-                                     arguments
-                                     (class-of object))
-        (when (null method)
-          (error "No constructor for object ~A with
-the arguments ~S." object arguments))
-        (pointer-call method (null-pointer)
-                      (mapcar #'(lambda (conversion argument)
-                                  (funcall conversion argument))
-                              sequence arguments)))))
+(defun call-constructor (class arguments)
+  (multiple-value-bind (method sequence)
+      (find-best-viable-function (constructor-name class)
+                                 arguments
+                                 class)
+    (when (null method)
+      (error "No constructor for class ~A with
+the arguments ~S." class arguments))
+    (pointer-call method (null-pointer)
+                  (mapcar #'(lambda (conversion argument)
+                              (funcall conversion argument))
+                          sequence arguments))))
 
 (defmethod initialize-instance :after ((object smoke-standard-object) 
                                        &key args
@@ -450,16 +476,43 @@
   (unless (slot-boundp object 'pointer)
     (if arg0p
         (setf (slot-value object 'pointer) 
-              (call-constructor object 
+              (call-constructor (class-of object)
                                 (cond
                                   (arg2p (list arg0 arg1 arg2))
                                   (arg1p (list arg0 arg1))
                                   (t (list arg0)))))
-        (setf (slot-value object 'pointer) (call-constructor object args)))
+        (setf (slot-value object 'pointer)
+              (call-constructor (class-of object) args)))
     (set-binding object)
     (take-ownership object)
     (add-object object)))
 
+(defun construct-extra-objects (object extra-objects)
+  (loop for class in extra-objects
+     collect (let ((extra-object (make-instance (first extra-objects)
+                                                :pointer (call-constructor (first extra-objects)
+                                                                           nil))))
+               (set-binding extra-object)
+               (setf (get-object (pointer extra-object)) object)
+               extra-object)))
+                            
+(defmethod initialize-instance :after ((object smoke-multi-superclass-mixin) 
+                                       &key args)
+  (setf (slot-value object 'extra-objects)
+        (construct-extra-objects object (extra-objects object))))
+
+(defmethod make-finalize ((object smoke-multi-superclass-mixin))
+  (let ((pointer (pointer object))
+        (extra-objects (extra-objects object))
+        (class (class-of object)))
+    #'(lambda ()
+        (declare (optimize (speed 3)))
+        (handler-case (progn
+                        (delete-pointer pointer class)
+                        (dolist (object extra-objects)
+                          (delete-object object)))
+          (error (condition)
+            (report-finalize-error condition 't (name class) pointer))))))
 
 (defmethod instance-to-lisp (pointer class type)
   (declare (type smoke-standard-class class)
@@ -475,7 +528,7 @@
   (declare (type smoke-standard-object object)
            (optimize (speed 3)))
   (when (member object (owned-objects new-owner))
-    (cerror "ignore" "~A has already been added to ~A."
+    (cerror "Ignore" "~A has already been added to ~A."
             object new-owner))
   (push object (owned-objects new-owner)))
 
diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp
--- old-smoke/src/object-map.lisp	2014-10-30 08:10:53.000000000 +0100
+++ new-smoke/src/object-map.lisp	2014-10-30 08:10:53.000000000 +0100
@@ -92,6 +92,8 @@
         (class (class-of object)))
     #'(lambda ()
         (declare (optimize (speed 3)))
+        ;; #'remove-object is called in the destructed callback. This
+        ;; happens even for objects without an virtual destructor.
         (handler-case (delete-pointer pointer class)
           (error (condition)
             (report-finalize-error condition 't (name class) pointer))))))
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp	2014-10-30 08:10:53.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp	2014-10-30 08:10:53.000000000 +0100
@@ -118,14 +118,6 @@
                      (push ,method ,methods))))
              t)))))
 
-(defun all-smoke-superclasses (class)
-  "Returns a list of all super-classes of CLASS and CLASS itself."
-  (declare (optimize (speed 3)))
-  (let ((classes (list class)))
-    (dolist (class (closer-mop:class-direct-superclasses class) classes)
-      (when (typep class 'smoke-standard-class)
-        (setf classes (append (all-smoke-superclasses class) classes))))))
-    
 (defun viable-functions (name argument-count class &optional const-p)
   (declare (optimize (speed 3)))
   (with-foreign-string (name name)
diff -rN -u old-smoke/test.lisp new-smoke/test.lisp
--- old-smoke/test.lisp	2014-10-30 08:10:53.000000000 +0100
+++ new-smoke/test.lisp	2014-10-30 08:10:53.000000000 +0100
@@ -1,6 +1,18 @@
 #|
+echo \
+"################
+## Testing sbcl
+################"
 MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1
+echo \
+"###############
+## Testing sbcl image
+################"
 sh ./test-bundle.sh || exit 2
+echo \
+"###############
+## Testing ccl 
+################"
 ccl --batch --quiet --load $0  || exit 3
 exit 0
 # do not use --script to allow loading mudballs with ${HOME}/.sbclrc