repos / smoke / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
SBCL: compile time overload resolution
Annotate for file src/overload-resolution.lisp
2009-04-17 tobias 1 ;;; C++ overload resolution
15:26:55 ' 2 ;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf
' 3
' 4 (in-package :smoke)
' 5
2009-07-22 tobias 6 (defun cstring= (string1 string2)
22:26:05 ' 7 "Returns T when the C strings STRING1 and STRING2 are equal
' 8 and NIL otherwise."
' 9 (declare (optimize (speed 3) (safety 0)))
' 10 (dotimes (i array-total-size-limit)
' 11 (let ((char1 (mem-aref string1 :char i))
' 12 (char2 (mem-aref string2 :char i)))
' 13 (when (/= char1 char2)
' 14 (return-from cstring= nil))
' 15 (when (or (= 0 char1)
' 16 (= 0 char2))
' 17 (return-from cstring= (= char1 char2))))))
' 18
2009-06-22 tobias 19 (declaim (inline cmp))
12:18:08 ' 20 (defun cmp (a b)
2009-07-22 tobias 21 "Returns -1 if a < b; 0 if a = b and 1 if a > b"
22:26:05 ' 22 (declare (values (integer -1 1)))
' 23 (if (< a b)
' 24 -1
' 25 (if (> a b)
' 26 1
' 27 0)))
2009-06-22 tobias 28
2009-07-22 tobias 29 (declaim (inline cstring-cmp))
22:26:05 ' 30 (defun cstring-cmp (string1 string2)
' 31 "Compares the C strings STRING1 and STRING2."
' 32 (declare (foreign-pointer string1 string2)
' 33 (values (integer -1 1))
' 34 (optimize (speed 3)))
' 35 (dotimes (i array-total-size-limit (error "omg"))
' 36 (let ((char1 (mem-aref string1 :char i))
' 37 (char2 (mem-aref string2 :char i)))
' 38 (when (/= char1 char2)
' 39 (return-from cstring-cmp (if (< char1 char2) -1 1)))
' 40 (when (= 0 char1) ;; <=> (= 0 char2)
' 41 (return-from cstring-cmp 0)))))
2009-04-17 tobias 42
2009-06-22 tobias 43 (defun cstring/= (string1 string2)
12:18:08 ' 44 "Returns T when the C strings STRING1 and STRING2 are not equal
' 45 and NIL otherwise."
2009-07-22 tobias 46 (declare (optimize (speed 3)))
22:26:05 ' 47 (dotimes (i array-total-size-limit)
' 48 (let ((char1 (mem-aref string1 :char i))
' 49 (char2 (mem-aref string2 :char i)))
' 50 (when (/= char1 char2)
' 51 (return-from cstring/= i))
' 52 (when (= 0 char1)
' 53 (return-from cstring/= nil)))))
' 54
' 55 (declaim (inline smoke-method-name))
' 56 (defun smoke-method-name (method)
' 57 (mem-aref (smoke-array-pointer (smoke-module-method-names
' 58 (smoke-method-smoke method)))
' 59 :pointer
' 60 (the (smoke-index 0)
' 61 (method-slot-value method 'name))))
2009-04-17 tobias 62
2009-06-22 tobias 63 (defun method-cmp (method class-id name)
12:18:08 ' 64 "Compares METHOD to the method with NAME of class CLASS-ID."
' 65 (declare (foreign-pointer name)
' 66 (type (smoke-index 0) class-id)
' 67 (smoke-method method)
2009-07-22 tobias 68 (values (integer -1 1))
2009-06-22 tobias 69 (optimize (speed 3) (debug 0) (safety 0)))
12:18:08 ' 70 (let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))
' 71 (the (smoke-index 0) class-id))))
2009-07-22 tobias 72 (declare (type (integer -1 1) id-cmp)
22:26:05 ' 73 (dynamic-extent id-cmp))
2009-06-22 tobias 74 (if (/= 0 id-cmp)
12:18:08 ' 75 id-cmp
2009-07-22 tobias 76 (cstring-cmp (smoke-method-name method)
2009-06-22 tobias 77 name))))
12:18:08 ' 78
' 79 (defun first-unabigious-index (smoke index)
' 80 (declare (type smoke-index index)
2009-04-17 tobias 81 (optimize (speed 3)))
2009-06-22 tobias 82 (if (>= index 0)
12:18:08 ' 83 index
' 84 (mem-aref (smoke-module-ambiguous-method-list smoke)
' 85 'smoke-index
' 86 (- index))))
2009-04-17 tobias 87
2009-06-22 tobias 88 (defun find-method-for-class (name class)
12:18:08 ' 89 "Returns the index of a method with name NAME for class CLASS."
' 90 (declare (type foreign-pointer name)
' 91 (type smoke-class class)
' 92 (optimize (speed 3)))
' 93 (let* ((start 1) ;; 0 is "no method"
2009-06-30 tobias 94 (class-id (id class))
22:47:39 ' 95 (smoke (smoke class))
2009-07-03 tobias 96 (end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))
2009-07-08 tobias 97 (declare (type (smoke-index 0) start end))
2009-06-22 tobias 98 (loop until (> start end) do
12:18:08 ' 99 (let* ((index (the smoke-index (floor (+ end start) 2)))
' 100 (method (make-smoke-method
' 101 :smoke smoke
' 102 :id (the (smoke-index 0)
' 103 (first-unabigious-index
' 104 smoke
' 105 (foreign-slot-value
' 106 (mem-aref (smoke-array-pointer
' 107 (smoke-module-method-maps
' 108 smoke))
' 109 'smoke-method-map index)
' 110 'smoke-method-map
' 111 'method)))))
2009-07-22 tobias 112 (cmp (the (integer -1 1) (method-cmp method class-id name))))
22:26:05 ' 113 (declare (type (integer -1 1) cmp)
2009-07-08 tobias 114 (dynamic-extent method index cmp))
2009-07-22 tobias 115 (ecase cmp
22:26:05 ' 116 (-1 (setf start (1+ index)))
' 117 (0 (return-from find-method-for-class index))
' 118 (1 (setf end (1- index)))))))
2009-06-22 tobias 119 -1)
2009-04-17 tobias 120
2009-08-27 tobias 121 (defmacro push-candidate-method (index name argument-count class methods)
2009-06-22 tobias 122 (with-gensyms (method-map method-index method ambig-index i smoke)
12:18:08 ' 123 `(let* ((,smoke (smoke ,class))
' 124 (,method-map (mem-aref
' 125 (smoke-array-pointer
' 126 (smoke-module-method-maps ,smoke))
' 127 'smoke-method-map
2009-07-22 tobias 128 ,index))
2009-06-22 tobias 129 (,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))
12:18:08 ' 130 (,method (make-smoke-method
' 131 :smoke ,smoke
' 132 :id (first-unabigious-index
' 133 ,smoke
' 134 ,method-index))))
' 135 (declare (type smoke-index ,method-index))
' 136 (if (cstring/= ,name
' 137 (smoke-method-name ,method))
' 138 nil
' 139 (progn
' 140 (when (= (the smoke-index ,argument-count)
' 141 (the smoke-index (get-arguments-length ,method)))
' 142 (if (< ,method-index 0)
' 143 (let ((,ambig-index (- ,method-index)))
' 144 (declare (type smoke-index ,ambig-index))
' 145 (loop as ,i = (the smoke-index
' 146 (mem-aref (smoke-module-ambiguous-method-list
' 147 ,smoke)
' 148 'smoke-index
' 149 ,ambig-index))
' 150 while (> (the smoke-index ,i) 0) do
2009-08-27 tobias 151 (incf ,ambig-index)
11:43:13 ' 152 (push (make-smoke-method :smoke ,smoke
' 153 :id ,i)
' 154 ,methods)))
' 155 (push ,method ,methods)))
2009-06-22 tobias 156 t)))))
2009-05-11 tobias 157
2009-08-30 tobias 158 (defun all-smoke-superclasses (class)
14:12:44 ' 159 "Returns a list of all super-classes of CLASS and CLASS itself."
' 160 (declare (optimize (speed 3)))
' 161 (let ((classes (list class)))
' 162 (dolist (class (closer-mop:class-direct-superclasses class) classes)
' 163 (when (typep class 'smoke-standard-class)
' 164 (setf classes (append (all-smoke-superclasses class) classes))))))
' 165
2009-08-27 tobias 166 (defun viable-functions (name argument-count class)
11:43:13 ' 167 "Returns a list of methods named NAME that take ARGUMENT-COUNT methods."
' 168 ;; 13.3.2
' 169 ;; FIXME make a lazy map-viable-functions to allow returning early,
' 170 ;; when an exact match is found.
2009-06-22 tobias 171 (declare (optimize (speed 3)))
12:18:08 ' 172 (with-foreign-string (name name)
2009-07-22 tobias 173 (let ((methods)
22:26:05 ' 174 (smoke (smoke class)))
2009-08-27 tobias 175 (dolist (class (all-smoke-superclasses class))
2009-07-22 tobias 176 (let ((start-index (find-method-for-class name class)))
22:26:05 ' 177 (declare (type smoke-index start-index))
' 178 (loop for index from start-index downto 1
' 179 while (push-candidate-method index name argument-count class
' 180 methods))
' 181 (loop for index from (1+ start-index)
' 182 to (the smoke-index (smoke-array-length
' 183 (smoke-module-method-maps smoke)))
' 184 while (push-candidate-method index name argument-count class
' 185 methods))))
2009-06-22 tobias 186 methods)))
12:18:08 ' 187
2009-07-22 tobias 188 (eval-when (:compile-toplevel :load-toplevel :execute)
22:26:05 ' 189 (defconstant +exact-match+ 0)
' 190 (defconstant +promotion+ 1)
' 191 (defconstant +conversion+ 2))
' 192
2009-07-08 tobias 193 (defclass std-conversion ()
20:41:19 ' 194 ((function-name :accessor conversion-function-name
' 195 :initarg :conversion-function-name))
' 196 (:documentation "A conversion"))
2009-04-17 tobias 197
2009-07-08 tobias 198 (defclass exact-match (std-conversion)
20:41:19 ' 199 ((rank :reader rank
' 200 :allocation :class
' 201 :type fixnum
' 202 :initform +exact-match+)))
2009-04-17 tobias 203
2009-07-08 tobias 204 (defclass promotion (std-conversion)
20:41:19 ' 205 ((rank :reader rank
' 206 :allocation :class
' 207 :type fixnum
' 208 :initform +promotion+)))
2009-04-17 tobias 209
2009-07-08 tobias 210 (defclass number-conversion (std-conversion)
20:41:19 ' 211 ((rank :reader rank
' 212 :allocation :class
' 213 :type fixnum
' 214 :initform +conversion+)))
2009-04-17 tobias 215
2009-07-08 tobias 216 (defclass pointer-conversion (std-conversion)
20:41:19 ' 217 ((rank :reader rank
' 218 :allocation :class
' 219 :type fixnum
' 220 :initform (1+ +conversion+))
' 221 (from :reader from
' 222 :initarg :from)
' 223 (to :reader to
' 224 :initarg :to)))
2009-04-17 tobias 225
2009-07-08 tobias 226 (defclass boolean-conversion (std-conversion)
20:41:19 ' 227 ((rank :reader rank
' 228 :allocation :class
' 229 :type fixnum
' 230 :initform (+ 2 +conversion+))))
2009-04-17 tobias 231
2009-07-08 tobias 232 (defclass user-conversion (std-conversion)
20:41:19 ' 233 ((rank :reader rank
' 234 :allocation :class
' 235 :type fixnum
' 236 :initform (+ 3 +conversion+))))
2009-04-17 tobias 237
2009-08-27 tobias 238 (defgeneric conversion< (conversion1 conversion2)
11:43:13 ' 239 (:documentation
' 240 "Returns true when CONVERSION1 is better than CONVERSION2.")
2009-04-17 tobias 241 ;; 13.3.3.2 Ranking implicit conversion sequences
15:26:55 ' 242 ;; 4
' 243 (:method (conversion1 conversion2)
2009-06-22 tobias 244 (declare (optimize (speed 3)))
2009-08-27 tobias 245 (or (null conversion2)
2009-07-08 tobias 246 (< (the fixnum (rank conversion1))
20:41:19 ' 247 (the fixnum (rank conversion2)))))
2009-04-17 tobias 248 (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
2009-06-22 tobias 249 (declare (optimize (speed 3)))
2009-07-08 tobias 250 (if (eq (from conversion1) (from conversion2))
2009-04-17 tobias 251 ;; A->B < A->C <=> B subclass of C
2009-07-08 tobias 252 (subtypep (to conversion1) (to conversion2))
20:41:19 ' 253 (if (eq (to conversion1) (to conversion2))
2009-04-17 tobias 254 ;; B->A < C->A <=> B subclass of C
2009-07-08 tobias 255 (subtypep (from conversion1) (from conversion2))
2009-04-17 tobias 256 nil))))
15:26:55 ' 257
' 258 (defgeneric conversion= (conversion1 conversion2)
2009-08-27 tobias 259 (:documentation
11:43:13 ' 260 "Returns true when the standard conversion sequence CONVERSION1
' 261 is indistinguishable from CONVERSION2.")
2009-04-17 tobias 262 (:method (conversion1 conversion2)
2009-07-08 tobias 263 (= (rank conversion1) (rank conversion2)))
2009-05-11 tobias 264 (:method ((conversion1 (eql nil)) (conversion2 (eql nil)))
2009-07-22 tobias 265 t)
22:26:05 ' 266 (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
' 267 (and (not (conversion< conversion1 conversion2))
' 268 (not (conversion< conversion2 conversion1)))))
2009-04-17 tobias 269
15:26:55 ' 270 (defun max-conversion (conversion1 conversion2)
2009-05-11 tobias 271 "Returns the greater conversion of CONVERSION1 and CONVERSION2."
2009-04-17 tobias 272 (if (null conversion2)
15:26:55 ' 273 conversion1
2009-08-27 tobias 274 (if (conversion< conversion1 conversion2)
2009-04-17 tobias 275 conversion2
15:26:55 ' 276 conversion1)))
2009-05-11 tobias 277
2010-02-20 tobias 278 (eval-when (:compile-toplevel :load-toplevel :execute)
17:24:36 ' 279 (defun conversion-function (name &optional arg)
' 280 (if arg
' 281 `(if (using-typep)
' 282 `(,,name
' 283 (find-class ',(class-name ,arg)))
' 284 #'(lambda (object)
' 285 (funcall (fdefinition ,name)
' 286 object ,arg)))
' 287 `(if (using-typep)
' 288 ,name
' 289 (fdefinition ,name)))))
' 290
2009-09-01 tobias 291 (defmacro make-match (type &optional (name ''identity)
11:44:21 ' 292 (argument nil)
2009-05-11 tobias 293 &rest args)
2009-07-08 tobias 294 `(make-instance ,type
20:41:19 ' 295 :conversion-function-name ,(conversion-function name argument)
' 296
2009-09-01 tobias 297 ,@args))
2009-04-17 tobias 298
2009-05-11 tobias 299 (defun+using-type get-conversion-sequence object (object type &optional user)
2009-07-01 tobias 300 "Retrains a conversion sequence to convert a instance of type CLASS
2009-05-11 tobias 301 to an instance of type TYPE. When USER is true user conversions are considered."
2009-07-08 tobias 302 (if-let (match (call-using-type exact-match object type))
14:56:52 ' 303 (if (eql t match)
' 304 (make-match 'exact-match)
' 305 (make-match 'exact-match match))
' 306 (or (call-using-type promotion object type)
' 307 (call-using-type conversion object type)
' 308 (and user
' 309 (call-using-type user-conversion object type)))))
2009-04-17 tobias 310
2009-05-11 tobias 311 (defun+using-types standard-conversion-sequence (method classes &optional user)
11:07:39 ' 312 "Returns the conversion sequences to convert the arguments of types CLASSES
' 313 to the types required by METHOD."
2009-08-27 tobias 314 (let ((max-rank)
11:43:13 ' 315 (conversions))
' 316 (loop for type in (arguments method)
' 317 for class in classes do
' 318 (let ((rank (call-using-type get-conversion-sequence class type user)))
' 319 (when (null rank)
' 320 (setf max-rank nil)
' 321 (return nil))
' 322 (setf max-rank (max-conversion rank max-rank))
' 323 (push (conversion-function-name rank) conversions)))
' 324 (values max-rank (reverse conversions))))
2009-04-17 tobias 325
2009-05-11 tobias 326 (defun+using-types conversion-sequence (method classes)
11:07:39 ' 327 (call-using-types standard-conversion-sequence method classes t))
2009-04-17 tobias 328
2009-08-27 tobias 329 (defun+using-types find-best-viable-function (name arguments class)
2009-05-11 tobias 330 "Returns the method named NAME of class CLASS that can be called
11:07:39 ' 331 using arguments of types TYPES with the lowest conversion sequence."
' 332 (call-using-types find-best-viable-function2
' 333 (function-using-types conversion-sequence)
2009-08-27 tobias 334 name arguments class))
2009-04-17 tobias 335
2009-08-27 tobias 336 (defun+using-types find-best-viable-function2 (get-sequence name objects class)
11:43:13 ' 337 (declare (type (function (t list) (values t function)) get-sequence))
2009-05-11 tobias 338 (when (and (using-typep)
11:07:39 ' 339 (not (typep class 'smoke-standard-class)))
' 340 (throw 'unspecific-type class))
2009-05-11 tobias 341 (let ((viable-functions (viable-functions name (length objects)
2009-08-27 tobias 342 class))
2009-05-11 tobias 343 (best-rank)
2009-04-17 tobias 344 (best-method)
15:26:55 ' 345 (conversions))
2009-08-27 tobias 346 (loop for method in viable-functions do
11:43:13 ' 347 (multiple-value-bind (rank method-conversions)
' 348 (funcall get-sequence method objects)
' 349 ;; FIXME test for ambiguous overload #'conversion=
' 350 (when (and rank (conversion< rank best-rank))
' 351 (setf best-rank rank)
' 352 (setf best-method method)
' 353 (setf conversions method-conversions)
' 354 (when (conversion= rank (make-match 'exact-match))
' 355 (return)))))
' 356 (values best-method conversions)))
2009-04-17 tobias 357
2009-05-11 tobias 358 (defvar *from-lisp-translations* (make-hash-table :test 'equal))
11:07:39 ' 359
' 360 (defmacro define-from-lisp-translation (type-names lisp-type
' 361 &optional
' 362 (conversion-function-name 'identity))
2009-05-11 tobias 363 "Defines a translation from LISP-TYPE to the C++ types TYPE-NAMES using
14:11:35 ' 364 the function CONVERSION-FUNCTION-NAME."
2009-05-11 tobias 365 `(progn ,@(loop for type-name in (ensure-list type-names)
2009-05-11 tobias 366 collect `(setf (gethash ,type-name *from-lisp-translations*)
2009-09-02 tobias 367 #'(lambda (type)
11:49:34 ' 368 (and (subtypep type ',lisp-type)
2009-05-11 tobias 369 ',conversion-function-name))))))
11:07:39 ' 370
' 371 (define-from-lisp-translation ("void*" "const void*" "void**" "const void**")
' 372 foreign-pointer)
' 373
' 374 ;; FIXME grovel this?
' 375 (deftype c-integer (ctype)
' 376 (let ((bits (* 8 (foreign-type-size ctype))))
2009-05-11 tobias 377 (if (starts-with-subseq
2009-05-11 tobias 378 (symbol-name :unsigned)
11:07:39 ' 379 (symbol-name ctype))
' 380 `(unsigned-byte ,bits)
' 381 `(signed-byte ,bits))))
' 382
' 383
' 384 (defun+using-type exact-match object (object type)
' 385 "Test for an exact match."
2009-04-17 tobias 386 (case (type-id type)
2009-06-22 tobias 387 (0 (when-let (test (gethash (name type) *from-lisp-translations*))
2009-09-02 tobias 388 (funcall test (object.type-of))))
2009-05-11 tobias 389 (1 (object.typep 'boolean))
11:07:39 ' 390 (2 (object.typep 'standard-char))
' 391 (3 (object.typep '(c-integer :unsigned-char)))
' 392 (4 (object.typep '(c-integer :short)))
' 393 (5 (object.typep '(c-integer :unsigned-short)))
' 394 (6 (object.typep '(c-integer :int)))
' 395 (7 (object.typep '(c-integer :unsigned-int)))
' 396 (10 (object.typep 'single-float))
' 397 (11 (object.typep 'double-float))
2010-01-25 tobias 398 (12 (object.typep 'enum)) ;; FIXME enum-type
2009-09-09 tobias 399 (13 (and (object.typep 'smoke-standard-object)
13:22:32 ' 400 (smoke-type= (get-class type) (object.type-of))))))
2009-05-11 tobias 401
11:07:39 ' 402
' 403 (defun make-cleanup-pointer (pointer cleanup-function)
2009-05-26 tobias 404 "Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument
09:54:47 ' 405 when it is finalized."
2009-05-11 tobias 406 (let ((address (pointer-address pointer)))
11:07:39 ' 407 (tg:finalize pointer #'(lambda ()
' 408 (funcall cleanup-function
' 409 (make-pointer address))))))
' 410
2009-04-17 tobias 411 (defun make-auto-pointer (pointer)
15:26:55 ' 412 "Returns a pointer that frees the memory at POINTER when it is finalized."
2009-05-26 tobias 413 (make-cleanup-pointer pointer #'foreign-free))
2009-04-17 tobias 414
2009-05-11 tobias 415 (defun coerce-c-string (string)
11:07:39 ' 416 (make-auto-pointer (foreign-string-alloc string)))
' 417
2010-02-20 tobias 418 (defun coerce-enum (enum)
2009-05-11 tobias 419 (cxx-support:value enum))
11:07:39 ' 420
2009-07-02 tobias 421 (defun coerce-double-float (number)
21:51:50 ' 422 (float number 0d0))
' 423
' 424 ;; FIXME incomplete
2009-05-11 tobias 425 (defun+using-type promotion object (object type)
2009-04-17 tobias 426 (declare (smoke-type type))
15:26:55 ' 427 (case (type-id type)
2009-05-11 tobias 428 (0 (when (and (string= (name type) "const char*")
11:07:39 ' 429 (object.typep 'string))
' 430 (make-match 'promotion 'coerce-c-string)))
' 431 (6 (when (object.typep 'enum)
2010-02-20 tobias 432 (make-match 'promotion 'coerce-enum)))
2009-05-11 tobias 433 (7 (when (object.typep 'enum)
2010-02-20 tobias 434 (make-match 'promotion 'coerce-enum)))
2009-07-02 tobias 435 (11 (when (object.typep 'real)
2010-02-20 tobias 436 (make-match 'promotion 'coerce-double-float)))))
2009-04-17 tobias 437
2009-05-26 tobias 438 (declaim (inline coerce-to-class))
2009-05-11 tobias 439 (defun coerce-cast (object to-class)
11:07:39 ' 440 (cast object to-class))
2009-04-17 tobias 441
2009-05-11 tobias 442 (defun coerce-to-void (object)
11:07:39 ' 443 object)
2009-04-17 tobias 444
2009-05-11 tobias 445 (defun+using-type conversion-cast object (object type)
11:07:39 ' 446 (when (and (class-p type)
' 447 (object.typep 'smoke-standard-object)
2009-08-27 tobias 448 (derived-p (object.type-of) (get-class type)))
2009-05-11 tobias 449 (make-match 'pointer-conversion
11:07:39 ' 450 'coerce-cast
' 451 (find-smoke-class (get-class type))
' 452 :from (object.type-of)
' 453 :to (find-smoke-class (get-class type)))))
' 454
' 455 (defun+using-type conversion-void object (object type)
' 456 (when (and (string= (name type) "void*")
' 457 (object.typep 'smoke-standard-object))
' 458 (make-match 'pointer-conversion
' 459 'coerce-void
' 460 nil
' 461 :from (object.type-of)
' 462 :to (find-class 't))))
' 463
' 464 (defun+using-type conversion-pointer object (object type)
2009-07-22 tobias 465 ;; Not using pointer-p to allow passing a raw pointer for
22:26:05 ' 466 ;; objects on the stack and references
2009-05-24 tobias 467 ;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )
21:28:44 ' 468 ;;
2009-07-22 tobias 469 ;; FIXME this breaks passing pointers to references
22:26:05 ' 470 ;; e.g.: calling the function foo(QByteArray& foo)
' 471 ;; with (foo pointer) assumes pointer to point to a QByteArray,
' 472 ;; but actually the conversion sequence QByteArray(pointer) should be used.
' 473 ;; When pointer is a null pointer it fails horribly!.
2009-05-24 tobias 474 (when (and (or (= 0 (type-id type)) ; voidp
21:28:44 ' 475 (= 13 (type-id type))) ; class
2009-05-11 tobias 476 (object.typep 'foreign-pointer))
11:07:39 ' 477 (make-match 'pointer-conversion 'identity nil
2009-08-02 tobias 478 :from (find-class 't)
10:12:41 ' 479 :to (find-class 't)))) ;; FIXME get the class when applicable
2009-05-11 tobias 480
11:07:39 ' 481
' 482 (defun+using-type conversion object (object type)
' 483 (or (call-using-type conversion-cast object type)
' 484 (call-using-type conversion-void object type)
' 485 (call-using-type conversion-pointer object type)))
' 486
' 487 (defun+using-type user-conversion object (object type)
' 488 (or (call-using-type operator-conversion object type)
' 489 (call-using-type constructor-conversion object type)))
' 490
' 491 (defun+using-type operator-conversion object (object type)
' 492 (when (object.typep 'smoke-standard-object)
' 493 (let ((method (find-smoke-method (object.type-of)
2009-07-24 tobias 494 (format nil "operator ~A"
13:32:23 ' 495 (if (class-p type)
' 496 (name (get-class type))
' 497 (name type))))))
2009-05-11 tobias 498 (when (valid-p method)
2009-08-27 tobias 499 (assert (not (void-p type))
11:43:13 ' 500 ()
' 501 "Conversion operators not supported by Smoke.
' 502 Update to Smoke >= r955426.")
2009-07-24 tobias 503 (make-match 'user-conversion
13:32:23 ' 504 (lispify (name method) :cxx))))))
2009-05-11 tobias 505
2009-05-26 tobias 506 (declaim (inline coerce-to-class))
2009-05-11 tobias 507 (defun coerce-to-class (object to-class)
11:07:39 ' 508 (make-instance to-class
' 509 :args (list object)))
' 510
' 511 (defun+using-type constructor-conversion object (object type)
' 512 (when (class-p type)
2009-08-27 tobias 513 (let ((to-class (find-smoke-class (get-class type))))
11:43:13 ' 514 (when (call-using-types find-best-viable-function2
' 515 (if (using-typep)
' 516 #'standard-conversion-sequence-using-types
' 517 #'standard-conversion-sequence)
2009-07-22 tobias 518 (format nil "~A" (name (get-class type)))
2009-08-27 tobias 519 (list object) to-class)
2010-01-10 tobias 520 (make-match 'user-conversion
17:31:42 ' 521 'coerce-to-class
' 522 to-class)))))
2009-04-17 tobias 523
15:26:55 ' 524 (defun call-sequence (method object sequence &rest args)
' 525 (s-call method object
2009-05-11 tobias 526 (mapcar #'(lambda (conversion argument)
11:07:39 ' 527 (funcall conversion argument))
' 528 sequence args)))
2009-05-27 tobias 529
17:47:28 ' 530 (defun format-no-applicable-cxx-method (stream name class arguments)
' 531 (format stream
' 532 "No applicable method ~S of ~A for ~S.
2009-07-02 tobias 533 Candidates are:~{~T~A~%~}."
2009-05-27 tobias 534 name class arguments
17:47:28 ' 535 (mapcar #'signature
' 536 (viable-functions name
' 537 (length arguments)
' 538 (smoke-class-of class)))))
' 539
' 540 (define-condition no-applicable-cxx-method (error)
' 541 ((method :initarg :method :reader condition-method)
' 542 (class :initarg :class :reader condition-class)
' 543 (arguments :initarg :arguments :reader condition-arguments))
' 544 (:report (lambda (condition stream)
' 545 (format-no-applicable-cxx-method stream
' 546 (condition-method condition)
' 547 (condition-class condition)
' 548 (condition-arguments condition)))))
2009-09-01 tobias 549
2009-04-17 tobias 550 (defun call-using-args (object-or-class name arguments)
2009-06-22 tobias 551 "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."
2009-09-09 tobias 552 (declare (optimize (speed 3)))
2009-08-27 tobias 553 (if (null arguments)
11:43:13 ' 554 (let ((method (find-smoke-method (smoke-class-of object-or-class)
' 555 name)))
' 556 (unless (valid-p method)
' 557 (error (make-condition 'no-applicable-cxx-method
' 558 :method name
' 559 :class object-or-class
' 560 :arguments arguments)))
' 561 (if (static-p method)
' 562 (s-call method (null-pointer))
' 563 (s-call method (cast object-or-class (get-class method)))))
' 564 (multiple-value-bind (method sequence)
' 565 (find-best-viable-function name
' 566 arguments
' 567 (smoke-class-of object-or-class))
' 568 (when (null method)
' 569 (error (make-condition 'no-applicable-cxx-method
' 570 :method name
' 571 :class object-or-class
' 572 :arguments arguments)))
' 573 (if (static-p method)
' 574 (apply #'call-sequence method (null-pointer) sequence arguments)
' 575 (apply #'call-sequence method (cast object-or-class (get-class method))
' 576 sequence arguments)))))
Crece desde el pueblo el futuro / crece desde el pie