Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup C++ to Lisp translation

- ("translate" (:needs "package"))

- ("method" (:needs "clos" "overload-resolution"))

+ ("smoke-to-clos" (:needs "clos" "overload-resolution"))

- (:needs "smoke-c" "utils")

+ (:needs "smoke-c" "utils" "bindings")

- (:needs "package" "translate")

+ (:needs "package")

-(defvar *bindings* (make-hash-table))

+(defvar *bindings* (make-hash-table)

+ "The Smoke C++ binding classes to which virtual method calls are dispatched.")

+ "A C array."

-(defvar *smoke-modules* (make-hash-table))

+(defvar *smoke-modules* (make-hash-table)

+ "All loaded Smoke modules.")

-

- (assert value [_$_]

- ()

+ (assert value ()

- (setf (gethash (pointer-address (smoke-module-pointer smoke)) *smoke-id-class-map*)

+ (setf (gethash (pointer-address (smoke-module-pointer smoke))

+ *smoke-id-class-map*)

- (setf (id-class-map smoke)

- (make-hash-table)))

+ (setf (id-class-map smoke) (make-hash-table)))

- (setf (gethash (id smoke-class)

- (id-class-map (smoke smoke-class)))

+ (setf (gethash (id smoke-class) (id-class-map (smoke smoke-class)))

- (ret (gethash (id class)

- (id-class-map (smoke class)))))

+ (ret (gethash (id class) (id-class-map (smoke class)))))

-

-(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))

+(defmethod closer-mop:validate-superclass ((class smoke-standard-class)

+ (superclass standard-class))

-(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))

+(defmethod closer-mop:validate-superclass ((class cxx:class)

+ (superclass smoke-standard-class))

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

+;; 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 &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 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 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)))

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

- [_$_]

- #'call-next-method class

+ next-method class

+(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))

+

+ ;; 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.

+ ;; It looks like there is no stack allocation in Qt virtual method signatures.

- (push (argument-to-lisp (mem-ref stack

- 'smoke-stack-item)

+ (push (argument-to-lisp (mem-ref stack 'smoke-stack-item)

- (transfer-ownership-to value object)))))))

+ (remove-object (pointer value))))))))

+ ; (transfer-ownership-to value object)))))))

+;; Receive virutal function calls.

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

-(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.

- (cerror "ignore" "~A has already been called for ~A."

- #'keep-wrapper object))

+ (cerror "ignore" "~A has already been added to ~A."

+ object new-owner))

- ((gf-methods :initform nil

+ ((gf-methods :initform nil :type list

- :type list

- :documentation "Generic functions for different argument counts."))

+ :documentation "gf for different argument counts."))

- (:documentation

- "A generic function that can be overloaded by argument count."))

+ (:documentation "gf that can be overloaded by argument count."))

- (= argument-count

- (argument-count gf)))

+ (= argument-count (argument-count gf)))

- (let ((generic-function (ensure-gf-by-argument-count cxx-generic-function

- (method-argument-count method))))

+ (let ((generic-function (ensure-gf-by-argument-count

+ cxx-generic-function

+ (method-argument-count method))))

-

-except object with a non virtual destructor which had their ownership transferred

-to C++.")

+except object with a non virtual destructor which had their ownership

+transferred to C++.")

-(defun remove-if-exists (pointer)

- (remhash (pointer-address pointer) *object-map*))

-

- (declare (optimize (speed 3)))

- [_$_]

+ [_$_]

- (assert (not (has-pointer-p (pointer object)))

- ()

+ (assert (not (has-pointer-p (pointer object))) ()

- ((id :initform 0 :type smoke-index :reader id :initarg :id)

- (smoke :type smoke-module :reader smoke :initarg :smoke)))

+ ((id :initform 0 :type smoke-index

+ :reader id :initarg :id)

+ (smoke :type smoke-module

+ :reader smoke :initarg :smoke)))

-

- (mem-aref (the foreign-pointer (smoke-array-pointer (smoke-module-classes

- (smoke class))))

+ (mem-aref (the foreign-pointer

+ (smoke-array-pointer (smoke-module-classes (smoke class))))

- (declare (optimize (speed 3)))

+ (declare (type smoke-class class)

+ (optimize (speed 3)))

-;smoke-find-class

- (smoke-is-derived-from (smoke-module-pointer (smoke class)) (id class)

- (smoke-module-pointer (smoke base-class)) (id base-class)))

+ (smoke-is-derived-from (smoke-module-pointer (smoke class)) [_$_]

+ (id class)

+ (smoke-module-pointer (smoke base-class))

+ (id base-class)))

- class (append classes

- (list

- (make-smoke-class-from-id (smoke class)

- class-index)))

+ class

+ (append classes

+ (list (make-smoke-class-from-id (smoke class) class-index)))

-;;;

- enum-type)

+ enum-type)

