Thu Aug 27 13:43:13 CEST 2009 Tobias Rautenkranz * Support the new smokegenerator (r1015073). * support const correctness * remove workarounds for the old smoke The old smoke is no longer supported. Thanks to Arno Rehn for making the smokegenerator work with cl-smoke. diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp --- old-smoke/src/bindings.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/bindings.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -45,6 +45,13 @@ (defvar *smoke-modules* (make-hash-table) "All loaded Smoke modules.") +(defmethod print-object ((smoke-module smoke-module) stream) + (if (null-pointer-p (smoke-module-pointer smoke-module)) + (call-next-method) + (print-unreadable-object (smoke-module stream :type t :identity t) + (princ (smoke-get-module-name (smoke-module-pointer smoke-module)) + stream)))) + (defun init-smoke-module (module) (let ((smoke (smoke-module-pointer module))) (setf (gethash (pointer-address smoke) *smoke-modules*) diff -rN -u old-smoke/src/class-map.lisp new-smoke/src/class-map.lisp --- old-smoke/src/class-map.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/class-map.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -26,11 +26,13 @@ (setf (gethash (id smoke-class) (id-class-map (smoke smoke-class))) class)) -(defun find-smoke-class (class) +(defun find-smoke-class (class &optional (error-p t)) "Returns the CLOS class for smoke-class CLASS." - (let* ((class (real-class class)) - (ret (gethash (id class) (id-class-map (smoke class))))) - (assert (not (null ret)) - () - "The class ~A was not found." (name class)) + (let* ((class (handler-case (real-class class) + (undefined-class (e) (when error-p (error e))))) + (ret (when class (gethash (id class) (id-class-map (smoke class)))))) + (when error-p + (assert (not (null ret)) + () + "The class ~A was not found." (name class))) ret)) diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/clos.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -108,6 +108,8 @@ (defmethod print-object ((object smoke-standard-object) stream) (if (slot-boundp object 'pointer) (print-unreadable-object (object stream :type t) + (when (const-p object) + (princ "CONST " stream)) (princ (pointer object) stream)) (call-next-method))) @@ -183,16 +185,22 @@ (add-id-class-map smoke) (map-classes #'(lambda (class) - (unless (external-p class) - (add-id class - (closer-mop:ensure-class (lispify (name class)) - :direct-superclasses - (mapcar #'smoke-class-symbol - (smoke-class-direct-superclasses class)) - :id (id class) - :smoke (smoke class) - :metaclass 'smoke-standard-class)) - (export (lispify (name class))))) + (unless (or (external-p class) + (and (eq package :cl-smoke.qt) + (string/= (smoke-get-module-name + (smoke-module-pointer smoke)) + "qt") + (string= (name class) "QGlobalSpace"))) + (with-simple-restart (skip "Skip generating class ~A" (name class)) + (add-id class + (closer-mop:ensure-class (lispify (name class)) + :direct-superclasses + (mapcar #'smoke-class-symbol + (smoke-class-direct-superclasses class)) + :id (id class) + :smoke (smoke class) + :metaclass 'smoke-standard-class)) + (export (lispify (name class)))))) smoke))) (defclass smoke-gf (cxx-generic-function) @@ -256,7 +264,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) + (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item) arg) args)))) @@ -456,7 +464,8 @@ (defmethod instance-to-lisp (pointer class type) (declare (type smoke-standard-class class) (optimize (speed 3))) - (let ((ret (make-instance class :pointer pointer))) + (let ((ret (make-instance class :pointer pointer + :const-p (const-p type)))) (when (stack-p type) (take-ownership ret) (add-object ret)) 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:11:19.000000000 +0100 +++ new-smoke/src/objects/class.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -91,7 +91,8 @@ (defun real-class (class) "Returns the same class like CLASS, but such that EXTERNAL-P returns NIL." (if (external-p class) - (make-smoke-class (smoke class) (name class)) + (handler-case (make-smoke-class (smoke class) (name class)) + (undefined-class () class)) class)) (defun class-id (module class) diff -rN -u old-smoke/src/objects/enum.lisp new-smoke/src/objects/enum.lisp --- old-smoke/src/objects/enum.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/objects/enum.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -44,17 +44,26 @@ (= (value enum1) (value enum2))) (defmacro enum-xcase (case keyform &body cases) - (let ((type (enum-type (eval (first (first cases)))))) + (flet ((first-key (keys) + (if (listp keys) + (first keys) + keys))) + (let ((type (enum-type (eval (first-key (first (first cases))))))) (loop for case in cases do - (check-enum-type (eval (first case)) + (check-enum-type (eval (first-key (first case))) type))) `(progn - ; (check-enum-type (enum-type ,keyform) - ; (enum-type ,(first (first cases)))) + ;; (check-enum-type (enum-type ,keyform) + ;; (enum-type ,(first (first cases)))) (,case (value ,keyform) ,@(loop for case in cases - collect `(,(value (eval (first case))) - ,@(rest case)))))) + collect `(,(if (listp (first case)) + (mapcar #'(lambda (c) + (print c) + (value (eval c))) + (first case)) + (value (eval (first case)))) + ,@(rest case))))))) (defmacro enum-case (keyform &body cases) `(enum-xcase case ,keyform ,@cases)) 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:11:19.000000000 +0100 +++ new-smoke/src/objects/stack.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -33,13 +33,16 @@ (incf-pointer (call-stack-top ,stack) ,(foreign-type-size 'smoke-stack-item))) form)) - (defclass smoke-standard-object () ((pointer :reader pointer :type foreign-pointer :initarg :pointer :documentation "Pointer to the C++ object.") + (const-p :reader const-p + :initarg :const-p + :initform nil + :documentation "Returns true when the object is const and nil otherwise.") #+clisp (finalizer :type list :initform (list nil)) ;; We can not have a global table of objects owned by C++, ;; since then they would be always reachable from Lisp and thus @@ -96,6 +99,8 @@ ,types) ,@body)))) +(defvar *to-lisp-translations* (make-hash-table :test 'equal)) + (defun enum-to-lisp (stack-item type) "Returns the Lisp representation for STACK-ITEM of the basic C type TYPE." (declare (optimize (speed 3))) @@ -158,7 +163,6 @@ ((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)) diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp --- old-smoke/src/objects/type.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/objects/type.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -58,10 +58,9 @@ (type-slot-value type 'name)) (defun smoke-type= (type1 type2) - (and t ;(pointer-eq (smoke type1) - ; (smoke type2)) - (= (id type1) - (id type2)))) + (if (eq (smoke type1) (smoke type2)) + (= (id type1) (id type2)) + (string= (name type1) (name type2)))) (defun get-type-flag (type flag) (declare (optimize (speed 3))) @@ -120,12 +119,14 @@ ;; For efficiency just check if the first byte is a null byte; ;; No need to convert the entire C string to lisp like in: ;; (null (name type))) - (declare (optimize (speed 3))) - (zerop (mem-ref (mem-aref (smoke-array-pointer - (smoke-module-types (smoke type))) - 'smoke-type - (the smoke-index (id type))) - :char))) + (null-pointer-p (mem-ref + (foreign-slot-pointer + (mem-aref (smoke-array-pointer + (smoke-module-types (smoke type))) + 'smoke-type + (the smoke-index (id type))) + 'smoke-type 'name) + :pointer))) (defgeneric get-class (smoke-symbol) 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:11:19.000000000 +0100 +++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -1,5 +1,8 @@ ;;; C++ overload resolution ;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf +;;; +;;; We handle only the most common cases. Stuff like virtual inheritance +;;; that is not needed is not implemented. (in-package :smoke) @@ -75,7 +78,8 @@ (return-from find-method-for-class index)))))) -1) -(defmacro push-candidate-method (index name argument-count class methods) +(defmacro push-candidate-method (index name argument-count class methods + const-p) (with-gensyms (method-map method-index method ambig-index i smoke) `(let* ((,smoke (smoke ,class)) (,method-map (mem-aref @@ -105,11 +109,13 @@ 'smoke-index ,ambig-index)) while (> (the smoke-index ,i) 0) do - (incf ,ambig-index) - (push (make-smoke-method :smoke ,smoke - :id ,i) - ,methods))) - (push ,method ,methods))) + (incf ,ambig-index) + (let ((,method (make-smoke-method :smoke ,smoke + :id ,i))) + (unless (and ,const-p (not (const-p ,method))) + (push ,method ,methods))))) + (unless (and ,const-p (not (const-p ,method))) + (push ,method ,methods)))) t))))) (defun all-smoke-superclasses (class) @@ -120,28 +126,22 @@ (when (typep class 'smoke-standard-class) (setf classes (append (all-smoke-superclasses class) classes)))))) -(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. +(defun viable-functions (name argument-count class &optional const-p) (declare (optimize (speed 3))) (with-foreign-string (name name) (let ((methods)) - (dolist (class (all-smoke-superclasses class)) - (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)))))) + (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 const-p)) + (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 const-p))))) methods))) (declaim (inline make-conversion make-exact-match make-promotion @@ -165,16 +165,15 @@ (defstruct (user-conversion (:include conversion (rank 5)))) -(defgeneric conversion< (conversion1 conversion2) - (:documentation - "Returns true when CONVERSION1 is better than CONVERSION2.") +(defgeneric conversion<= (conversion1 conversion2) ;; 13.3.3.2 Ranking implicit conversion sequences ;; 4 (:method (conversion1 conversion2) (declare (optimize (speed 3))) - (or (null conversion2) - (< (the fixnum (conversion-rank conversion1)) - (the fixnum (conversion-rank conversion2))))) + (and (not (null conversion1)) + (or (null conversion2) + (<= (the fixnum (conversion-rank conversion1)) + (the fixnum (conversion-rank conversion2)))))) (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion)) (declare (optimize (speed 3))) (if (eq (pointer-conversion-from conversion1) @@ -190,11 +189,9 @@ nil)))) (defgeneric conversion= (conversion1 conversion2) - (:documentation - "Returns true when the standard conversion sequence CONVERSION1 - is indistinguishable from CONVERSION2.") (:method (conversion1 conversion2) - (= (conversion-rank conversion1) (conversion-rank conversion2))) + (and (conversion<= conversion1 conversion2) + (conversion<= conversion2 conversion1))) (:method ((conversion1 (eql nil)) (conversion2 (eql nil))) t)) @@ -202,7 +199,7 @@ "Returns the greater conversion of CONVERSION1 and CONVERSION2." (if (null conversion2) conversion1 - (if (conversion< conversion1 conversion2) + (if (conversion<= conversion1 conversion2) conversion2 conversion1))) @@ -241,49 +238,69 @@ (defun+using-types standard-conversion-sequence (method classes &optional user) "Returns the conversion sequences to convert the arguments of types CLASSES to the types required by METHOD." - (let ((max-rank) - (conversions)) - (loop for type in (arguments method) - for class in classes do - (let ((rank (call-using-type get-conversion-sequence class type user))) - (when (null rank) - (setf max-rank nil) - (return nil)) - (setf max-rank (max-conversion rank max-rank)) - (push (conversion-function-name rank) conversions))) - (values max-rank (reverse conversions)))) + (if (null classes) + (values (make-match 'exact-match) nil) + (let ((max-rank) + (conversions)) + (loop for type in (arguments method) + for class in classes do + (let ((rank (call-using-type get-conversion-sequence class type user))) + (when (null rank) + (setf max-rank nil) + (return nil)) + (setf max-rank (max-conversion rank max-rank)) + (push (conversion-function-name rank) conversions))) + (values max-rank (reverse conversions))))) (defun+using-types conversion-sequence (method classes) (call-using-types standard-conversion-sequence method classes t)) -(defun+using-types find-best-viable-function (name arguments class) +(defun+using-types find-best-viable-function (name arguments class + &optional const-p) "Returns the method named NAME of class CLASS that can be called using arguments of types TYPES with the lowest conversion sequence." (call-using-types find-best-viable-function2 (function-using-types conversion-sequence) - name arguments class)) + name arguments class const-p)) -(defun+using-types find-best-viable-function2 (get-sequence name objects class) - (declare (type (function (t list) (values t function)) get-sequence)) +(defun+using-types find-best-viable-function2 (get-sequence name objects class + &optional const-p) (when (and (using-typep) (not (typep class 'smoke-standard-class))) (throw 'unspecific-type class)) (let ((viable-functions (viable-functions name (length objects) - class)) + class const-p)) (best-rank) (best-method) (conversions)) - (loop for method in viable-functions do - (multiple-value-bind (rank method-conversions) - (funcall get-sequence method objects) - ;; FIXME test for ambiguous overload #'conversion= - (when (and rank (conversion< rank best-rank)) - (setf best-rank rank) - (setf best-method method) - (setf conversions method-conversions) - (when (conversion= rank (make-match 'exact-match)) - (return))))) - (values best-method conversions))) + (if (null viable-functions) + (dolist (class (closer-mop:class-direct-superclasses class) + (values best-method nil)) + (when (typep class 'smoke-standard-class) + (multiple-value-bind (method conversions) + (call-using-types find-best-viable-function2 get-sequence name objects class const-p) + (when method + (return (values method conversions)))))) + (loop for method in viable-functions + finally (return (values best-method conversions)) do + (block next + (multiple-value-bind (rank method-conversions) + (funcall get-sequence method objects) + (when (and rank (conversion<= rank best-rank)) + (when (conversion= rank best-rank) + ;; FIXME catch all ambigious overloads + (if const-p + (error "Ambigious overload ~A." method) + (when (const-p method) + ;; assume that the previous method is a non + ;; const one and thus more specific. + (return-from next)))) + (setf best-rank rank) + (setf best-method method) + (setf conversions method-conversions) + (when (and (conversion= rank (make-match 'exact-match)) + (not (xor const-p (const-p method)))) + (return (values method conversions)))))))))) (defvar *from-lisp-translations* (make-hash-table :test 'equal)) @@ -377,7 +394,8 @@ (defun+using-type conversion-cast object (object type) (when (and (class-p type) (object.typep 'smoke-standard-object) - (derived-p (object.type-of) (get-class type))) + (derived-p (object.type-of) (get-class type)) + (find-smoke-class (get-class type))) (make-match 'pointer-conversion 'coerce-cast (find-smoke-class (get-class type)) @@ -428,13 +446,7 @@ "operator " (if (class-p to-type) (name (get-class to-type)) - (if (pointer-p to-type) - ;; Insert a space before the #\* - (let ((name (name to-type))) - (concatenate 'string - (subseq name 0 (1- (length name))) - " *")) - (name to-type))))) + (name to-type)))) (defun coerce-to-type (object method) (pointer-call method (pointer object))) @@ -444,10 +456,6 @@ (let ((method (find-smoke-method (object.type-of) (conversion-operator-name type)))) (when (valid-p method) - (assert (not (void-p type)) - () - "Conversion operators not supported by Smoke. -Update to Smoke >= r955426.") (if (pointer-p type) (make-match 'user-conversion 'coerce-to-type @@ -462,13 +470,14 @@ (defun+using-type constructor-conversion object (object type) (when (class-p type) - (let ((to-class (find-smoke-class (get-class type)))) - (when (call-using-types find-best-viable-function2 - (if (using-typep) - #'standard-conversion-sequence-using-types - #'standard-conversion-sequence) - (constructor-name (get-class type)) - (list object) to-class) + (let ((to-class (find-smoke-class (get-class type) nil))) + (when (and to-class + (call-using-types find-best-viable-function2 + (if (using-typep) + #'standard-conversion-sequence-using-types + #'standard-conversion-sequence) + (constructor-name (get-class type)) + (list object) to-class)) (make-match 'user-conversion 'coerce-to-class to-class))))) @@ -502,27 +511,19 @@ (defun call-using-args (object-or-class name arguments) "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS." (declare (optimize (speed 3))) - (if (null arguments) - (let ((method (find-smoke-method (smoke-class-of object-or-class) - name))) - (unless (valid-p method) - (error (make-condition 'no-applicable-cxx-method - :method name - :class object-or-class - :arguments arguments))) - (if (static-p method) - (s-call method (null-pointer)) - (s-call method (cast object-or-class (get-class method))))) - (multiple-value-bind (method sequence) - (find-best-viable-function name - arguments - (smoke-class-of object-or-class)) - (when (null method) - (error (make-condition 'no-applicable-cxx-method - :method name - :class object-or-class - :arguments arguments))) - (if (static-p method) - (apply #'call-sequence method (null-pointer) sequence arguments) - (apply #'call-sequence method (cast object-or-class (get-class method)) - sequence arguments))))) + (multiple-value-bind (method sequence) + (find-best-viable-function name + arguments + (smoke-class-of object-or-class) + (when (typep object-or-class + 'smoke-standard-object) + (const-p object-or-class))) + (when (null method) + (error (make-condition 'no-applicable-cxx-method + :method name + :class object-or-class + :arguments arguments))) + (if (static-p method) + (apply #'call-sequence method (null-pointer) sequence arguments) + (apply #'call-sequence method (cast object-or-class (get-class method)) + sequence arguments)))) diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp --- old-smoke/src/package.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/package.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -35,6 +35,7 @@ #:make-cleanup-pointer #:make-auto-pointer + #:const-p #:pointer #:define-smoke-module #:define-takes-ownership diff -rN -u old-smoke/src/smoke-to-clos.lisp new-smoke/src/smoke-to-clos.lisp --- old-smoke/src/smoke-to-clos.lisp 2014-10-30 08:11:19.000000000 +0100 +++ new-smoke/src/smoke-to-clos.lisp 2014-10-30 08:11:19.000000000 +0100 @@ -103,11 +103,7 @@ (exports)) (map-methods #'(lambda (method) - (when (and (enum-p method) - ;; FIXME workaround for - ;; http://lists.kde.org/?l=kde-bindings&m=123464781307375 - (not (string= (name (get-class method)) - "KGlobalSettings"))) + (when (enum-p method) (multiple-value-bind (def export) (constant-definition package method smoke) (push def constants)