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