- (enum-type enum2))

+ (enum-type enum2))

- collect `(,(value (eval (first case)))

- ,@(rest case)))))

+ collect `(,(value (eval (first case)))

+ ,@(rest case)))))

- (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method)))

+ (if (or (null-pointer-p (smoke-module-pointer

+ (smoke-method-smoke smoke-method)))

- (the (smoke-index 0)

- (method-slot-value method 'name))))

+ (the (smoke-index 0) (method-slot-value method 'name))))

- (format nil "~A~:[~; static~]" (access method)

- (static-p method)))

+ (format nil "~A~:[~; static~]" (access method) (static-p method)))

-

- :top (inc-pointer smoke-stack

- #.(foreign-type-size 'smoke-stack-item))))

+ :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))

- (setf (foreign-slot-value (call-stack-top stack)

- 'smoke-stack-item type) value)

+ (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)

+ value)

- 'smoke-stack-item ,type) ,value)

+ 'smoke-stack-item ,type)

+ ,value)

- (0 (let ((cffi-type (get-type (name type))))

- (if (null cffi-type)

- (progn [_$_]

- ;; FIXME warn but not on void**

- ;;(warn "Unknown translation from ~A to lisp." (name type))

- (foreign-slot-value stack-item 'smoke-stack-item 'voidp))

- (let* ((pointer (foreign-slot-value stack-item

- 'smoke-stack-item

- 'voidp))

- (value (convert-from-foreign pointer cffi-type)))

- (when (stack-p type)

- ;; FIXME free-translated-object is not intended for this;

- ;; param is NIL for now.

- (cffi:free-translated-object pointer cffi-type nil))

- value

- ))))

+ (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

+ 'voidp)))

+ (prog1 (funcall (car translation) pointer)

+ (when (stack-p type)

+ (funcall (cdr translation) pointer))))

+ (error "Do not know how to convert the type ~A to Lisp." type)))

- :value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)

+ :value (foreign-slot-value stack-item 'smoke-stack-item

+ 'enum-value)

- (if (class-p type)

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

- (if (has-pointer-p object)

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

+ (if (has-pointer-p object)

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

+ (get-class type))

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

- nil))

+ (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)

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

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

- (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

+ (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item

- ((void-p type)

- (values))

- ((class-p type)

- (class-to-lisp stack-item type))

- (t

- (enum-to-lisp stack-item type))))

+ ((void-p type) (values))

+ ((class-p type) (class-to-lisp stack-item type))

+ (t (enum-to-lisp stack-item type))))

+

+(defvar *to-lisp-translations* (make-hash-table :test 'equal))

+

+(defun error-no-free (object)

+ (error "Can not free object at ~A." object))

+

+(defmacro define-to-lisp-translation (type-names &optional

+ (conversion-function-name 'identity)

+ (free-function-name 'error-no-free))

+ `(progn ,@(loop for type-name in (ensure-list type-names)

+ collect `(setf (gethash ,type-name *to-lisp-translations*)

+ (cons ',conversion-function-name

+ ',free-function-name)))))

+

+(defmacro define-pointer-typedef (type-names lisp-type)

+ (declare (ignore lisp-type))

+ `(progn [_$_]

+ (define-to-lisp-translation ,type-names identity identity)))

+ ;; not needed

+ ;;(define-from-lisp-translation ,type-names ,lisp-type)))

+

+(define-to-lisp-translation ("void*" "const void*" "void**"))

+

+(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)

- ;; Can't just use #'get-type-flag since it

- ;; can only be one of :stack, :reference and :pointer.

+ ;; Can't just use #'get-type-flag since it can only be one of

+ ;; :stack, :reference and :pointer.

- (= 0 (mem-ref (mem-aref (smoke-array-pointer

- (smoke-module-types (smoke type)))

- 'smoke-type

- (the smoke-index (id type)))

- :char)))

+ (zerop (mem-ref (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke type)))

+ 'smoke-type

+ (the smoke-index (id type)))

+ :char)))

- (assert (/= -1 (type-slot-value type 'class))

+ (assert (class-p type)

- "The type ~S is not a smoke class." (name type))

- (make-smoke-class-from-id

- (smoke type)

- (type-slot-value type 'class)))

+ "The type ~S is not a smoke class." type)

+ (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))

+ ;;

+ ;; But it is needed for passing the int pointer in QApplication(int&, char**).

- :from (find-class 't)

- :to (find-class 't)))) ;; FIXME get the class when applicable

+ :from (find-class 't)

+ :to (find-class 't)))) ;; FIXME get the class when applicable

+ #:define-to-lisp-translation

+ #:define-pointer-typedef

+#include <QDebug>

+ * @param class_index Index of the object's class.

-

-

- 'smoke-class

- 'class-function)

+ 'smoke-class 'class-function)

- 'smoke-method

- 'method)

+ 'smoke-method 'method)

-

- (s-call

- (make-smoke-method-from-name class method-name)

- pointer args))

+ (s-call (make-smoke-method-from-name class method-name) pointer args))

- (s-call

- (make-smoke-method-from-name (make-smoke-class smoke class-name)

- method-name)

- (null-pointer) args))

+ (s-call (make-smoke-method-from-name (make-smoke-class smoke class-name)

+ method-name)

+ (null-pointer) args))

+ ;;

- ;; and confuses it with the member function type() ??

- ;; (27.2.09)

+ ;; and confuses it with the member function type() ?? (27.2.09)

- (s-call

- (make-smoke-method-from-name class method-name)

- pointer)))

+ (s-call (make-smoke-method-from-name class method-name) pointer)))

- (make-smoke-method-from-name (class-of object) method-name)

- (pointer object)))

+ (make-smoke-method-from-name (class-of object) method-name)

+ (pointer object)))

- (setf (foreign-slot-value (mem-aref stack

- 'smoke-stack-item

- 1)

- 'smoke-stack-item

- 'voidp)

+ (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)

+ 'smoke-stack-item 'voidp)

- 'smoke-class

- 'class-function)

+ 'smoke-class 'class-function)

- :pointer (pointer object) smoke-stack stack

+ :pointer (pointer object)

+ smoke-stack stack

- (let* ((binding (smoke-init smoke

- (callback destructed)

+ (let* ((binding (smoke-init smoke (callback destructed)

- (setf (gethash (pointer-address (smoke-module-pointer (eval symbol))) pointer-symbol-map)

+ (setf (gethash (pointer-address (smoke-module-pointer (eval symbol)))

+ pointer-symbol-map)

- (smoke-call (class-of object)

- (pointer object)

- method-name

- args))

+ (smoke-call (class-of object) (pointer object)

+ method-name args))

-

+

- (defcvar (,variable ,variable-name

- :read-only t

- :library ,library) :pointer)

+ (defcvar (,variable ,variable-name :read-only t :library ,library)

+ :pointer)

-

-(in-package :smoke)

-

-(defvar *type-map* (make-hash-table :test 'equal))

-

-(defun get-type (name)

- "Return the CFFI type for NAME."

- (gethash name *type-map*))

-

-(defun add-type (name type)

- "Registers the CFFI type TYPE with NAME."

- (setf (gethash name *type-map*) type))

-

-(defun setup-type-map ()

- "Setup C string <-> Lisp string translation."

- (add-type "char*" :string)

- (add-type "const char*" :string))

-

-(eval-when (:load-toplevel :execute)

- (setup-type-map))

-

-(defgeneric convert-to-class (smoke-class object))

-

-;(defmethod convert-to-class (smoke-class (pointer cffi:foreign-pointer))

-(defmethod convert-to-class (smoke-class pointer)

- (declare (ignore smoke-class))

- (assert (cffi:pointerp pointer))

- pointer)