Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs

--- old-smoke/TODO 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/TODO 1970-01-01 01:00:00.000000000 +0100

@@ -1,22 +0,0 @@

-Methods:

- * C++ overload resolution & argument promotion

- => no more writing (make-instance 'qt:byte-array :args ("foo"))

- * Test for null pointer in this and for references

- * default arguments

- * fetch name of arguments

-

-* const correctness

-

-* keyword arguments for make-instance

-

-* QApplication and KCmdLineArgs.init call exit() on e.g. "--help"

-

-Testsuite:

- * Fix segfaults when lots of qt:applictions are created & deleted

- * Test condition & restarts

-

-finalization:

- * get rid of owned-p

- * use QObject::deleteLater ?

-

-* Exceptions

--- old-smoke/src/clos.lisp 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/src/clos.lisp 2014-10-30 07:05:58.000000000 +0100

@@ -19,8 +19,8 @@

,documentation

(declare (simple-string input)

(optimize (speed 3)))

- ;; At least on sbcl 1.0.25.debian CONCATENATE is faster

- ;; than VECTOR-PUSH-EXTEND

+ ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than

+ ;; VECTOR-PUSH-EXTEND.

(let ((,output "")

(,index 0)

(,length (length input))

@@ -121,10 +121,10 @@

(:documentation "Metaclass to extend Smoke Objects."))

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

- T)

+ t)

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

- T)

+ t)

(defmethod reinitialize-instance :around

((class smoke-standard-class)

@@ -245,7 +245,7 @@

(list ,@(rest lambda-list))))))))

(defcallback destructed :void

- ((object-pointer :pointer))

+ ((object-pointer :pointer))

(declare (optimize (speed 3)))

(let ((object (get-object object-pointer)))

(when object

@@ -267,8 +267,8 @@

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

(next arg)

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

- 'smoke-stack-item)

- arg)

+ 'smoke-stack-item)

+ arg)

args))))

