Changeset 434
- Timestamp:
- Jan 30, 2004, 12:09:13 PM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/objc-clos.lisp (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/objc-clos.lisp
r379 r434 19 19 ;;; - MAP-OBJC-CLASS needs to INITIALIZE-INSTANCE and FINALIZE-INHERITANCE 20 20 ;;; for predefined classes 21 ;;; - OBJC-FOREIGN-ARG-TYPE in BRIDGE.LISP needs to handle BITFIELDs,22 ;;; ARRAYs and UNIONs23 21 ;;; - Need to fully handle init keywords and ObjC init messages 24 ;;; - Need to add getter and setter functions for more for iegn slot types22 ;;; - Need to add getter and setter functions for more foreign slot types 25 23 ;;; - Canonicalization and retention for ObjC objects 26 24 ;;; - Support redef of CLOS parts, but not changes in ObjC parts … … 49 47 (package-force-export "NS") 50 48 51 52 49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 50 ;;;; Testing ;;;; 54 51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 53 ;;; Enable some debugging output. 54 (defparameter *objc-clos-debug* nil) 55 55 56 56 ;;; Until foreign slot definition objects automatically show up where they're … … 160 160 161 161 (defclass objc:objc-class-object (foreign-class objc:objc-object) 162 ((foreign :initform t)163 (peer :initform nil )))162 ((foreign :initform nil :initarg :foreign) 163 (peer :initform nil :initarg :peer))) 164 164 165 165 (defclass objc:objc-metaclass (objc:objc-class-object) … … 170 170 (defclass objc:objc-class (objc:objc-class-object) 171 171 ()) 172 173 (setq *objc-class-class* (find-class 'objc:objc-class)) 172 174 173 175 (defmethod objc-metaclass-p ((c class)) … … 198 200 199 201 200 201 (defun initialize-objc-class-slots (class class-name wrapper &optional foreign) 202 ; (format t "~&initialize-objc-class-slots ~s (#x~x)" class-name (%ptr-to-int class)) 203 ; (force-output) 204 (let* ((super (pref class :objc_class.super_class)) 205 (super-id (unless (%null-ptr-p super) (objc-class-id super))) 206 (super-slots (if super-id 207 (id->objc-class-slots-vector super-id) 208 (instance.slots (find-class 'objc:objc-object)))) 209 (super-cpl (%slot-ref super-slots %class.cpl))) 210 (gvector :slot-vector 211 class 212 nil ;direct-methods 213 nil ;prototype 214 class-name 215 (cons class super-cpl) ;cpl 216 wrapper 217 (list (slot-vector.instance super-slots)) ;local-supers 218 nil ;subclasses 219 nil ;dependents 220 (make-class-ctype class) ;ctype 221 nil ;direct-slots 222 nil ;slots 223 t ;kernel-p 224 nil ;local-default-initargs 225 nil ;default-initargs 226 nil ;alist 227 foreign 228 nil 229 ))) 230 231 (defun initialize-objc-metaclass-slots (class class-name wrapper 232 &optional foreign peer) 233 ; (format t "~&initialize-objc-metaclass-slots ~s" class-name) 234 ; (force-output) 235 (let* ((super (pref class :objc_class.super_class)) 236 (super-id (unless (%null-ptr-p super) (objc-metaclass-id super))) 237 (super-slots (if super-id 238 (id->objc-metaclass-slots-vector super-id) 239 (instance.slots (find-class 'objc:objc-class)))) 240 (super-cpl (%slot-ref super-slots %class.cpl)) 241 (eslotds (class-slots (find-class 'objc:objc-class)))) 242 (setup-slot-lookup wrapper eslotds) 243 (gvector :slot-vector 244 class 245 nil ;direct-methods 246 nil ;prototype 247 class-name 248 (cons class super-cpl) ;cpl 249 wrapper 250 (list (slot-vector.instance super-slots)) ;local-supers 251 nil ;subclasses 252 nil ;dependents 253 (make-class-ctype class) ;ctype 254 nil ;direct-slots 255 eslotds ;slots 256 t ;kernel-p 257 nil ;local-default-initargs 258 nil ;default-initargs 259 nil ;alist 260 foreign 261 peer 262 ))) 202 (defun make-objc-class-object-slots-vector (class meta) 203 (let* ((n (1+ (length (extract-instance-effective-slotds meta)))) 204 (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker)))) 205 (setf (slot-vector.instance slots) class) 206 slots)) 207 208 (defun make-objc-metaclass-slots-vector (metaclass) 209 (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*)) 210 211 (defun make-objc-class-slots-vector (class) 212 (make-objc-class-object-slots-vector class *objc-class-class*)) 213 263 214 264 215 … … 289 240 ;;; Metaclasses for foreign slots 290 241 242 (defconstant objc-bitfield-offset-mask (ash 1 28) "When set in a foreign 243 DIRECT slot definition's offset, indicates that the low 27 bits are a bit 244 offset into the slots of the relevant class.") 245 246 (defconstant objc-bitfield-offset-bit-offset (byte 22 6) "bit offset of 247 most significant bitfield bit in word; corresponding byte offset will 248 be word-aligned") 249 250 (defconstant objc-bitfield-offset-byte-offset (byte 22 0) "byte offset 251 of field, relative to start of class's own slots") 252 291 253 (defclass foreign-direct-slot-definition (direct-slot-definition) 292 ((foreign :initarg :foreign)) 293 (:default-initargs :type :id)) 254 ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type) 255 (offset :initarg :offset 256 :initform nil 257 :accessor foreign-direct-slot-definition-offset 258 :documentation "A byte- (or, if certain high bits are set, bit-) 259 offset, relative to the start of the instance's slots. The corresponding 260 effective slot definition's offset is a product of this value and the 261 instance_size of its ObjC superclass.")) 262 (:default-initargs :foreign-type :id)) 294 263 295 264 (defclass foreign-effective-slot-definition (effective-slot-definition) 296 ((getter :type function :accessor foreign-slot-definition-getter) 265 ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type) 266 (getter :type function :accessor foreign-slot-definition-getter) 297 267 (setter :type function :accessor foreign-slot-definition-setter))) 298 268 299 269 300 ;;; Use the foreign slot metaclasses if the slot has a :FOREIGN attribute301 ;; of T270 ;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute 271 ;; 302 272 303 273 (defmethod direct-slot-definition-class ((class objc:objc-class-object) 304 274 &rest initargs) 305 (if (getf initargs :foreign )306 275 (if (getf initargs :foreign-type) 276 (find-class 'foreign-direct-slot-definition) 307 277 (find-class 'standard-direct-slot-definition))) 308 278 309 279 (defmethod effective-slot-definition-class ((class objc:objc-class-object) 310 280 &rest initargs) 311 (if (getf initargs :foreign )312 281 (if (getf initargs :foreign-type) 282 (find-class 'foreign-effective-slot-definition) 313 283 (find-class 'standard-effective-slot-definition))) 284 285 ;;; A little structure used to drive the state-driven ivar-parsing mechanism. 286 (defstruct 287 (ivar-parse-state (:constructor %make-ivar-parse-state (class-origin))) 288 (class-origin 0 :type fixnum) 289 (last-byte-offset-seen nil :type (or null fixnum)) 290 (bitfield-offset nil :type (or null fixnum))) 291 292 (defun make-ivar-parse-state (class) 293 (%make-ivar-parse-state (superclass-instance-size class))) 314 294 315 295 … … 323 303 (loop with ns-package = (find-package "NS") 324 304 with n = (pref ivars :objc_ivar_list.ivar_count) 305 with state = (make-ivar-parse-state c) 325 306 for i from 1 to n 326 307 for ivar = (pref ivars :objc_ivar_list.ivar_list) … … 330 311 when (eql (schar name 0) #\_) 331 312 do (unexport sym ns-package) 332 do (format t "~S: ~S~%" name (pref ivar :objc_ivar.ivar_offset))313 ;do (format t "~S: ~S~%" name (pref ivar :objc_ivar.ivar_offset)) 333 314 collect 334 (make-direct-slot-definition 315 (make-direct-slot-definition-from-ivar 316 state 317 (pref ivar :objc_ivar.ivar_offset) 318 (with-string-from-cstring 319 (s (pref ivar :objc_ivar.ivar_type)) 320 (objc-foreign-type-for-ivar s)) 335 321 c 336 322 (list 337 323 :name sym 338 324 :allocation :instance 339 :foreign t 340 :class (find-class 'foreign-effective-slot-definition) 341 :type (objc-foreign-arg-type 342 (%get-cstring (pref ivar :objc_ivar.ivar_type))) 343 ; :offset (pref ivar :objc_ivar.ivar_offset) 344 ))))))) 325 :class c ))))))) 326 327 (defun make-direct-slot-definition-from-ivar (state 328 ivar-offset 329 slot-type 330 class 331 initargs) 332 (let* ((byte-offset (- ivar-offset (ivar-parse-state-class-origin state))) 333 (offset byte-offset)) 334 (if (or (eq slot-type 'bit) 335 (and (consp slot-type) (eq (car slot-type) 'bitfield))) 336 (let* ((width (if (eq slot-type 'bit) 1 (cadr slot-type))) 337 (bit-offset 338 (if (eql offset (ivar-parse-state-last-byte-offset-seen state)) 339 (ivar-parse-state-bitfield-offset state) 340 (or (ivar-parse-state-bitfield-offset state) 0)))) 341 (setf (ivar-parse-state-last-byte-offset-seen state) offset 342 (ivar-parse-state-bitfield-offset state) (+ bit-offset width)) 343 (setq offset (logior objc-bitfield-offset-mask 344 (dpb bit-offset 345 objc-bitfield-offset-bit-offset 346 offset))))) 347 (let* ((slot 348 (make-direct-slot-definition 349 class 350 `(:foreign-type ,slot-type :offset ,offset ,@initargs)))) 351 slot))) 352 353 354 (defun set-objc-foreign-direct-slot-offsets (dslotds) 355 (let* ((byte-offset 0)) 356 (dolist (d dslotds) 357 (let* ((type (foreign-slot-definition-foreign-type d)) 358 (ftype (parse-foreign-type type)) 359 (type-alignment (progn (ensure-foreign-type-bits ftype) 360 (foreign-type-alignment ftype)))) 361 (if (= type-alignment 1) 362 (break "Bitfields not handled yet: ~s" type)) 363 (setq byte-offset 364 (align-offset byte-offset (ceiling type-alignment 8))) 365 (setf (foreign-direct-slot-definition-offset d) byte-offset) 345 366 367 (setq byte-offset 368 (+ byte-offset 369 (ceiling (foreign-type-bits ftype) 8))))))) 370 371 372 ;;; When an ObjC class is created by the user, the OFFSET fields in 373 ;;; its foreign direct slot definitions are generally not set. We 374 ;;; can compute them fairly easily, but this is stateful (a slot's 375 ;;; offset may depend on its predecessor's offset.) Intercept the 376 ;;; attempt to set the classes direct slots and ensure that all 377 ;;; of those slots have proper offsets. 378 ;;; (In any case that I can think of, we should either find that 379 ;;; all foreign direct slots have non-null offsets or that none 380 ;;; do. If any don't, recompute all of them. 381 (defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class)) 382 (let* ((foreign-dslotds 383 (loop for d in dslotds 384 when (typep d 'foreign-direct-slot-definition) 385 collect d))) 386 (unless 387 (dolist (d foreign-dslotds t) 388 (if (not (foreign-direct-slot-definition-offset d)) 389 (return nil))) 390 (set-objc-foreign-direct-slot-offsets foreign-dslotds)))) 391 392 393 (defun lisp-defined-slot-name-to-objc-slot-name (lisp-name) 394 (lisp-to-objc-message (list lisp-name))) 395 396 ;;; This is only going to be called on a class created by the user; 397 ;;; the byte part of each foreign direct slotd's offset field should 398 ;;; already have been set. 399 (defun %make-objc-ivars (class) 400 (let* ((start-offset (superclass-instance-size class)) 401 (foreign-dslotds (loop for s in (class-direct-slots class) 402 when (typep s 'foreign-direct-slot-definition) 403 collect s))) 404 (if (null foreign-dslotds) 405 (values (%null-ptr) start-offset) 406 (let* ((n (length foreign-dslotds)) 407 (offset start-offset) 408 (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size 409 :objc_ivar :bytes)))))) 410 (setf (pref ivars :objc_ivar_list.ivar_count) n) 411 (do* ((l foreign-dslotds (cdr l)) 412 (dslotd (car l) (car l)) 413 (ivar (pref ivars :objc_ivar_list.ivar_list) 414 (%inc-ptr ivar (%foreign-type-or-record-size 415 :objc_ivar :bytes)))) 416 ((null l) (values ivars (align-offset offset 4))) 417 (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) 418 (type (parse-foreign-type (foreign-slot-definition-foreign-type dslotd))) 419 (encoding (encode-objc-type type))) 420 (setq offset 421 (+ start-offset 422 (ldb objc-bitfield-offset-byte-offset 423 (foreign-direct-slot-definition-offset dslotd)))) 424 (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string) 425 (pref ivar :objc_ivar.ivar_type) (make-cstring encoding) 426 (pref ivar :objc_ivar.ivar_offset) offset) 427 (setq offset (+ offset (ceiling (foreign-type-bits type) 8))))))))) 346 428 347 429 (defun %objc-ivar-offset-in-class (name c) … … 369 451 (or (locate-objc-slot name c) 370 452 (error "No ObjC instance variable named ~S in ~S" name c))))) 371 453 454 ;;; Maintain the class wrapper of an ObjC class or metaclass. 455 456 (defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass)) 457 (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper)) 458 459 (defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class)) 460 (setf (id->objc-class-wrapper (objc-class-id class)) wrapper)) 372 461 373 462 ;;; Return the getter and setter functions for a foreign slot 374 463 ;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE 375 464 376 (defclass unhandled-foreign-slot ()377 ((ftype :initarg :ftype :accessor unhandled-foreign-slot-ftype)))378 379 (defmethod print-object ((ufs unhandled-foreign-slot) stream)380 (print-unreadable-object (ufs stream :type t :identity t)381 (format stream "for foreign type ~s" (unhandled-foreign-slot-ftype ufs))))382 465 383 466 (defun compute-foreign-slot-accessors (eslotd) 384 (let ((ftype (%slot-definition-type eslotd))) 385 (flet ((unhandled-foreign-slot-type (ptr &optional offset) 386 (declare (ignore ptr offset)) 387 (make-instance 'unhandled-foreign-slot :ftype ftype))) 388 (case ftype 389 (:unsigned-byte (values #'%get-unsigned-byte #'%set-byte)) 390 (:signed-byte (values #'%get-signed-byte #'%set-byte)) 391 (:unsigned-word (values #'%get-unsigned-word #'%set-word)) 392 (:signed-word (values #'%get-signed-word #'%set-word)) 393 (:unsigned-fullword (values #'%get-unsigned-long #'%set-long)) 394 (:signed-fullword (values #'%get-signed-long #'%set-long)) 395 (:unsigned-longlong 396 (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)) 397 (:signed-longlong 398 (values #'%%get-signed-longlong #'%%set-signed-longlong)) 399 (:single-float (values #'%get-single-float #'%set-single-float)) 400 (:double-float (values #'%get-double-float #'%set-double-float)) 401 ((:id :address) (values #'%get-ptr #'%set-ptr)) 402 (t 403 (cond 404 ((and (consp ftype) (eq (first ftype) :*)) 405 (values #'%get-ptr #'%set-ptr)) 406 (t (values #'unhandled-foreign-slot-type 407 #'unhandled-foreign-slot-type)))))))) 408 409 410 ;;; Augment SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with an :AROUND 411 ;;; method for OBJC-CLASSes that sets up foreign slot info 467 (let* ((ftypespec (foreign-slot-definition-foreign-type eslotd)) 468 (ftype (parse-foreign-type ftypespec))) 469 (etypecase ftype 470 (foreign-integer-type 471 (let* ((bits (foreign-integer-type-bits ftype)) 472 (align (foreign-integer-type-alignment ftype)) 473 (signed (foreign-integer-type-signed ftype))) 474 (if (= bits align) 475 (ecase bits 476 (1 (values #'%get-bit #'%set-bit)) 477 (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte) 478 #'%set-byte)) 479 (16 (values (if signed #'%get-signed-word #'%get-unsigned-word) 480 #'%set-word)) 481 (32 (values (if signed #'%get-signed-long #'%get-unsigned-long) 482 #'%set-long)) 483 (64 (if signed 484 (values #'%%get-signed-longlong #'%%set-signed-longlong) 485 (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)))) 486 (values #'(lambda (ptr offset) 487 (%get-bitfield ptr offset bits)) 488 #'(lambda (ptr offset new) 489 (setf (%get-bitfield ptr offset bits) new)))))) 490 (foreign-double-float-type 491 (values #'%get-double-float #'%set-double-float)) 492 (foreign-single-float-type 493 (values #'%get-single-float #'%set-single-float)) 494 (foreign-pointer-type 495 (values #'%get-ptr #'%set-ptr)) 496 (foreign-mem-block-type 497 (let* ((nbytes (%foreign-type-or-record-size ftype :bytes))) 498 (values #'%inc-ptr #'(lambda (pointer offset new) 499 (setf (%composite-pointer-ref 500 nbytes 501 pointer 502 offset) 503 new)))))))) 504 505 506 507 ;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a 508 ;;; method for OBJC-CLASSes that sets up foreign slot info. 412 509 413 510 (defmethod compute-effective-slot-definition :around ((class objc:objc-class-object) 414 511 name 415 512 direct-slots) 416 (let* ((first (first direct-slots)) 417 (eslotd (call-next-method))) 418 (when (typep first 'foreign-direct-slot-definition) 419 (setq eslotd 420 (make-effective-slot-definition 421 class 422 :name name 423 :allocation (%slot-definition-allocation eslotd) 424 :foreign t 425 :documentation (%slot-definition-documentation eslotd) 426 :class (%slot-definition-class first) 427 :initargs (%slot-definition-initargs eslotd) 428 :initfunction (%slot-definition-initfunction eslotd) 429 :initform (%slot-definition-initform eslotd) 430 :type (%slot-definition-type eslotd))) 513 (let* ((first (first direct-slots))) 514 (if (not (typep first 'foreign-direct-slot-definition)) 515 (call-next-method) 516 (let* ((initer (dolist (s direct-slots) 517 (when (%slot-definition-initfunction s) 518 (return s)))) 519 (documentor (dolist (s direct-slots) 520 (when (%slot-definition-documentation s) 521 (return s)))) 522 (initargs (let* ((initargs nil)) 523 (dolist (dslot direct-slots initargs) 524 (dolist (dslot-arg (%slot-definition-initargs dslot)) 525 (pushnew dslot-arg initargs :test #'eq))))) 526 (eslotd 527 (make-effective-slot-definition 528 class 529 :name name 530 :allocation :instance 531 :type (or (%slot-definition-type first) t) 532 :documentation (when documentor (nth-value 533 1 534 (%slot-definition-documentation 535 documentor))) 536 :class (%slot-definition-class first) 537 :initargs initargs 538 :initfunction (if initer 539 (%slot-definition-initfunction initer)) 540 :initform (if initer (%slot-definition-initform initer)) 541 :foreign-type (foreign-slot-definition-foreign-type first)))) 431 542 (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd) 432 543 (setf (foreign-slot-definition-getter eslotd) getter) 433 (setf (foreign-slot-definition-setter eslotd) setter)) )434 eslotd))544 (setf (foreign-slot-definition-setter eslotd) setter)) 545 eslotd)))) 435 546 436 547 437 548 ;;; Determine the location of each slot 549 ;;; An effective slot's location is 550 ;;; a) a function of the class's origin (superclass-instance-size) 551 ;;; and the corresponding direct class's offset, if it's defined in the 552 ;;; class (has a corresponding direct-slot-definition in the class) 553 ;;; b) Exactly the same as the superclass's version's location, because 554 ;;; of single inheritance. 555 556 (defun determine-foreign-slot-location (class slot-name) 557 (or 558 (let* ((origin (superclass-instance-size class))) 559 (dolist (d (class-direct-slots class)) 560 (when (and (eq slot-name (slot-definition-name d)) 561 (typep d 'foreign-direct-slot-definition)) 562 (return (+ origin 563 (ldb objc-bitfield-offset-byte-offset 564 (foreign-direct-slot-definition-offset d))))))) 565 (dolist (super (class-direct-superclasses class)) 566 (when (typep super 'objc:objc-class) ; can be at most 1 567 (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name))) 568 (when e (return (slot-definition-location e)))))) 569 (error "Can't find slot definition for ~s in ~s" slot-name class))) 570 438 571 439 572 (defmethod compute-slots :around ((class objc:objc-class-object)) … … 448 581 (setq instance-slots 449 582 (sort-effective-instance-slotds instance-slots class cpl)) 450 (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%" 451 instance-slots class-slots foreign-slots) 583 (when *objc-clos-debug* 584 (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%" 585 instance-slots class-slots foreign-slots)) 452 586 (loop for islot in instance-slots 453 587 for loc = 1 then (1+ loc) … … 460 594 (dolist (fslot foreign-slots) 461 595 (setf (%slot-definition-location fslot) 462 (%objc-ivar-offset 463 (compute-objc-variable-name (%slot-definition-name fslot)) class))) 596 (determine-foreign-slot-location 597 class 598 (%slot-definition-name fslot)))) 464 599 (append instance-slots class-slots foreign-slots)))) 465 600 … … 503 638 (defmethod make-instance ((class objc:objc-class-object) &rest initargs) 504 639 (let ((instance (apply #'allocate-instance class initargs))) 505 (apply #'initialize-instance instance initargs) 506 instance)) 507 508 (defmethod allocate-instance ((class objc:objc-class) &key &allow-other-keys) 640 (apply #'initialize-instance instance initargs))) 641 642 (defun remove-slot-initargs (class initargs) 643 (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe 644 (collect ((non-slot-initargs)) 645 (do* ((key (pop initargs) (pop initargs)) 646 (val (pop initargs) (pop initargs))) 647 ((null initargs) (non-slot-initargs)) 648 (unless (member key slot-initargs :test #'eq) 649 (non-slot-initargs key) 650 (non-slot-initargs val)))))) 651 652 (defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys) 509 653 (unless (class-finalized-p class) 510 654 (finalize-inheritance class)) 511 (let* ((instance (%send class 'alloc)) ; For now; Use SEND macro eventually 512 (len (length (%wrapper-instance-slots (class-own-wrapper class)))) 513 (slot-vector 514 (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))) 515 (setf (slot-vector.instance slot-vector) instance) 516 (setf (gethash instance *objc-object-slot-vectors*) slot-vector) 517 instance)) 655 (let* ((instance 656 (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs 657 class 658 initargs)) 659 (apply #'%send ; For now; Use SEND macro eventually 660 (%send class 'alloc) (lisp-to-objc-init ks) vs)))) 661 (unless (%null-ptr-p instance) 662 (let* ((len (length (%wrapper-instance-slots (class-own-wrapper class)))) 663 (slot-vector 664 (unless (zerop len) 665 (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))))) 666 (setf (slot-vector.instance slot-vector) instance) 667 (setf (gethash instance *objc-object-slot-vectors*) slot-vector) 668 (terminate-when-unreachable instance) 669 (retain-obcj-object instance) 670 instance)))) 671 672 (defmethod terminate ((instance objc:objc-object)) 673 (objc-message-send instance "release")) 674 675 518 676 519 677 (defmethod initialize-instance ((instance objc:objc-object) &rest initargs) … … 522 680 (defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs) 523 681 (apply #'shared-initialize instance nil initargs)) 682 683 (defmethod initialize-instance :after ((class objc:objc-class) &rest initargs) 684 (declare (ignore initargs)) 685 (unless (slot-value class 'foreign) 686 (multiple-value-bind (ivars instance-size) 687 (%make-objc-ivars class) 688 (%add-objc-class class ivars instance-size)))) 524 689 525 690 (defmethod shared-initialize ((instance objc:objc-object) slot-names 526 691 &rest initargs) 527 692 (let ((class (class-of instance))) 528 ;; Call appropriate ObjC init method529 (multiple-value-bind (ks vs) (keys-and-vals initargs)530 (apply #'%send instance (lisp-to-objc-init ks) vs))531 693 ;; Initialize CLOS slots 532 694 (dolist (slotd (class-slots class)) … … 554 716 instance)) 555 717 718 (defmethod shared-initialize :after ((spec foreign-effective-slot-definition) 719 slot-names 720 &key &allow-other-keys) 721 (declare (ignore slot-names)) 722 (setf (slot-value spec 'type-predicate) #'true)) 723 724 ;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS, 725 ;;; but not necessarily the one specified as a :metaclass option to 726 ;;; DEFCLASS or ENSURE-CLASS. Allow an existing class to be reinitialized, 727 ;;; as long as the specified :metaclass and the class's own class have 728 ;;; the same metaclass and specified metaclass is a root class. 729 730 (defmethod ensure-class-using-class ((class objc:objc-class) 731 name 732 &rest keys &key) 733 (multiple-value-bind (metaclass initargs) 734 (ensure-class-metaclass-and-initargs class keys) 735 (let* ((existing-metaclass (class-of class))) 736 (if (and (eq (class-of metaclass) 737 (class-of existing-metaclass)) 738 ;; A root metaclass has the corresponding class as 739 ;; its superclass, and that class has no superclass. 740 (with-macptrs ((super (pref metaclass :objc_class.super_class))) 741 (and (not (%null-ptr-p super)) 742 (not (%objc-metaclass-p super)) 743 (%null-ptr-p (pref super :objc_class.super_class))))) 744 ;; Whew! it's ok to reinitialize the class. 745 (progn 746 (apply #'reinitialize-instance class initargs) 747 (setf (find-class name) class)) 748 (error "Can't change metaclass of ~s to ~s." class metaclass))))) 749 750 556 751 557 752 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 570 765 ;;; already existing subclass of OBJC:OBJC-CLASS 571 766 767 768 769 770 572 771 (defun compute-objc-variable-name (sym) 573 772 (let* ((pname (string sym)) … … 579 778 580 779 (defmethod allocate-instance ((metaclass objc:objc-metaclass) 581 &key name direct-superclasses direct-slots780 &key name direct-superclasses 582 781 &allow-other-keys) 583 (let ((class-name (compute-objc-classname name)) 584 (superclass-name 782 (let ((superclass 585 783 (loop for s in direct-superclasses 586 784 when (typep s 'objc:objc-class) … … 588 786 finally 589 787 (if (= (length objc-supers) 1) 590 (return ( compute-objc-classname (class-name (first objc-supers))))788 (return (first objc-supers)) 591 789 (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" 592 790 direct-superclasses 593 (length objc-supers))))) 594 (ivars 595 (loop for splist in direct-slots 596 when (getf splist :foreign) 597 collect (list (compute-objc-variable-name (getf splist :name)) 598 (or (getf splist :type) :id))))) 599 (%define-objc-class (note-objc-class class-name superclass-name ivars)))) 600 601 (defmethod shared-initialize ((class objc:objc-class) slot-names &rest initargs) 602 ;; *** validate superclasses 603 ;; *** create direct slot definition objects 604 ;; *** dependency maintenance 605 ;; *** maybe finalize inheritance 606 class) 791 (length objc-supers)))))) 792 (%allocate-objc-class name superclass))) 793 794 (defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs) 795 (%shared-initialize class slot-names initargs)) 607 796 608 797 (defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class)) … … 618 807 class) 619 808 809 ;;; Reader/writer methods for instances of OBJC:OBJC-CLASS 810 (defmethod reader-method-class ((class objc:objc-class) 811 (dslotd direct-slot-definition) 812 &rest initargs) 813 (declare (ignore initargs)) 814 (find-class 'standard-reader-method)) 815 816 (defmethod writer-method-class ((class objc:objc-class) 817 (dslotd direct-slot-definition) 818 &rest initargs) 819 (declare (ignore initargs)) 820 (find-class 'standard-reader-method))
Note:
See TracChangeset
for help on using the changeset viewer.
