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

-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

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

- T)

+ t)

- T)

+ t)

- ((object-pointer :pointer))

+ ((object-pointer :pointer))

- 'smoke-stack-item)

- arg)

+ 'smoke-stack-item)

+ arg)

+ ;;

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

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

- :smoke (gethash (pointer-address (smoke-get-smoke binding))

+ :smoke (gethash (pointer-address

+ (smoke-get-smoke binding))

+(defun constructor-name (class)

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

+ (if name-start

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

+ (name class))))

+

- (name (class-of object)))))

+ (constructor-name (class-of object)))))

+ (assert (valid-p method)

+ (method)

+ "No constructor for ~A." object)

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

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

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

- object arguments))

+ (error "No constructor for object ~A with

+the arguments ~S." object arguments))

- &key args &allow-other-keys)

+ &key args

+ (arg0 nil arg0p)

+ (arg1 nil arg1p)

+ (arg2 nil arg2p)

+ &allow-other-keys)

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

- (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 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~%"))))))

- (assert (<= class-index

- (smoke-array-length

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

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

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

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

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

+

- (/ [_$_]

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

-

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

+ (- a b))

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

+(declaim (inline strcmp))

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

+(declaim (inline cstring/=))

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

- (values (integer -1 1))

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

- (dynamic-extent id-cmp))

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

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

+ (strcmp (smoke-method-name method)

-;;; INLINE OPTIMIZE

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

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

- ,index))

+ (the smoke-index ,index)))

+ ;;

- (let ((methods)

- (smoke (smoke class)))

+ (let ((methods))

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

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

-(defconstant +exact-match+ 0)

-(defconstant +promotion+ 1)

-(defconstant +conversion+ 2))

-

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

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

- t)

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

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

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

+ t))

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

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

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

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

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

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

+ #:make-auto-pointer

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

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

- pointer))

- (setf pointer (null-pointer)))

+ pointer)))

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

+

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

+

- (declare (string name)

- (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (with-foreign-string (name name)

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

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

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

+ (load-foreign-library ',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))))

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