(defun convert-argument (argument type &optional (user t))

@@ -286,9 +286,10 @@

(let ((stack (make-call-stack stack)))

(setf (call-stack-top stack) (call-stack-pointer stack))

;; FIXME support user conversions.

+ ;;

;; We need to determine which of value and converted-value is

- ;; passed on the stack. E.g. converted-value can be something like

- ;; (cxx:operator-variant value).

+ ;; passed on the stack. E.g. converted-value can be something

+ ;; like (cxx:operator-variant value).

(let ((converted-value (convert-argument value type nil)))

(push-smoke-stack stack converted-value (type-id type))

(when (stack-p type) ;; Pass by value => smoke deletes the object.

@@ -314,10 +315,11 @@

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

+ ;; 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 (gethash (pointer-address

+ (smoke-get-smoke binding))

*smoke-modules*)

:id method)))

(loop

@@ -409,25 +411,38 @@

(defmethod convert-to-class (smoke-class (object smoke-standard-object))

(cast object smoke-class))

+(defun constructor-name (class)

+ (let ((name-start (search "::" (name class) :from-end t)))

+ (if name-start

+ (subseq (name class) (+ name-start 2))

+ (name class))))

+

(defun call-constructor (object arguments)

(if (null arguments)

(let ((method (find-smoke-method (class-of object)

- (name (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 (name (class-of object))

+ (find-best-viable-function (constructor-name (class-of object))

arguments

(class-of object))

(when (null method)

- (error "No constructor ~A for ~S"

- object arguments))

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

(defmethod initialize-instance :after ((object smoke-standard-object)

- &key args &allow-other-keys)

+ &key args

+ (arg0 nil arg0p)

+ (arg1 nil arg1p)

+ (arg2 nil arg2p)

+ &allow-other-keys)

"Initializes a Smoke object. Calls its constructor with the arguments supplied

by the key :ARGS and sets the smoke binding."

(declare (optimize (speed 3)))

@@ -437,7 +452,14 @@

"Pointer ~A bound and constructor argument :ARGS ~S supplied."

(slot-value object 'pointer) args)

(unless (slot-boundp object 'pointer)

- (setf (slot-value object 'pointer) (call-constructor object args))

+ (if arg0p

+ (setf (slot-value object 'pointer)

+ (call-constructor object

+ (cond

+ (arg2p (list arg0 arg1 arg2))

+ (arg1p (list arg0 arg1))

+ (t (list arg0)))))

+ (setf (slot-value object 'pointer) (call-constructor object args)))

(set-binding object)

(take-ownership object)

(add-object object)))

--- old-smoke/src/object-map.lisp 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/src/object-map.lisp 2014-10-30 07:05:58.000000000 +0100

@@ -64,10 +64,8 @@

(defun remove-object (pointer)

(declare (optimize (speed 3)))

- (assert (has-pointer-p pointer)

- (pointer)

- "No object to remove for pointer ~A." pointer)

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

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

+ (cerror "ignore" "No object to remove for pointer ~A." pointer)))

(defun report-finalize-error (condition function class pointer)

"Report the error CONDITION it the finalizer FUNCTION for the

@@ -102,6 +100,17 @@

(handler-case (delete-pointer pointer class)

(error (condition)

(report-finalize-error condition 't (name class) pointer))))))

+

+(defun debug-finalize ()

+ (eval '(defmethod make-finalize :around (object)

+ (let ((pointer (pointer object))

+ (class (class-of object))

+ (next (call-next-method)))

+ #'(lambda ()

+ (format *debug-io* "cl-smoke: finalizing: ~A..."

+ (make-instance class :pointer pointer))

+ (funcall next)

+ (format *debug-io* "done~%"))))))

(defun add-object (object)

"Adds OBJECT to the pointer -> object map. It can later be retrieved

--- old-smoke/src/objects/class.lisp 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/src/objects/class.lisp 2014-10-30 07:05:58.000000000 +0100

@@ -119,13 +119,13 @@

(smoke class))

'smoke-index

index)))

- (assert (<= class-index

- (smoke-array-length

- (smoke-module-classes (smoke class)))))

+ (assert (<= class-index (smoke-array-length

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

(if (= 0 class-index)

classes

- (smoke-add-superclass class (append classes

- (list

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

- class-index)))

- (1+ index)))))

+ (smoke-add-superclass

+ class (append classes

+ (list

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

+ class-index)))

+ (1+ index)))))

--- old-smoke/src/objects/method.lisp 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/src/objects/method.lisp 2014-10-30 07:05:58.000000000 +0100

@@ -47,6 +47,14 @@

(gethash (pointer-address smoke) *smoke-modules*))

:id (foreign-slot-value m 'smoke-module-index 'index)))))

+(declaim (inline smoke-method-name))

+(defun smoke-method-name (method)

+ (mem-aref (smoke-array-pointer (smoke-module-method-names

+ (smoke-method-smoke method)))

+ :pointer

+ (the (smoke-index 0)

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

+

;smoke-find-method

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

"Returns the method NAME of CLASS.

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

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

@@ -8,10 +8,9 @@

(defgeneric size (object))

(defmethod size ((stack call-stack))

"Returns the size (number of arguments) of STACK."

- (/

- (- (pointer-address (call-stack-top stack))

- (pointer-address (call-stack-pointer stack)))

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

+ (/ (- (pointer-address (call-stack-top stack))

+ (pointer-address (call-stack-pointer stack)))

+ (foreign-type-size 'smoke-stack-item)))

(defun make-call-stack (smoke-stack)

(declare (type foreign-pointer smoke-stack)

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

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

@@ -3,80 +3,33 @@

(in-package :smoke)

-(defun cstring= (string1 string2)

- "Returns T when the C strings STRING1 and STRING2 are equal

- and NIL otherwise."

- (declare (optimize (speed 3) (safety 0)))

- (dotimes (i array-total-size-limit)

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring= nil))

- (when (or (= 0 char1)

- (= 0 char2))

- (return-from cstring= (= char1 char2))))))

-

(declaim (inline cmp))

(defun cmp (a b)

- "Returns -1 if a < b; 0 if a = b and 1 if a > b"

- (declare (values (integer -1 1)))

- (if (< a b)

- -1

- (if (> a b)

- 1

- 0)))

-

-(declaim (inline cstring-cmp))

-(defun cstring-cmp (string1 string2)

- "Compares the C strings STRING1 and STRING2."

- (declare (foreign-pointer string1 string2)

- (values (integer -1 1))

- (optimize (speed 3)))

- (dotimes (i array-total-size-limit (error "omg"))

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring-cmp (if (< char1 char2) -1 1)))

- (when (= 0 char1) ;; <=> (= 0 char2)

- (return-from cstring-cmp 0)))))

+ (- a b))

+(declaim (inline strcmp))

+(defcfun strcmp :int (s1 :pointer) (s2 :pointer))

+

+(declaim (inline cstring/=))

(defun cstring/= (string1 string2)

"Returns T when the C strings STRING1 and STRING2 are not equal

and NIL otherwise."

- (declare (optimize (speed 3)))

- (dotimes (i array-total-size-limit)

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring/= i))

- (when (= 0 char1)

- (return-from cstring/= nil)))))

-

-(declaim (inline smoke-method-name))

-(defun smoke-method-name (method)

- (mem-aref (smoke-array-pointer (smoke-module-method-names

- (smoke-method-smoke method)))

- :pointer

- (the (smoke-index 0)

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

+ (not (zerop (strcmp string1 string2))))

(defun method-cmp (method class-id name)

"Compares METHOD to the method with NAME of class CLASS-ID."

(declare (foreign-pointer name)

(type (smoke-index 0) class-id)

(smoke-method method)

- (values (integer -1 1))

(optimize (speed 3) (debug 0) (safety 0)))

(let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))

(the (smoke-index 0) class-id))))

- (declare (type (integer -1 1) id-cmp)

- (dynamic-extent id-cmp))

+ (declare (type smoke-index id-cmp))

(if (/= 0 id-cmp)

id-cmp

- (cstring-cmp (smoke-method-name method)

+ (strcmp (smoke-method-name method)

name))))

-;;; INLINE OPTIMIZE

(declaim (inline first-unabigious-index))

(defun first-unabigious-index (smoke index)

(declare (type smoke-index index)

@@ -112,13 +65,14 @@

'smoke-method-map index)

'smoke-method-map

'method)))))

- (cmp (the (integer -1 1) (method-cmp method class-id name))))

- (declare (type (integer -1 1) cmp)

+ (cmp (the smoke-index (method-cmp method class-id name))))

+ (declare (type smoke-index cmp)

(dynamic-extent method))

- (ecase cmp

- (-1 (setf start (1+ index)))

- (0 (return-from find-method-for-class index))

- (1 (setf end (1- index)))))))

+ (if (< cmp 0)

+ (setf start (1+ index))

+ (if (> cmp 0)

+ (setf end (1- index))

+ (return-from find-method-for-class index))))))

