repos / smoke / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Fix for r1077826. Not instantiable parent classes are external. (QAbstractPrintDialog)
Annotate for file src/clos.lisp
2009-04-05 tobias 1 (in-package #:smoke)
15:36:29 ' 2
' 3 (declaim (inline lispify))
' 4 (defun lispify (name &optional (package nil))
' 5 "Returns the interned symbol for name in Lisp style."
' 6 (declare (string name)
' 7 (optimize (speed 3)))
' 8 (if (null package)
' 9 (values (intern (cxx-to-lisp name)))
' 10 (values (intern (cxx-to-lisp name) package))))
' 11
' 12 (defmacro define-string-transform (name documentation &body states)
' 13 "Defines a function to transform a string."
' 14 (let ((output (gensym))
' 15 (index (gensym))
' 16 (length (gensym)))
' 17 `(defun ,name (input)
' 18 ,documentation
' 19 (declare (simple-string input)
' 20 (optimize (speed 3)))
2009-07-22 tobias 21 ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than
22:26:05 ' 22 ;; VECTOR-PUSH-EXTEND.
2009-04-05 tobias 23 (let ((,output "")
15:36:29 ' 24 (,index 0)
' 25 (,length (length input))
' 26 (char #\Null))
' 27 (declare (base-char char))
' 28 (macrolet ((next-char ()
' 29 `(if (>= ,',index ,',length)
' 30 (return-from transform ,',output)
' 31 (progn
' 32 (setf char (aref input ,',index))
' 33 (incf ,',index))))
' 34 (go-next (tag)
' 35 `(progn (next-char)
' 36 (go ,tag)))
' 37 (append-char (char)
' 38 `(setf ,',output (concatenate 'string
' 39 ,',output
' 40 (string ,char)))))
' 41 (block transform
' 42 (tagbody
' 43 (next-char) ;; Get first char
' 44 ,@(reduce #'append
' 45 (mapcar #'(lambda (state)
' 46 (if (stringp (second state))
' 47 `(,(first state) . ,(cddr state))
' 48 state))
' 49 states)))))))))
' 50
' 51
' 52 (define-string-transform lisp-to-cxx
' 53 "Converts LISP-STYLE to camelCase.
2009-07-01 tobias 54 Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not necessarily return
10:54:01 ' 55 a string equal to SOME-STRING."
2009-04-05 tobias 56 (default
2009-07-01 tobias 57 "Down case, convert _ and dispatch."
2009-04-05 tobias 58 (case char
15:36:29 ' 59 (#\- (go-next camel-upcase))
' 60 (#\. (go-next namespace))
' 61 (t (append-char (char-downcase char))
' 62 (go-next default))))
' 63 (camel-upcase
' 64 "Convert camelCase to lisp-style."
' 65 (append-char char)
' 66 (go-next default))
' 67 (namespace
' 68 "Convert . to ::"
' 69 (append-char #\:)
' 70 (append-char #\:)
' 71 (go default)))
' 72
' 73 (define-string-transform cxx-to-lisp
2009-04-17 tobias 74 "Returns camelCase STRING in lisp-style."
2009-04-05 tobias 75 (begin
2009-07-01 tobias 76 "Strip leading Q or K."
2009-04-05 tobias 77 (case char
15:36:29 ' 78 (#\K (go-next default))
' 79 (#\Q (go-next default))
' 80 (t (go default))))
' 81 (default
2009-07-01 tobias 82 "Up case, convert _ and dispatch."
2009-04-05 tobias 83 (case char
15:36:29 ' 84 (#\: (go-next namespace))
' 85 (#\_ (append-char #\-)
' 86 (go-next default))
2009-04-17 tobias 87 (#\ (append-char #\-) ;; space (cast operators)
15:26:55 ' 88 (go-next default))
2009-04-05 tobias 89 (t (append-char (char-upcase char))
15:36:29 ' 90 (if (lower-case-p char)
' 91 (go-next camel-case)
' 92 (go-next default)))))
' 93 (namespace
2009-06-22 tobias 94 "C++ namespace separator"
2009-04-05 tobias 95 (assert (eql #\: char))
15:36:29 ' 96 (append-char #\.)
' 97 (go-next default))
' 98 (camel-case
' 99 "Convert camelCase to lisp-style."
' 100 (if (upper-case-p char)
' 101 (progn
' 102 (append-char #\-)
' 103 (append-char char)
' 104 (go-next default))
' 105 (go default))))
' 106
' 107
' 108 (defmethod print-object ((object smoke-standard-object) stream)
2009-05-27 tobias 109 (if (slot-boundp object 'pointer)
17:22:08 ' 110 (print-unreadable-object (object stream :type t)
2009-08-27 tobias 111 (when (const-p object)
11:43:13 ' 112 (princ "CONST " stream))
2009-05-27 tobias 113 (princ (pointer object) stream))
17:22:08 ' 114 (call-next-method)))
2009-04-05 tobias 115
15:36:29 ' 116 (defclass smoke-standard-class (standard-class smoke-class)
2009-05-24 tobias 117 ()
2009-04-05 tobias 118 (:documentation "A Smoke C++ class"))
15:36:29 ' 119
2009-05-31 tobias 120 (defclass cxx:class (smoke-standard-class)
2009-07-08 tobias 121 ()
2009-05-31 tobias 122 (:documentation "Metaclass to extend Smoke Objects."))
2009-05-14 tobias 123
2009-08-30 tobias 124 (defclass smoke-multi-superclass-mixin ()
14:12:44 ' 125 ((extra-objects :reader extra-objects
' 126 :initarg :extra-objects)))
' 127
2009-08-02 tobias 128 (defmethod closer-mop:validate-superclass ((class smoke-standard-class)
10:12:41 ' 129 (superclass standard-class))
2009-07-22 tobias 130 t)
2009-04-05 tobias 131
2009-08-02 tobias 132 (defmethod closer-mop:validate-superclass ((class cxx:class)
10:12:41 ' 133 (superclass smoke-standard-class))
2009-07-22 tobias 134 t)
2009-04-05 tobias 135
2009-08-02 tobias 136 ;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default
10:12:41 ' 137 ;; STANDARD-OBJECT.
' 138 (defun init-smoke-standard-class (class next-method
' 139 &rest args &key direct-superclasses
' 140 &allow-other-keys)
' 141 (apply next-method class
' 142 :direct-superclasses (or direct-superclasses
' 143 (list (find-class 'smoke-standard-object)))
' 144 args))
2009-04-05 tobias 145
2009-08-02 tobias 146 (defmethod initialize-instance :around ((class smoke-standard-class) &rest args)
10:12:41 ' 147 (apply #'init-smoke-standard-class class #'call-next-method args))
' 148
' 149 (defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)
' 150 (apply #'init-smoke-standard-class class #'call-next-method args))
2009-04-05 tobias 151
15:36:29 ' 152
2009-08-02 tobias 153 (defun init-cxx-class (class next-method &rest args &key direct-superclasses
2009-08-30 tobias 154 direct-default-initargs &allow-other-keys)
2009-04-05 tobias 155 (assert (not (null direct-superclasses))
15:36:29 ' 156 (direct-superclasses)
2009-08-30 tobias 157 "No superclass supplied for class ~A" class)
14:12:44 ' 158 (let ((superclass (first direct-superclasses))
' 159 (extra-superclasses (remove-if-not #'(lambda (class)
' 160 (typep class 'smoke-standard-class))
' 161 (rest direct-superclasses))))
' 162 (assert (typep superclass 'smoke-standard-class)
2009-04-05 tobias 163 ((first direct-superclasses))
2009-08-30 tobias 164 "The first superclass ~A must be an subclass of an Smoke class."
14:12:44 ' 165 class)
2009-06-10 tobias 166 (assert (virtual-destructor-p superclass)
11:55:55 ' 167 ()
2009-08-30 tobias 168 "The superclass ~A of ~A has a non virtual destructor."
14:12:44 ' 169 superclass class)
' 170 (when extra-superclasses
' 171 (dolist (superclass extra-superclasses)
' 172 (unless (virtual-destructor-p superclass)
' 173 (cerror "Continue anyway"
' 174 "The superclass ~A of ~A has a non virtual destructor."
' 175 superclass class)))
' 176 (setf direct-superclasses
' 177 (append direct-superclasses
' 178 (list (find-class 'smoke-multi-superclass-mixin))))
' 179 (push `(:extra-objects ,extra-superclasses ,#'(lambda ()
' 180 extra-superclasses))
' 181 direct-default-initargs))
2009-04-05 tobias 182 (apply
2009-08-02 tobias 183 next-method class
2009-07-08 tobias 184 :id (id superclass)
2009-06-22 tobias 185 :smoke (smoke superclass)
2009-04-05 tobias 186 :direct-superclasses direct-superclasses
2009-08-30 tobias 187 :direct-default-initargs direct-default-initargs
2009-04-05 tobias 188 args)))
15:36:29 ' 189
2009-08-02 tobias 190 (defmethod reinitialize-instance :around ((class cxx:class) &rest args)
10:12:41 ' 191 (apply #'init-cxx-class class #'call-next-method args))
' 192
' 193 (defmethod initialize-instance :around ((class cxx:class) &rest args)
' 194 (apply #'init-cxx-class class #'call-next-method args))
' 195
2010-01-26 tobias 196 (defun smoke-class-symbols (classes)
16:26:09 ' 197 (let ((class-symbols))
' 198 (dolist (class classes class-symbols)
' 199 (if (external-p class)
' 200 (let ((real-class (find-smoke-class class nil)))
' 201 (if real-class
' 202 (push (class-name real-class) class-symbols)
' 203 (warn "The class ~A could not be found in any module."
' 204 (name class))))
' 205 (push (lispify (name class)) class-symbols)))))
2009-04-05 tobias 206
2009-06-11 tobias 207 (defun make-smoke-classes (package smoke)
2009-07-01 tobias 208 "Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE."
2009-06-22 tobias 209 (declare (optimize (speed 3)))
2010-01-10 tobias 210 (let ((impl-package *package*)
08:49:36 ' 211 (*package* (find-package package)))
2009-06-22 tobias 212 (add-id-class-map smoke)
2009-04-05 tobias 213 (map-classes
15:36:29 ' 214 #'(lambda (class)
2010-01-10 tobias 215 (unless (external-p class)
2009-08-27 tobias 216 (with-simple-restart (skip "Skip generating class ~A" (name class))
2010-01-10 tobias 217 (let ((class-name
08:49:36 ' 218 ;; There is a QGlobalSpace class per Smoke module.
' 219 ;; Put it in *package* and not PACKAGE to avoid
' 220 ;; clashes between multiple modules.
' 221 (if (string= "QGlobalSpace" (name class))
' 222 (lispify "QGlobalSpace" impl-package)
' 223 (lispify (name class)))))
' 224 (add-id class
' 225 (closer-mop:ensure-class class-name
' 226 :direct-superclasses
2010-01-26 tobias 227 (smoke-class-symbols
16:26:09 ' 228 (smoke-class-direct-superclasses class))
2010-01-10 tobias 229 :id (id class)
08:49:36 ' 230 :smoke (smoke class)
' 231 :metaclass 'smoke-standard-class))
' 232 (when (eql (symbol-package class-name) *package*)
' 233 (export class-name))))))
2009-06-11 tobias 234 smoke)))
2009-04-05 tobias 235
2009-04-12 tobias 236 (defclass smoke-gf (cxx-generic-function)
14:43:33 ' 237 ((cxx-name :reader name :initarg :cxx-name
2009-05-11 tobias 238 :type string
11:07:39 ' 239 :documentation "The C++ name of the method."))
2009-04-05 tobias 240 (:metaclass closer-mop:funcallable-standard-class)
2009-05-11 tobias 241 (:documentation "Smoke generic function."))
2009-04-05 tobias 242
2009-06-22 tobias 243 (declaim (inline smoke-class-of))
2009-04-05 tobias 244 (defun smoke-class-of (object)
2009-07-01 tobias 245 "Returns the class of OBJECT or OBJECT iff it already is a class."
2009-06-22 tobias 246 (declare (optimize (speed 3)))
12:18:08 ' 247 (if (typep object 'smoke-class)
2009-04-05 tobias 248 object
15:36:29 ' 249 (class-of object)))
' 250
2009-04-12 tobias 251 ;;; To speed up the startup
2009-04-05 tobias 252 ;;; ENSURE-METHOD is only called as needed.
15:36:29 ' 253 (defmethod no-applicable-method ((gf smoke-gf) &rest args)
' 254 "Calls the smoke method."
2009-06-22 tobias 255 (declare (dynamic-extent args)
12:18:08 ' 256 (optimize (speed 3)))
2009-04-17 tobias 257 (call-using-args (first args) (name gf) (rest args)))
2009-04-05 tobias 258
2009-04-12 tobias 259 (defmethod add-method :after ((gf cxx-method-generic-function) method)
2009-04-05 tobias 260 "Adds a method which calls the smoke method, to make call-next-method work."
15:36:29 ' 261 (when (null (rest (closer-mop:generic-function-methods gf)))
2009-04-12 tobias 262 (let ((lambda-list (closer-mop:method-lambda-list method)))
14:43:33 ' 263 (closer-mop:ensure-method
' 264 gf
' 265 `(lambda ,lambda-list
' 266 (declare (optimize (speed 3)))
2009-05-11 tobias 267 (call-using-args ,(first lambda-list)
17:55:42 ' 268 (name ,(cxx-generic-function gf))
2009-05-11 tobias 269 (list ,@(rest lambda-list))))))))
2009-04-05 tobias 270
15:36:29 ' 271 (defcallback destructed :void
2009-07-22 tobias 272 ((object-pointer :pointer))
2009-06-22 tobias 273 (declare (optimize (speed 3)))
2009-04-05 tobias 274 (let ((object (get-object object-pointer)))
2009-08-02 tobias 275 ;; The destructed callback can be the result of deleting the object
10:12:41 ' 276 ;; in a finalizer. In that case the object is already removed from
' 277 ;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.
2009-04-05 tobias 278 (when object
2009-09-02 tobias 279 (when (typep object 'smoke-multi-superclass-mixin)
11:49:34 ' 280 (dolist (extra-object (extra-objects object))
' 281 (unless (null-pointer-p (pointer extra-object))
' 282 (remove-object (pointer extra-object))
' 283 (delete-object extra-object))))
2009-06-30 tobias 284 (remove-finalizer object)
2009-04-05 tobias 285 (remove-object object-pointer)
15:36:29 ' 286 (setf (slot-value object 'pointer) (null-pointer)))))
' 287
2009-06-22 tobias 288 (declaim (inline argument-to-lisp))
12:18:08 ' 289 (defun argument-to-lisp (stack-item type)
' 290 ;; FIXME do not take ownership of stack allocated objects.
2009-08-02 tobias 291 ;; It looks like there is no stack allocation in Qt virtual method signatures.
2009-06-22 tobias 292 (type-to-lisp stack-item type))
12:18:08 ' 293
2009-04-05 tobias 294 (defun stack-to-args (stack arg &optional (args nil))
15:36:29 ' 295 "Returns the arguments in STACK, where ARG is the type
' 296 of the first argument, as an list of Lisp objects."
' 297 (if (end-p arg)
2009-06-22 tobias 298 (reverse args)
12:18:08 ' 299 (stack-to-args (inc-pointer stack
' 300 (foreign-type-size 'smoke-stack-item))
2009-04-05 tobias 301 (next arg)
2009-08-27 tobias 302 (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)
2009-07-22 tobias 303 arg)
2009-06-22 tobias 304 args))))
2009-04-05 tobias 305
2009-09-02 tobias 306 (defun convert-argument (argument type &optional disown)
11:49:34 ' 307 "Returns ARGUMENT converted to TYPE and removes the ownership when
' 308 it is passed on the stack."
' 309 (flet ((disown (object)
' 310 (remove-finalizer object)
' 311 (when (typep object 'smoke-standard-object)
' 312 (remove-object (pointer object)))))
' 313 (let ((rank (get-conversion-sequence argument type nil)))
' 314 (if (null rank)
' 315 (let ((rank (get-conversion-sequence argument type t)))
' 316 (if (null rank)
' 317 (error "Can not convert the argument ~S to ~A."
' 318 argument (name type))
' 319 (let ((ret (funcall (conversion-function-name rank)
' 320 argument)))
' 321 (when (and disown (stack-p type))
' 322 (disown ret))
' 323 ret)))
' 324 (prog1 (funcall (conversion-function-name rank) argument)
' 325 (when (and disown (stack-p type))
' 326 (disown argument)))))))
2009-04-05 tobias 327
2009-06-08 tobias 328 (defun put-returnvalue (stack value type object)
2009-04-05 tobias 329 (unless (void-p type)
2009-05-26 tobias 330 (let ((stack (make-call-stack stack)))
2009-07-08 tobias 331 (setf (call-stack-top stack) (call-stack-pointer stack))
2009-09-02 tobias 332 (let ((converted-value (convert-argument value type t)))
11:49:34 ' 333 (push-smoke-stack stack converted-value (type-id type))))))
2009-04-05 tobias 334
2009-05-19 tobias 335 (defun get-gf-for-method (smoke-method)
11:09:12 ' 336 (declare (smoke-method smoke-method)
' 337 (optimize (speed 3)))
' 338 (symbol-function (lispify (name smoke-method) "CXX")))
2009-05-19 tobias 339
2009-08-30 tobias 340 ;; Receive virtual function calls.
2009-04-05 tobias 341 (defcallback dispatch-method :boolean
2010-02-19 tobias 342 ((binding :pointer)
21:10:24 ' 343 (method smoke-index)
2009-06-30 tobias 344 (object-ptr :pointer)
22:47:39 ' 345 (stack smoke-stack)
' 346 (abstract :boolean))
2009-04-05 tobias 347 (declare (optimize (speed 3)))
2009-06-30 tobias 348 (let ((object (get-object object-ptr)))
2009-08-02 tobias 349 ;; The Lisp OBJECT can be gc'ed but we might still receive a
10:12:41 ' 350 ;; QObject destructed event when the C++ instance is deleted in
' 351 ;; the finalizer. Thus OBJECT might be NIL.
2010-02-18 tobias 352 (when (and object (typep (class-of object) 'cxx:class))
19:57:00 ' 353 ;; Do not allow overwriting methods of classes the users has
' 354 ;; not derived from (like in C++), to reduce overhead.
2009-08-02 tobias 355 (let* ((method (make-smoke-method
2010-02-19 tobias 356 :smoke (gethash (pointer-address
21:10:24 ' 357 (smoke-get-smoke binding))
' 358 *smoke-modules*)
2009-08-02 tobias 359 :id method)))
10:12:41 ' 360 (loop
' 361 (restart-case
' 362 (return-from dispatch-method
' 363 (let ((gf (get-gf-for-method method)))
' 364 (declare (function gf))
' 365 (if (null (gf-methods gf))
' 366 (progn
' 367 (when abstract
' 368 (error "Abstract method ~A of ~A called."
' 369 (method-declaration method) object))
' 370 nil)
' 371 (if object
' 372 (progn
' 373 (put-returnvalue
' 374 stack
' 375 (apply gf object
' 376 (stack-to-args
' 377 (inc-pointer stack (foreign-type-size
' 378 'smoke-stack-item))
' 379 (get-first-argument method)))
' 380 (return-type method) object)
' 381 t)
' 382 nil))))
' 383 ;; Restarts to prevent stack unwinding across the C++ stack.
' 384 (call-default ()
' 385 :report (lambda (stream)
' 386 (declare (stream stream))
' 387 (format stream
' 388 "Call default implementation ~A instead."
' 389 method))
' 390 :test (lambda (condition)
' 391 (declare (ignore condition))
' 392 (not abstract))
' 393 (return-from dispatch-method nil))
' 394 (use-returnvalue (return-value)
' 395 :report (lambda (stream)
' 396 (declare (stream stream))
' 397 (format stream "Supply a return value for ~A."
' 398 (method-declaration method)))
' 399 :test (lambda (condition)
' 400 (declare (ignore condition))
' 401 (not (void-p (return-type method))))
' 402 :interactive (lambda ()
' 403 (format *query-io* "~&Enter a new return value: ")
' 404 (multiple-value-list (eval (read *query-io*))))
' 405 (put-returnvalue stack return-value
' 406 (return-type method)
' 407 (get-object object-ptr))
' 408 (return-from dispatch-method t))
' 409 (return ()
' 410 :report (lambda (stream)
' 411 (declare (stream stream))
' 412 (format stream "Return void for ~A."
' 413 (method-declaration method)))
' 414 :test (lambda (condition)
' 415 (declare (ignore condition))
' 416 (void-p (return-type method)))
' 417 (return-from dispatch-method (values)))
' 418 (retry ()
' 419 :report (lambda (stream)
' 420 (declare (stream stream))
' 421 (format stream "Try again calling ~A."
' 422 (method-declaration method))))))
' 423 nil))))
2009-04-05 tobias 424
15:36:29 ' 425 ;;FIXME use CHANGE-CLASS instead?
2009-08-30 tobias 426 (defgeneric cast (object class)
2009-07-08 tobias 427 (declare (optimize (speed 3)))
2009-08-30 tobias 428 (:documentation "Returns a pointer of type CLASS to the C++ object of OBJECT.")
14:12:44 ' 429 (:method (object class)
' 430 (declare (optimize (speed 3)))
' 431 (assert (derived-p (class-of object) class)
' 432 ()
' 433 "Can not cast object ~A of class ~A to class ~A."
' 434 object (name (class-of object)) (name class))
' 435 (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)
2010-02-18 tobias 436 (id (class-of object)) (id class)))
2009-08-30 tobias 437 (:method ((object smoke-multi-superclass-mixin) class)
14:12:44 ' 438 (if (derived-p (class-of object) class)
' 439 (call-next-method)
' 440 (let ((extra-object (find-if #'(lambda (o)
' 441 (derived-p (class-of o) class))
' 442 (extra-objects object))))
' 443 (assert extra-object
' 444 ()
' 445 "Can not cast object ~A to class ~A."
' 446 object (name class))
' 447 (cast extra-object class)))))
2009-04-05 tobias 448
15:36:29 ' 449 (defun upcast (object class)
' 450 (assert (derived-p class (class-of object))
' 451 ()
' 452 "Can not upcast object ~A of class ~A to class ~A."
' 453 object (name (class-of object)) (name class))
2009-06-22 tobias 454 (smoke-cast (smoke-module-pointer (smoke class)) (pointer object)
2009-04-05 tobias 455 (id (class-of object)) (id (real-class class))))
15:36:29 ' 456
' 457
2009-08-02 tobias 458 ;; The constructor name is the name of the class minus any namespace parts.
2009-07-22 tobias 459 (defun constructor-name (class)
2010-02-19 tobias 460 (let ((name-start (search "::" (name class) :from-end t)))
2009-07-22 tobias 461 (if name-start
2010-02-19 tobias 462 (subseq (name class) (+ name-start 2))
21:22:50 ' 463 (name class))))
2009-07-22 tobias 464
2009-08-30 tobias 465 (defun call-constructor (class arguments)
14:12:44 ' 466 (multiple-value-bind (method sequence)
2010-02-20 tobias 467 (find-best-viable-function (constructor-name class)
17:24:36 ' 468 arguments
' 469 class)
2009-08-30 tobias 470 (when (null method)
14:12:44 ' 471 (error "No constructor for class ~A with
' 472 the arguments ~S." class arguments))
' 473 (pointer-call method (null-pointer)
' 474 (mapcar #'(lambda (conversion argument)
' 475 (funcall conversion argument))
' 476 sequence arguments))))
2009-04-05 tobias 477
15:36:29 ' 478 (defmethod initialize-instance :after ((object smoke-standard-object)
2009-07-22 tobias 479 &key args
22:26:05 ' 480 (arg0 nil arg0p)
' 481 (arg1 nil arg1p)
' 482 (arg2 nil arg2p)
2010-01-25 tobias 483 (arg3 nil arg3p)
2009-07-22 tobias 484 &allow-other-keys)
2009-04-05 tobias 485 "Initializes a Smoke object. Calls its constructor with the arguments supplied
15:36:29 ' 486 by the key :ARGS and sets the smoke binding."
2009-06-22 tobias 487 (declare (optimize (speed 3)))
2009-04-05 tobias 488 (assert (not (and (slot-boundp object 'pointer)
15:36:29 ' 489 (not (null args))))
' 490 ((slot-value object 'pointer) args)
' 491 "Pointer ~A bound and constructor argument :ARGS ~S supplied."
' 492 (slot-value object 'pointer) args)
' 493 (unless (slot-boundp object 'pointer)
2009-07-22 tobias 494 (if arg0p
22:26:05 ' 495 (setf (slot-value object 'pointer)
2009-08-30 tobias 496 (call-constructor (class-of object)
2009-07-22 tobias 497 (cond
2010-01-25 tobias 498 (arg3p (list arg0 arg1 arg2 arg3))
2009-07-22 tobias 499 (arg2p (list arg0 arg1 arg2))
22:26:05 ' 500 (arg1p (list arg0 arg1))
' 501 (t (list arg0)))))
2009-08-30 tobias 502 (setf (slot-value object 'pointer)
14:12:44 ' 503 (call-constructor (class-of object) args)))
2009-06-22 tobias 504 (set-binding object)
2009-05-24 tobias 505 (take-ownership object)
2009-04-05 tobias 506 (add-object object)))
15:36:29 ' 507
2009-08-30 tobias 508 (defun construct-extra-objects (object extra-objects)
14:12:44 ' 509 (loop for class in extra-objects
' 510 collect (let ((extra-object (make-instance (first extra-objects)
' 511 :pointer (call-constructor (first extra-objects)
' 512 nil))))
' 513 (set-binding extra-object)
' 514 (setf (get-object (pointer extra-object)) object)
' 515 extra-object)))
' 516
' 517 (defmethod initialize-instance :after ((object smoke-multi-superclass-mixin)
' 518 &key args)
' 519 (setf (slot-value object 'extra-objects)
' 520 (construct-extra-objects object (extra-objects object))))
' 521
' 522 (defmethod make-finalize ((object smoke-multi-superclass-mixin))
' 523 (let ((pointer (pointer object))
' 524 (extra-objects (extra-objects object))
' 525 (class (class-of object)))
' 526 #'(lambda ()
' 527 (declare (optimize (speed 3)))
' 528 (handler-case (progn
' 529 (delete-pointer pointer class)
' 530 (dolist (object extra-objects)
' 531 (delete-object object)))
' 532 (error (condition)
' 533 (report-finalize-error condition 't (name class) pointer))))))
2009-04-05 tobias 534
15:36:29 ' 535 (defmethod instance-to-lisp (pointer class type)
2009-06-22 tobias 536 (declare (type smoke-standard-class class)
12:18:08 ' 537 (optimize (speed 3)))
2009-08-27 tobias 538 (let ((ret (make-instance class :pointer pointer
11:43:13 ' 539 :const-p (const-p type))))
2009-05-24 tobias 540 (when (stack-p type)
11:30:05 ' 541 (take-ownership ret)
' 542 (add-object ret))
2009-04-05 tobias 543 ret))
2009-05-31 tobias 544
2009-06-08 tobias 545 (defun keep-wrapper (object new-owner)
2009-06-22 tobias 546 (declare (type smoke-standard-object object)
12:18:08 ' 547 (optimize (speed 3)))
2009-06-10 tobias 548 (when (member object (owned-objects new-owner))
2009-08-30 tobias 549 (cerror "Ignore" "~A has already been added to ~A."
2009-08-02 tobias 550 object new-owner))
2009-06-08 tobias 551 (push object (owned-objects new-owner)))
2009-05-31 tobias 552
2009-06-22 tobias 553 (declaim (inline remove-wrapper-object))
2009-06-08 tobias 554 (defun remove-wrapper-object (object owner)
09:20:54 ' 555 (remove object (owned-objects owner)))
2009-05-31 tobias 556
2009-06-08 tobias 557 (defun transfer-ownership-to (object new-owner)
2009-05-31 tobias 558 "Transfers the ownership of OBJECT to C++."
2009-06-22 tobias 559 (declare (optimize (speed 3)))
2009-06-30 tobias 560 (remove-finalizer object)
2009-06-10 tobias 561 (if (virtual-destructor-p (class-of object))
11:55:55 ' 562 (keep-wrapper object new-owner)
' 563 (remove-object (pointer object))))
2009-05-31 tobias 564
2009-06-08 tobias 565 (defun take-ownership (object &optional current-owner)
2009-05-31 tobias 566 "Assigns the ownership of OBJECT to Lisp. i.e.:
17:41:26 ' 567 cl-smoke is responsible for deleting the object."
2009-06-08 tobias 568 (when current-owner
09:20:54 ' 569 (remove-wrapper-object object current-owner))
2009-06-30 tobias 570 (set-finalizer object))
Crece desde el pueblo el futuro / crece desde el pie