Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz * Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs diff -rN -u old-smoke/TODO new-smoke/TODO --- old-smoke/TODO 2014-10-30 08:12:26.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 diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/clos.lisp 2014-10-30 08:12:26.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))) diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp --- old-smoke/src/object-map.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/object-map.lisp 2014-10-30 08:12:26.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 diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp --- old-smoke/src/objects/class.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/objects/class.lisp 2014-10-30 08:12:26.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))))) diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp --- old-smoke/src/objects/method.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/objects/method.lisp 2014-10-30 08:12:26.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. diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp --- old-smoke/src/objects/stack.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/objects/stack.lisp 2014-10-30 08:12:26.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) diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:12:26.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 diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp --- old-smoke/src/package.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/package.lisp 2014-10-30 08:12:26.000000000 +0100 @@ -31,6 +31,7 @@ #:define-from-lisp-translation #:make-cleanup-pointer + #:make-auto-pointer #:pointer #:define-smoke-module diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-30 08:12:26.000000000 +0100 +++ new-smoke/src/smoke.lisp 2014-10-30 08:12:26.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)