-1)

(defmacro push-candidate-method (index name argument-count class methods)

@@ -128,7 +82,7 @@

(smoke-array-pointer

(smoke-module-method-maps ,smoke))

'smoke-method-map

- ,index))

+ (the smoke-index ,index)))

(,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))

(,method (make-smoke-method

:smoke ,smoke

@@ -169,30 +123,27 @@

(defun viable-functions (name argument-count class)

"Returns a list of methods named NAME that take ARGUMENT-COUNT methods."

;; 13.3.2

+ ;;

;; FIXME make a lazy map-viable-functions to allow returning early,

;; when an exact match is found.

(declare (optimize (speed 3)))

(with-foreign-string (name name)

- (let ((methods)

- (smoke (smoke class)))

+ (let ((methods))

(dolist (class (all-smoke-superclasses class))

- (let ((start-index (find-method-for-class name class)))

- (declare (type smoke-index start-index))

- (loop for index from start-index downto 1

- while (push-candidate-method index name argument-count class

- methods))

- (loop for index from (1+ start-index)

- to (the smoke-index (smoke-array-length

- (smoke-module-method-maps smoke)))

- while (push-candidate-method index name argument-count class

- methods))))

+ (let ((smoke (smoke class)))

+ (let ((start-index (find-method-for-class name class)))

+ (declare (type smoke-index start-index))

+ (when (>= start-index 0)

+ (loop for index from start-index downto 1

+ while (push-candidate-method index name argument-count class

+ methods))

+ (loop for index from (1+ start-index)

+ to (the smoke-index (smoke-array-length

+ (smoke-module-method-maps smoke)))

+ while (push-candidate-method index name argument-count class

+ methods))))))

methods)))

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

-(defconstant +exact-match+ 0)

-(defconstant +promotion+ 1)

-(defconstant +conversion+ 2))

-

(declaim (inline make-conversion make-exact-match make-promotion

make-number-conversion make-pointer-conversion

make-boolean-conversion make-user-conversion))

@@ -200,19 +151,19 @@

(function-name nil :type (or symbol function) :read-only t)

(rank -1 :type fixnum :read-only t))

