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