Thu Aug 27 13:43:13 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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.
hunk ./src/bindings.lisp 48
+(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))))
+
hunk ./src/class-map.lisp 29
-(defun find-smoke-class (class)
+(defun find-smoke-class (class &optional (error-p t))
hunk ./src/class-map.lisp 31
- (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)))
hunk ./src/clos.lisp 111
+ (when (const-p object)
+ (princ "CONST " stream))
hunk ./src/clos.lisp 188
- (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))))))
hunk ./src/clos.lisp 267
- (push (argument-to-lisp (mem-ref stack 'smoke-stack-item)
+ (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)
hunk ./src/clos.lisp 467
- (let ((ret (make-instance class :pointer pointer)))
+ (let ((ret (make-instance class :pointer pointer
+ :const-p (const-p type))))
hunk ./src/objects/class.lisp 94
- (make-smoke-class (smoke class) (name class))
+ (handler-case (make-smoke-class (smoke class) (name class))
+ (undefined-class () class))
hunk ./src/objects/enum.lisp 47
- (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)))))))
hunk ./src/objects/enum.lisp 53
- (check-enum-type (eval (first case))
+ (check-enum-type (eval (first-key (first case)))
hunk ./src/objects/enum.lisp 56
- ; (check-enum-type (enum-type ,keyform)
- ; (enum-type ,(first (first cases))))
+ ;; (check-enum-type (enum-type ,keyform)
+ ;; (enum-type ,(first (first cases))))
hunk ./src/objects/enum.lisp 60
- 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)))))))
hunk ./src/objects/stack.lisp 36
- [_$_]
hunk ./src/objects/stack.lisp 42
+ (const-p :reader const-p
+ :initarg :const-p
+ :initform nil
+ :documentation "Returns true when the object is const and nil otherwise.")
hunk ./src/objects/stack.lisp 102
+(defvar *to-lisp-translations* (make-hash-table :test 'equal))
+
hunk ./src/objects/stack.lisp 166
-(defvar *to-lisp-translations* (make-hash-table :test 'equal))
hunk ./src/objects/type.lisp 61
- (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))))
hunk ./src/objects/type.lisp 122
- (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)))
hunk ./src/overload-resolution.lisp 3
+;;;
+;;; We handle only the most common cases. Stuff like virtual inheritance
+;;; that is not needed is not implemented.
hunk ./src/overload-resolution.lisp 81
-(defmacro push-candidate-method (index name argument-count class methods)
+(defmacro push-candidate-method (index name argument-count class methods
+ const-p)
hunk ./src/overload-resolution.lisp 112
- (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))))
hunk ./src/overload-resolution.lisp 129
-(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)
hunk ./src/overload-resolution.lisp 133
- (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)))))
hunk ./src/overload-resolution.lisp 168
-(defgeneric conversion< (conversion1 conversion2)
- (:documentation
- "Returns true when CONVERSION1 is better than CONVERSION2.")
+(defgeneric conversion<= (conversion1 conversion2)
hunk ./src/overload-resolution.lisp 173
- (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))))))
hunk ./src/overload-resolution.lisp 192
- (:documentation
- "Returns true when the standard conversion sequence CONVERSION1
- is indistinguishable from CONVERSION2.")
hunk ./src/overload-resolution.lisp 193
- (= (conversion-rank conversion1) (conversion-rank conversion2)))
+ (and (conversion<= conversion1 conversion2)
+ (conversion<= conversion2 conversion1)))
hunk ./src/overload-resolution.lisp 202
- (if (conversion< conversion1 conversion2)
+ (if (conversion<= conversion1 conversion2)
hunk ./src/overload-resolution.lisp 241
- (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)))))
hunk ./src/overload-resolution.lisp 258
-(defun+using-types find-best-viable-function (name arguments class)
+(defun+using-types find-best-viable-function (name arguments class
+ &optional const-p)
hunk ./src/overload-resolution.lisp 264
- name arguments class))
+ name arguments class const-p))
hunk ./src/overload-resolution.lisp 266
-(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)
hunk ./src/overload-resolution.lisp 272
- class))
+ class const-p))
hunk ./src/overload-resolution.lisp 276
- (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))))))))))
hunk ./src/overload-resolution.lisp 397
- (derived-p (object.type-of) (get-class type)))
+ (derived-p (object.type-of) (get-class type))
+ (find-smoke-class (get-class type)))
hunk ./src/overload-resolution.lisp 449
- (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))))
hunk ./src/overload-resolution.lisp 459
- (assert (not (void-p type))
- ()
- "Conversion operators not supported by Smoke.
-Update to Smoke >= r955426.")
hunk ./src/overload-resolution.lisp 473
- (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))
hunk ./src/overload-resolution.lisp 514
- (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))))
hunk ./src/package.lisp 38
+ #:const-p
hunk ./src/smoke-to-clos.lisp 106
- (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)