-(defstruct (exact-match (:include conversion (rank +exact-match+))))

+(defstruct (exact-match (:include conversion (rank 0))))

-(defstruct (promotion (:include conversion (rank +promotion+))))

+(defstruct (promotion (:include conversion (rank 1))))

-(defstruct (number-conversion (:include conversion (rank +conversion+))))

+(defstruct (number-conversion (:include conversion (rank 2))))

-(defstruct (pointer-conversion (:include conversion (rank (1+ +conversion+))))

+(defstruct (pointer-conversion (:include conversion (rank 3)))

(from (find-class t) :type class :read-only t)

(to (find-class t) :type class :read-only t))

-(defstruct (boolean-conversion (:include conversion (rank (+ 2 +conversion+)))))

+(defstruct (boolean-conversion (:include conversion (rank 4))))

-(defstruct (user-conversion (:include conversion (rank (+ 3 +conversion+)))))

+(defstruct (user-conversion (:include conversion (rank 5))))

(defgeneric conversion< (conversion1 conversion2)

(:documentation

@@ -245,10 +196,7 @@

(:method (conversion1 conversion2)

(= (conversion-rank conversion1) (conversion-rank conversion2)))

(:method ((conversion1 (eql nil)) (conversion2 (eql nil)))

- t)

- (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

- (and (not (conversion< conversion1 conversion2))

- (not (conversion< conversion2 conversion1)))))

+ t))

