src/overload-resolution.lisp
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/overload-resolution.lisp 2014-10-30 08:11:34.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:11:34.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))))