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.

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

+++ new-smoke/src/bindings.lisp 2014-10-30 07:05:54.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*)

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

+++ new-smoke/src/class-map.lisp 2014-10-30 07:05:54.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))

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

+++ new-smoke/src/clos.lisp 2014-10-30 07:05:54.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))

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

+++ new-smoke/src/objects/class.lisp 2014-10-30 07:05:54.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)

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

+++ new-smoke/src/objects/enum.lisp 2014-10-30 07:05:54.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))

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

+++ new-smoke/src/objects/stack.lisp 2014-10-30 07:05:54.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))

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

+++ new-smoke/src/objects/type.lisp 2014-10-30 07:05:54.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)

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

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:05:54.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))))

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

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

@@ -35,6 +35,7 @@

#:make-cleanup-pointer

#:make-auto-pointer

+ #:const-p

#:pointer

#:define-smoke-module

#:define-takes-ownership

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

+++ new-smoke/src/smoke-to-clos.lisp 2014-10-30 07:05:54.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)