Sun Aug 30 16:12:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Allow deriving from multiple C++ classes.
hunk ./src/clos.lisp 124
+(defclass smoke-multi-superclass-mixin ()
+ ((extra-objects :reader extra-objects
+ :initarg :extra-objects)))
+
hunk ./src/clos.lisp 154
- &allow-other-keys)
+ direct-default-initargs &allow-other-keys)
hunk ./src/clos.lisp 157
- "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)
hunk ./src/clos.lisp 164
- "The first superclass must be an subclass of an smoke class.")
+ "The first superclass ~A must be an subclass of an Smoke class."
+ class)
hunk ./src/clos.lisp 168
- "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))
hunk ./src/clos.lisp 187
+ :direct-default-initargs direct-default-initargs
hunk ./src/clos.lisp 202
-
hunk ./src/clos.lisp 324
-;; Receive virutal function calls.
+;; Receive virtual function calls.
hunk ./src/clos.lisp 410
-(defun cast (object class)
- "Returns a pointer of type CLASS to the C++ object of OBJECT."
+(defgeneric cast (object class)
hunk ./src/clos.lisp 412
- (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)))))
hunk ./src/clos.lisp 449
-(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))))
hunk ./src/clos.lisp 479
- (call-constructor object [_$_]
+ (call-constructor (class-of object)
hunk ./src/clos.lisp 484
- (setf (slot-value object 'pointer) (call-constructor object args)))
+ (setf (slot-value object 'pointer)
+ (call-constructor (class-of object) args)))
hunk ./src/clos.lisp 490
+(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))))))
hunk ./src/clos.lisp 531
- (cerror "ignore" "~A has already been added to ~A."
+ (cerror "Ignore" "~A has already been added to ~A."
hunk ./src/object-map.lisp 95
+ ;; #'remove-object is called in the destructed callback. This
+ ;; happens even for objects without an virtual destructor.
hunk ./src/overload-resolution.lisp 121
-(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))))))
- [_$_]
hunk ./test.lisp 2
+echo \
+"################
+## Testing sbcl
+################"
hunk ./test.lisp 7
+echo \
+"###############
+## Testing sbcl image
+################"
hunk ./test.lisp 12
+echo \
+"###############
+## Testing ccl [_$_]
+################"