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