Sat Apr 3 14:04:39 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Make the slot-* functions work for C++ class attributes.

Allow slot-value to be used to access C++ member variables of objects.

--- old-smoke/src/objects/stack.lisp 2014-10-30 07:04:59.000000000 +0100

+++ new-smoke/src/objects/stack.lisp 2014-10-30 07:04:59.000000000 +0100

@@ -140,13 +140,17 @@

(let ((class (get-class type)))

(if (has-pointer-p object)

(if (derived-p (class-of (get-object object))

- (get-class type))

+ (get-class type))

(get-object object)

(progn

- (cerror "Remove the old object."

- "The object at pointer ~A is ~A but should be a ~A."

- object (get-object object) type)

- (remove-object object)

+ (when (stack-p type)

+ ;; The first member varible of a class can have the

+ ;; same address as its object.

+ ;; e.g.: QSharedData::ref

+ (cerror "Remove the old object."

+ "The object at pointer ~A is ~A but should be a ~A."

+ object (get-object object) type)

+ (remove-object object))

(instance-to-lisp object (find-smoke-class class) type)))

(instance-to-lisp object (find-smoke-class class) type))))

--- old-smoke/src/overload-resolution.lisp 2014-10-30 07:04:59.000000000 +0100

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:04:59.000000000 +0100

@@ -529,7 +529,6 @@

(condition-class condition)

(condition-arguments condition)))))

-

(defun call-using-args (object-or-class name arguments)

"Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."

(declare (optimize (speed 3))

@@ -554,3 +553,28 @@

(null-pointer)

(cast object-or-class (get-class method)))

sequence arguments)))

+

+(defmethod slot-missing ((class smoke-standard-class) object slot-name operation &optional new-value)

+ (let ((method (find-smoke-method (class-of object) (lisp-to-cxx (string slot-name)))))

+ (if (not (valid-p method))

+ (call-next-method)

+ (ecase operation

+ (setf

+ (handler-case (funcall (fdefinition

+ (intern

+ (concatenate 'string "SET-"

+ (string-upcase

+ (string slot-name)))

+ :cxx))

+ object new-value)

+ (undefined-function ()

+ (error "The C++ attribute ~A of ~A is read only." slot-name object))

+ (no-applicable-cxx-method (condition)

+ (if (null (viable-functions (condition-method condition)

+ (length (condition-arguments condition))

+ (condition-class condition)))

+ (error "The C++ attribute ~A of ~A is read only." slot-name object)

+ (error condition)))))

+ (slot-boundp t)

+ (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name object))

+ (slot-value (s-call method (cast object (get-class method))))))))