Sun Aug 30 16:12:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Allow deriving from multiple C++ classes.

--- old-smoke/src/clos.lisp 2014-10-11 08:01:24.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-10-11 08:01:25.000000000 +0200

@@ -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)))

--- old-smoke/src/object-map.lisp 2014-10-11 08:01:24.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-10-11 08:01:25.000000000 +0200

@@ -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))))))

--- old-smoke/src/overload-resolution.lisp 2014-10-11 08:01:24.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-10-11 08:01:25.000000000 +0200

@@ -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)

--- old-smoke/test.lisp 2014-10-11 08:01:24.000000000 +0200

+++ new-smoke/test.lisp 2014-10-11 08:01:25.000000000 +0200

@@ -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