src/clos.lisp
Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cleanup C++ to Lisp translation
--- old-smoke/src/clos.lisp 2014-10-30 08:11:49.000000000 +0100
+++ new-smoke/src/clos.lisp 2014-10-30 08:11:49.000000000 +0100
@@ -9,7 +9,6 @@
(values (intern (cxx-to-lisp name)))
(values (intern (cxx-to-lisp name) package))))
-
(defmacro define-string-transform (name documentation &body states)
"Defines a function to transform a string."
(let ((output (gensym))
@@ -120,51 +119,33 @@
()
(:documentation "Metaclass to extend Smoke Objects."))
-(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))
+(defmethod closer-mop:validate-superclass ((class smoke-standard-class)
+ (superclass standard-class))
t)
-(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))
+(defmethod closer-mop:validate-superclass ((class cxx:class)
+ (superclass smoke-standard-class))
t)
-(defmethod reinitialize-instance :around
- ((class smoke-standard-class)
- &rest args &key direct-superclasses &allow-other-keys)
- (apply
- #'call-next-method class
- :direct-superclasses (or direct-superclasses
- (list (find-class
- 'smoke-standard-object))) args))
-
-(defmethod initialize-instance :around
- ((class smoke-standard-class)
- &rest args &key direct-superclasses &allow-other-keys)
- "Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default STANDARD-OBJECT."
- (apply
- #'call-next-method class
- :direct-superclasses (or direct-superclasses
- (list (find-class 'smoke-standard-object)))
- args))
-
-(defmethod reinitialize-instance :around
- ((class cxx:class)
- &rest args &key direct-superclasses &allow-other-keys)
- (assert (not (null direct-superclasses))
- (direct-superclasses)
- "No superclass supplied for class ~A" class)
- (let ((superclass (first direct-superclasses)))
- (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))
- ((first direct-superclasses))
- "The first superclass must be an subclass of an smoke class.")
- (apply
- #'call-next-method class
- :id (id superclass)
- :smoke (smoke superclass)
- :direct-superclasses direct-superclasses
- args)))
+;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default
+;; STANDARD-OBJECT.
+(defun init-smoke-standard-class (class next-method
+ &rest args &key direct-superclasses
+ &allow-other-keys)
+ (apply next-method class
+ :direct-superclasses (or direct-superclasses
+ (list (find-class 'smoke-standard-object)))
+ args))
+
+(defmethod initialize-instance :around ((class smoke-standard-class) &rest args)
+ (apply #'init-smoke-standard-class class #'call-next-method args))
+
+(defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)
+ (apply #'init-smoke-standard-class class #'call-next-method args))
+
-(defmethod initialize-instance :around
- ((class cxx:class)
- &rest args &key direct-superclasses &allow-other-keys)
+(defun init-cxx-class (class next-method &rest args &key direct-superclasses
+ &allow-other-keys)
(assert (not (null direct-superclasses))
(direct-superclasses)
"No superclass sup-lied for class ~A" class)
@@ -175,14 +156,19 @@
(assert (virtual-destructor-p superclass)
()
"The class ~A has a non virtual destructor." superclass)
-
(apply
- #'call-next-method class
+ next-method class
:id (id superclass)
:smoke (smoke superclass)
:direct-superclasses direct-superclasses
args)))
+(defmethod reinitialize-instance :around ((class cxx:class) &rest args)
+ (apply #'init-cxx-class class #'call-next-method args))
+
+(defmethod initialize-instance :around ((class cxx:class) &rest args)
+ (apply #'init-cxx-class class #'call-next-method args))
+
(defun smoke-class-symbol (smoke-class)
"Returns the Lisp class-name of SMOKE-CLASS:"
(if (external-p smoke-class)
@@ -248,6 +234,9 @@
((object-pointer :pointer))
(declare (optimize (speed 3)))
(let ((object (get-object object-pointer)))
+ ;; The destructed callback can be the result of deleting the object
+ ;; in a finalizer. In that case the object is already removed from
+ ;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.
(when object
(remove-finalizer object)
(remove-object object-pointer)
@@ -256,6 +245,7 @@
(declaim (inline argument-to-lisp))
(defun argument-to-lisp (stack-item type)
;; FIXME do not take ownership of stack allocated objects.
+ ;; It looks like there is no stack allocation in Qt virtual method signatures.
(type-to-lisp stack-item type))
(defun stack-to-args (stack arg &optional (args nil))
@@ -266,8 +256,7 @@
(stack-to-args (inc-pointer stack
(foreign-type-size 'smoke-stack-item))
(next arg)
- (push (argument-to-lisp (mem-ref stack
- 'smoke-stack-item)
+ (push (argument-to-lisp (mem-ref stack 'smoke-stack-item)
arg)
args))))
@@ -295,13 +284,15 @@
(when (stack-p type) ;; Pass by value => smoke deletes the object.
(remove-finalizer converted-value)
(when (typep value 'smoke-standard-object)
- (transfer-ownership-to value object)))))))
+ (remove-object (pointer value))))))))
+ ; (transfer-ownership-to value object)))))))
(defun get-gf-for-method (smoke-method)
(declare (smoke-method smoke-method)
(optimize (speed 3)))
(symbol-function (lispify (name smoke-method) "CXX")))
+;; Receive virutal function calls.
(defcallback dispatch-method :boolean
((binding :pointer)
(method smoke-index)
@@ -310,82 +301,81 @@
(abstract :boolean))
(declare (optimize (speed 3)))
(let ((object (get-object object-ptr)))
- ;; FIXME:
- ;;(assert object
- ;; (object)
- ;; "No object for ~A to call ~A." object-ptr method)
- (if (and object (typep (class-of object) 'cxx:class))
- ;; Do not allow overwriting methods of classes the users has
- ;; not derived from (like in C++), to reduce overhead.
- (let* ((method (make-smoke-method
- :smoke (gethash (pointer-address
- (smoke-get-smoke binding))
- *smoke-modules*)
- :id method)))
- (loop
- (restart-case
- (return-from dispatch-method
- (let ((gf (get-gf-for-method method)))
- (declare (function gf))
- (if (null (gf-methods gf))
- (progn
- (when abstract
- (error "Abstract method ~A called."
- (method-declaration method)))
- nil)
- (if object
- (progn
- (put-returnvalue stack
- (apply gf object
- (stack-to-args
- (inc-pointer stack
- (foreign-type-size
- 'smoke-stack-item))
- (get-first-argument method)))
- (return-type method)
- object)
- t)
- nil))))
- ;; Restarts to prevent stack unwinding across the C++ stack.
- (call-default ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Call default implementation ~A instead."
- method))
- :test (lambda (condition)
- (declare (ignore condition))
- (not abstract))
- (return-from dispatch-method nil))
- (use-returnvalue (return-value)
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Supply a return value for ~A."
- (method-declaration method)))
- :test (lambda (condition)
- (declare (ignore condition))
- (not (void-p (return-type method))))
- :interactive (lambda ()
- (format *query-io* "~&Enter a new return value: ")
- (multiple-value-list (eval (read *query-io*))))
- (put-returnvalue stack return-value
- (return-type method)
- (get-object object-ptr))
- (return-from dispatch-method t))
- (return ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Return void for ~A."
- (method-declaration method)))
- :test (lambda (condition)
- (declare (ignore condition))
- (void-p (return-type method)))
- (return-from dispatch-method (values)))
- (retry ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Try again calling ~A."
- (method-declaration method))))))
- nil))))
+ ;; The Lisp OBJECT can be gc'ed but we might still receive a
+ ;; QObject destructed event when the C++ instance is deleted in
+ ;; the finalizer. Thus OBJECT might be NIL.
+ (when (and object (typep (class-of object) 'cxx:class))
+ ;; Do not allow overwriting methods of classes the users has
+ ;; not derived from (like in C++), to reduce overhead.
+ (let* ((method (make-smoke-method
+ :smoke (gethash (pointer-address
+ (smoke-get-smoke binding))
+ *smoke-modules*)
+ :id method)))
+ (loop
+ (restart-case
+ (return-from dispatch-method
+ (let ((gf (get-gf-for-method method)))
+ (declare (function gf))
+ (if (null (gf-methods gf))
+ (progn
+ (when abstract
+ (error "Abstract method ~A of ~A called."
+ (method-declaration method) object))
+ nil)
+ (if object
+ (progn
+ (put-returnvalue
+ stack
+ (apply gf object
+ (stack-to-args
+ (inc-pointer stack (foreign-type-size
+ 'smoke-stack-item))
+ (get-first-argument method)))
+ (return-type method) object)
+ t)
+ nil))))
+ ;; Restarts to prevent stack unwinding across the C++ stack.
+ (call-default ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream
+ "Call default implementation ~A instead."
+ method))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not abstract))
+ (return-from dispatch-method nil))
+ (use-returnvalue (return-value)
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Supply a return value for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not (void-p (return-type method))))
+ :interactive (lambda ()
+ (format *query-io* "~&Enter a new return value: ")
+ (multiple-value-list (eval (read *query-io*))))
+ (put-returnvalue stack return-value
+ (return-type method)
+ (get-object object-ptr))
+ (return-from dispatch-method t))
+ (return ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Return void for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (void-p (return-type method)))
+ (return-from dispatch-method (values)))
+ (retry ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Try again calling ~A."
+ (method-declaration method))))))
+ nil))))
;;FIXME use CHANGE-CLASS instead?
(defun cast (object class)
@@ -408,9 +398,7 @@
(id (class-of object)) (id (real-class class))))
-(defmethod convert-to-class (smoke-class (object smoke-standard-object))
- (cast object smoke-class))
-
+;; The constructor name is the name of the class minus any namespace parts.
(defun constructor-name (class)
(let ((name-start (search "::" (name class) :from-end t)))
(if name-start
@@ -478,8 +466,8 @@
(declare (type smoke-standard-object object)
(optimize (speed 3)))
(when (member object (owned-objects new-owner))
- (cerror "ignore" "~A has already been called for ~A."
- #'keep-wrapper object))
+ (cerror "ignore" "~A has already been added to ~A."
+ object new-owner))
(push object (owned-objects new-owner)))
(declaim (inline remove-wrapper-object))