(defun max-conversion (conversion1 conversion2)

"Returns the greater conversion of CONVERSION1 and CONVERSION2."

@@ -375,6 +323,8 @@

(5 (object.typep '(c-integer :unsigned-short)))

(6 (object.typep '(c-integer :int)))

(7 (object.typep '(c-integer :unsigned-int)))

+ (8 (object.typep '(c-integer :long)))

+ (9 (object.typep '(c-integer :unsigned-long)))

(10 (object.typep 'single-float))

(11 (object.typep 'double-float))

(12 (object.typep 'enum)) ;; FIXME enum-type

@@ -444,15 +394,16 @@

:to (find-class 't))))

(defun+using-type conversion-pointer object (object type)

- ;; Not using pointer-p to allow passing a raw pointer for

- ;; objects on the stack and references

+ ;; Not using pointer-p to allow passing a raw pointer for objects on

+ ;; the stack and references.

;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )

;;

- ;; FIXME this breaks passing pointers to references

- ;; e.g.: calling the function foo(QByteArray& foo)

- ;; with (foo pointer) assumes pointer to point to a QByteArray,

- ;; but actually the conversion sequence QByteArray(pointer) should be used.

- ;; When pointer is a null pointer it fails horribly!.

+ ;; FIXME this breaks passing pointers to references.

+ ;;

+ ;; e.g.: calling the function foo(QByteArray& foo) with

+ ;; (foo pointer) assumes pointer to point to a QByteArray, but

+ ;; actually the conversion sequence QByteArray(pointer) should be

+ ;; used. When pointer is a null pointer it fails horribly!.

(when (and (or (= 0 (type-id type)) ; voidp

(= 13 (type-id type))) ; class

(object.typep 'foreign-pointer))

@@ -497,7 +448,7 @@

(if (using-typep)

#'standard-conversion-sequence-using-types

#'standard-conversion-sequence)

- (format nil "~A" (name (get-class type)))

+ (constructor-name (get-class type))

(list object) to-class)

(make-match 'user-conversion

'coerce-to-class

--- old-smoke/src/package.lisp 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/src/package.lisp 2014-10-30 07:05:58.000000000 +0100

@@ -31,6 +31,7 @@

#:define-from-lisp-translation

#:make-cleanup-pointer

+ #:make-auto-pointer

#:pointer

#:define-smoke-module

--- old-smoke/src/smoke.lisp 2014-10-30 07:05:58.000000000 +0100

+++ new-smoke/src/smoke.lisp 2014-10-30 07:05:58.000000000 +0100

@@ -80,11 +80,10 @@

"Destructs the object at POINTER of type CLASS.

Calls the destructor and frees the memory."

(declare (optimize (speed 3)))

- (let ((method-name (concatenate 'string "~" (name class))))

+ (let ((method-name (concatenate 'string "~" (constructor-name class))))

(s-call

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

- pointer))

- (setf pointer (null-pointer)))

+ pointer)))

(defun delete-object (object)

(let ((method-name (concatenate 'string "~" (name (class-of object)))))

@@ -144,35 +143,39 @@

(declare (optimize (speed 3)))

(format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class)))

-;; No eql T since all-methods is to slow to be used in conjunction with

-;; mb:document

-(defmethod documentation ((gf smoke-gf) (doc-type (eql 'cxx-function)))

+(defmethod documentation ((gf smoke-gf) (doc-type (eql 't)))

(declare (optimize (speed 3)))

(let ((methods (all-methods (name gf))))

(format nil "~@[~A~%~]~{~T~A~%~}"

(call-next-method)

(sort (mapcar #'method-declaration methods) #'string<=))))

+

+(declaim (inline cstring=))

+(defun cstring= (string1 string2)

+ "Returns T when the C strings STRING1 and STRING2 are equal

+ and NIL otherwise."

+ (zerop (strcmp string1 string2)))

+

(defun all-methods (name)

"Returns a list of all methods named NAME."

;;FIXME speed this up, needed by (mb:document :smoke).

- (declare (string name)

- (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (with-foreign-string (name name)

(let ((methods))

(maphash

- #'(lambda (address value)

- (declare (ignore value))

- (let ((smoke (make-pointer address)))

- (map-methods #'(lambda (method)

- (when (and (string= name (name method))

- (not (enum-p method)))

- (push (make-instance 'smoke-method

- :id (smoke-method-id method)

- :smoke (smoke method))

- methods)))

- smoke)))

- *smoke-id-class-map*)

- methods))

+ #'(lambda (address module)

+ (declare (ignore address))

+ (map-methods #'(lambda (method)

+ (when (and (cstring= name (smoke-method-name method))

+ (not (enum-p method)))

+ (push (make-smoke-method

+ :id (smoke-method-id method)

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

+ methods)))

+ module))

+ *smoke-modules*)

+ methods)))

(defun fgrep-methods (smoke str)

(map-methods #'(lambda (method)

@@ -187,18 +190,13 @@

"Define a Smoke module."

(let ((smoke-module (intern "*SMOKE-MODULE*")))

`(progn

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

- (define-foreign-library ,library

- (:unix ,(format nil "~(~A~).so.2" library))

- (t (:default ,(format nil "~(~A~)" library)))))

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

+ (define-foreign-library ,library

+ (:unix ,(format nil "~(~A~).so.2" library))

+ (t (:default ,(format nil "~(~A~)" library)))))

(eval-startup (:compile-toplevel :execute)

- (load-foreign-library ',library))

+ (load-foreign-library ',library))

(eval-startup (:compile-toplevel :execute)

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

-; (define-foreign-library ,library

-; (:unix ,(format nil "~(~A~).so.2" library))

-; (t (:default ,(format nil "~(~A~)" library))))

-; (load-foreign-library ',library))

(defcvar (,variable ,variable-name

:read-only t

:library ,library) :pointer)