;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 2003-2009 Clozure Associates and contributors.
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html
;;;
;;; TO DO
;;;  - Both method creation and invocation should be faster and cons less
;;;  - Resolve messages with repeated keywords
;;;    (rename them to :range1:range2 or don't use &key in GFs and methods)
;;;  - How to integrate SEND-SUPER with CALL-NEXT-METHOD?
;;;  - Variable arity ObjC methods
;;;  - Pass-by-ref structures need to keep track of IN, OUT, IN/OUT info

;;;  - Need to canonicalize and retain every returned :ID
;;;  - Support :BEFORE, :AFTER and :AROUND for ObjC methods
;;;  - User-defined ObjC methods via DEFMETHOD (or DEFINE-OBJ-METHOD)
;;;  - Need to fully handle init keywords and ObjC init messages

;;; Package and module stuff

(in-package "CCL")

(eval-when (:compile-toplevel :execute)
  #+(or apple-objc cocotron-objc)
  (use-interface-dir :cocoa)
  #+gnu-objc
  (use-interface-dir :gnustep))

(require "SEQUENCE-UTILS")
;;; We need OBJC-FOREIGN-ARG-TYPE from the bridge to process ivar types
(require "BRIDGE")


(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore.  Note that this may exacerbate compatibility problems.")





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                                 Testing                                ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Enable some debugging output.
(defparameter *objc-clos-debug* nil)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                     OBJC Foreign Object Domain                         ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defconstant objc-type-flags (byte 3 20))
(defconstant objc-type-index (byte 20 0))
(defconstant objc-flag-instance 0)
(defconstant objc-flag-class 1)
(defconstant objc-flag-metaclass 2)

(defvar *objc-class-class*)
(defvar *objc-metaclass-class*)

(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql))



(defun recognize-objc-object (p)
  (labels ((recognize (p mapped)
             (let* ((idx (objc-class-id p)))
               (if idx
                 (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))
                 (if (setq idx (objc-metaclass-id p))
                   (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))
                   (if (setq idx (%objc-instance-class-index p))
                     (%set-macptr-type p idx)
                     (unless mapped
                       (if (maybe-map-objc-classes)
                         (recognize p t)))))))))
    (recognize p nil)))

(defun release-canonical-nsobject (object)
  object)

  

(defun %objc-domain-class-of (p)
  (let* ((type (%macptr-type p))
	 (flags (ldb objc-type-flags type))
	 (index (ldb objc-type-index type)))
    (declare (fixnum type flags index))
    (ecase flags
      (#.objc-flag-instance (id->objc-class index))
      (#.objc-flag-class (objc-class-id->objc-metaclass index))
      (#.objc-flag-metaclass *objc-metaclass-class*))))
  
(defun %objc-domain-classp (p)
  (let* ((type (%macptr-type p))
	 (flags (ldb objc-type-flags type)))
    (declare (fixnum type flags))
    (not (= flags objc-flag-instance))))

(defun %objc-domain-instance-class-wrapper (p)
  (let* ((type (%macptr-type p))
	 (flags (ldb objc-type-flags type))
	 (index (ldb objc-type-index type)))
    (declare (fixnum type flags index))
    (ecase flags
      (#.objc-flag-instance (id->objc-class-wrapper index))
      (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index)))
      (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*)))))

(defun %objc-domain-class-own-wrapper (p)
  (let* ((type (%macptr-type p))
	 (flags (ldb objc-type-flags type))
	 (index (ldb objc-type-index type)))
    (declare (fixnum type flags index))
    (ecase flags
      (#.objc-flag-instance nil)
      (#.objc-flag-class (id->objc-class-wrapper index))
      (#.objc-flag-metaclass (id->objc-metaclass-wrapper index)))))

(defun has-lisp-slot-vector (p)
  (gethash p *objc-object-slot-vectors*))

(defun %remove-lisp-slot-vector (p)
  (remhash p *objc-object-slot-vectors*))

(defun objc:remove-lisp-slots (p)
  (%remove-lisp-slot-vector p))

(defun %objc-domain-slots-vector (p)
  (let* ((type (%macptr-type p))
         (flags (ldb objc-type-flags type))
         (index (ldb objc-type-index type)))
    (declare (fixnum type flags index))
    (ecase flags
      (#.objc-flag-instance (or (gethash p *objc-object-slot-vectors*)
                                        ; try to allocate the slot vector on demand
                                (let* ((slot-vector (create-foreign-instance-slot-vector (class-of p))))
                                  (when slot-vector
                                    (let* ((copy (%inc-ptr p 0)))
                                      (setf (slot-vector.instance slot-vector) copy)
                                      (setf (gethash copy *objc-object-slot-vectors*) slot-vector))
                                    (initialize-instance p))
                                  slot-vector)
                                (error "~s has no slots." p)))
      (#.objc-flag-class (id->objc-class-slots-vector index))
      (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index)))))

(defun %objc-domain-class-ordinal (p)
  (let* ((type (%macptr-type p))
	 (flags (ldb objc-type-flags type))
	 (index (ldb objc-type-index type)))
    (declare (fixnum type flags index))
    (ecase flags
      (#.objc-flag-instance nil)
      (#.objc-flag-class (objc-class-id->ordinal index))
      (#.objc-flag-metaclass (objc-metaclass-id->ordinal index)))))

(defun %set-objc-domain-class-ordinal (p new)
  (let* ((type (%macptr-type p))
	 (flags (ldb objc-type-flags type))
	 (index (ldb objc-type-index type)))
    (declare (fixnum type flags index))
    (ecase flags
      (#.objc-flag-instance nil)
      (#.objc-flag-class (setf (objc-class-id->ordinal index) new))
      (#.objc-flag-metaclass (setf (objc-metaclass-id->ordinal index) new)))))

(defloadvar *objc-object-domain*
    (register-foreign-object-domain :objc
				:recognize #'recognize-objc-object
				:class-of #'%objc-domain-class-of
				:classp #'%objc-domain-classp
				:instance-class-wrapper
				#'%objc-domain-instance-class-wrapper
				:class-own-wrapper
				#'%objc-domain-class-own-wrapper
				:slots-vector #'%objc-domain-slots-vector
				:class-ordinal #'%objc-domain-class-ordinal
				:set-class-ordinal
				#'%set-objc-domain-class-ordinal))

;;; P is known to be a (possibly null!) instance of some ObjC class.
(defun %set-objc-instance-type (p)
  (unless (%null-ptr-p p)
    (let* ((parent (#_object_getClass p))
           (id (objc-class-id parent)))
      (when id
        (%set-macptr-domain p *objc-object-domain*)
        (%set-macptr-type p id)))))

;;; P is known to be of type :ID.  It may be null.
(defun %set-objc-id-type (p)
  (let* ((idx (objc-class-id p)))
    (if idx
      (progn
        (%set-macptr-domain p *objc-object-domain*)
        (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx)))
      (if (setq idx (objc-metaclass-id p))
        (progn
          (%set-macptr-domain p *objc-object-domain*)  
          (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx)))
        (%set-objc-instance-type p)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                  ObjC Objects, Classes and Metaclasses                 ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass objc:objc-object (foreign-standard-object)
    ())

;;; "Real" OBJC-CLASSes and OBJC-METACLASSEs are subtypes of this
;;; abstract class.  We need to keep track of those classes that're
;;; implemented in lisp separately (so that they can be restored after
;;; SAVE-APPLICATION).

(defclass objc:objc-class-object (foreign-class objc:objc-object)
    ((foreign :initform nil :initarg :foreign)
     (peer :initform nil :initarg :peer)))

(defclass objc:objc-metaclass (objc:objc-class-object)
    ())

(setq *objc-metaclass-class* (find-class 'objc:objc-metaclass))

(defclass objc:objc-class (objc:objc-class-object)
    ())

(setq *objc-class-class* (find-class 'objc:objc-class))

(deftype @metaclass (&optional string)
  (declare (ignore string))
  'objc:objc-class)

(defmethod objc-metaclass-p ((c class))
  nil)

(defmethod objc-metaclass-p ((c objc:objc-class-object))
  (%objc-metaclass-p c))


(defmethod print-object ((c objc:objc-class) stream)
  (print-unreadable-object (c stream)
    (format stream "~s ~:[~;[MetaClass] ~]~s (#x~x)" 
	    'objc:objc-class 
	    (objc-metaclass-p c) 
	    (if (slot-boundp c 'name)
              (class-name c)
              "<unnamed>")
	    (%ptr-to-int c))))

(defmethod print-object ((c objc:objc-metaclass) stream)
  (print-unreadable-object (c stream)
    (format stream "~s ~s (#x~x)" 
	    'objc:objc-metaclass 
	    (if (slot-boundp c 'name)
              (class-name c)
              "<unnamed>") 
	    (%ptr-to-int c))))

(defmethod print-object ((o objc:objc-object) stream)
  (if (objc-object-p o)
    (print-unreadable-object (o stream :type t)
      (format stream
              (if (and (typep o 'ns::ns-string)
                       (initialized-nsobject-p o))
                "~s (#x~x)"
                "~a (#x~x)")
              (nsobject-description o) (%ptr-to-int o)))
    (format stream "#<Bogus ObjC Object #x~X>" (%ptr-to-int o))))



  


(defun make-objc-class-object-slots-vector (class meta)
  (let* ((n (1+ (length (extract-instance-effective-slotds meta))))
	 (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker))))
    (setf (slot-vector.instance slots) class)
    slots))

(defun make-objc-metaclass-slots-vector (metaclass)
  (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*))

(defun make-objc-class-slots-vector (class)
  (make-objc-class-object-slots-vector class *objc-class-class*))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                              Slot Protocol                             ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Accessing Lisp slots

(defmethod slot-boundp-using-class ((class objc:objc-class-object)
				    instance
				    (slotd standard-effective-slot-definition))
  (%std-slot-vector-boundp (%objc-domain-slots-vector instance) slotd))

(defmethod slot-value-using-class ((class objc:objc-class-object)
				   instance
				   (slotd standard-effective-slot-definition))
  (%std-slot-vector-value (%objc-domain-slots-vector instance) slotd))

(defmethod (setf slot-value-using-class)
    (new
     (class objc:objc-class-object)
     instance
     (slotd standard-effective-slot-definition))
  (%set-std-slot-vector-value (%objc-domain-slots-vector instance) slotd new))


;;; Metaclasses for foreign slots

(defclass foreign-direct-slot-definition (direct-slot-definition)
  ((foreign-type  :initform :id :accessor foreign-slot-definition-foreign-type)
   (bit-offset :initarg :bit-offset
               :initform nil
               :accessor foreign-direct-slot-definition-bit-offset
               :documentation "A bit-offset, relative to the start of the
               instance's slots.  The corresponding effective slot definition's
                offset is strictly determined by this value")))

(defmethod shared-initialize :after ((slotd foreign-direct-slot-definition)
                                     slot-names
                                     &key (foreign-type :id))
  (declare (ignore slot-names))
  (unless (typep foreign-type 'foreign-type)
    (setq foreign-type (parse-foreign-type foreign-type)))
  (setf (foreign-slot-definition-foreign-type slotd) foreign-type))


(defclass foreign-effective-slot-definition (effective-slot-definition)
  ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type)
   (getter :type function :accessor foreign-slot-definition-getter)
   (setter :type function :accessor foreign-slot-definition-setter)))


;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute
;;  

(defmethod direct-slot-definition-class ((class objc:objc-class-object)
					 &rest initargs)
  (if (getf initargs :foreign-type)
    (find-class 'foreign-direct-slot-definition)
    (find-class 'standard-direct-slot-definition)))

(defmethod effective-slot-definition-class ((class objc:objc-class-object)
					    &rest initargs)
  (if (getf initargs :foreign-type)
    (find-class 'foreign-effective-slot-definition)
    (find-class 'standard-effective-slot-definition)))


(defun set-objc-foreign-direct-slot-offsets (dslotds bit-offset)
  (dolist (d dslotds)
    (let* ((ftype (foreign-slot-definition-foreign-type d))
           (type-alignment (progn (ensure-foreign-type-bits ftype)
                                  (foreign-type-alignment ftype))))
      (setf (foreign-direct-slot-definition-bit-offset d)
            (setq bit-offset
                  (align-offset bit-offset type-alignment)))
      (setq bit-offset (+ bit-offset (foreign-type-bits ftype))))))

(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class))
  #-(or apple-objc-2.0 cocotron-objc)
  (let* ((foreign-dslotds
	  (loop for d in dslotds
		when (typep d 'foreign-direct-slot-definition)
		collect d))
         (bit-offset (dolist (c (class-direct-superclasses class) 0)
                       (when (typep c 'objc::objc-class)
                         (return
                           (ash (%objc-class-instance-size c)
                                3))))))
    (unless
        (dolist (d foreign-dslotds t)
          (if (not (foreign-direct-slot-definition-bit-offset d))
            (return nil)))
      (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset)))
  #+(or apple-objc-2.0 cocotron-objc)
  ;; Add ivars for each foreign direct slot, then ask the runtime for
  ;; the ivar's byte offset.  (Note that the ObjC 2.0 ivar initialization
  ;; protocol doesn't seem to offer support for bitfield-valued ivars.)
  (dolist (dslotd dslotds)
    (when (typep dslotd 'foreign-direct-slot-definition)
      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
             (type (foreign-slot-definition-foreign-type dslotd))
             (encoding (progn
                         (ensure-foreign-type-bits type)
                         (encode-objc-type type)))
             (size (ceiling (foreign-type-bits type) 8))
             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
        (with-cstrs ((name string)
                     (encoding encoding))
          (when (eql #$NO (#_class_addIvar class name size align encoding))
            (error "class_addIvar failed"))
          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
            (unless (%null-ptr-p ivar)
              (let* ((offset (#_ivar_getOffset ivar)))
                (setf (foreign-direct-slot-definition-bit-offset dslotd)
                      (ash offset 3))))))))))


#+(or apple-objc-2.0 cocotron-objc)
(defun %revive-foreign-slots (class)
  (dolist (dslotd (class-direct-slots class))
    (when (typep dslotd 'foreign-direct-slot-definition)
      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
             (type (foreign-slot-definition-foreign-type dslotd))
             (encoding (progn
                         (ensure-foreign-type-bits type)
                         (encode-objc-type type)))
             (size (ceiling (foreign-type-bits type) 8))
             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
        (with-cstrs ((name string)
                     (encoding encoding))
          (#_class_addIvar class name size align encoding)
          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
              (unless (%null-ptr-p ivar)
                (let* ((offset (#_ivar_getOffset ivar)))
                  (unless (eql (foreign-direct-slot-definition-bit-offset dslotd)
                               (ash offset 3))
                    (dbg))))))))))

(defun lisp-defined-slot-name-to-objc-slot-name (lisp-name)
  (lisp-to-objc-message (list lisp-name)))

;;; This is only going to be called on a class created by the user;
;;; each foreign direct slotd's offset field should already have been
;;; set to the slot's bit offset.
#-(or apple-objc-2.0 cocotron-objc)
(defun %make-objc-ivars (class)
  (let* ((start-offset (superclass-instance-size class))
	 (foreign-dslotds (loop for s in (class-direct-slots class)
				when (typep s 'foreign-direct-slot-definition)
				collect s)))
    (if (null foreign-dslotds)
      (values (%null-ptr) start-offset)
      (let* ((n (length foreign-dslotds))
	     (offset start-offset)
	     (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size
				       :objc_ivar :bytes))))))
      (setf (pref ivars :objc_ivar_list.ivar_count) n)
      (do* ((l foreign-dslotds (cdr l))
	    (dslotd (car l) (car l))
	    (ivar (pref ivars :objc_ivar_list.ivar_list)
		  (%inc-ptr ivar (%foreign-type-or-record-size
				 :objc_ivar :bytes))))
	   ((null l) (values ivars (ash (align-offset offset 32) 3)))
	(let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
	       (type (foreign-slot-definition-foreign-type dslotd))
	       (encoding (progn
                           (ensure-foreign-type-bits type)
                           (encode-objc-type type))))
	  (setq offset (foreign-direct-slot-definition-bit-offset dslotd))
	  (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string)
		(pref ivar :objc_ivar.ivar_type) (make-cstring encoding)
		(pref ivar :objc_ivar.ivar_offset) (ash offset -3))
          (incf offset (foreign-type-bits type))))))))
  
  

(defun %objc-ivar-offset-in-class (name c)
  ;; If C is a non-null ObjC class that contains an instance variable
  ;; named NAME, return that instance variable's offset,  else return
  ;; NIL.
  #+(or apple-objc-2.0 cocotron-objc)
  (with-cstrs ((name name))
    (with-macptrs ((ivar (#_class_getInstanceVariable c name)))
      (unless (%null-ptr-p ivar)
        (#_ivar_getOffset ivar))))
  #-(or apple-objc-2.0 cocotron-objc)
  (when (objc-class-p c)
    (with-macptrs ((ivars (pref c :objc_class.ivars)))
      (unless (%null-ptr-p ivars)
	(loop with n = (pref ivars :objc_ivar_list.ivar_count)
	      for i from 1 to n
	      for ivar = (pref ivars :objc_ivar_list.ivar_list) 
	          then (%inc-ptr ivar (record-length :objc_ivar))
	      when (string= name (%get-cstring (pref ivar :objc_ivar.ivar_name)))
	        do (return-from %objc-ivar-offset-in-class (pref ivar :objc_ivar.ivar_offset)))))))

(defun %objc-ivar-offset (name c)
  (labels ((locate-objc-slot (name class)
	     (unless (%null-ptr-p class)
		 (or (%objc-ivar-offset-in-class name class)
		     (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc)
                                           (#_class_getSuperclass class)
                                           #-(or apple-objc-2.0 cocotron-objc)
                                           (pref class :objc_class.super_class)))
		       (unless (or (%null-ptr-p super) (eql super class))
			 (locate-objc-slot name super)))))))
    (when (objc-class-p c)
      (or (locate-objc-slot name c)
	  (error "No ObjC instance variable named ~S in ~S" name c)))))

;;; Maintain the class wrapper of an ObjC class or metaclass.

(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass))
  (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper))

(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class))
  (setf (id->objc-class-wrapper (objc-class-id class)) wrapper))

;;; Return the getter and setter functions for a foreign slot
;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE

(defun compute-foreign-slot-accessors (eslotd)
  (let* ((ftype (foreign-slot-definition-foreign-type eslotd))
         (ordinal (foreign-type-ordinal ftype)))
    (etypecase ftype
      (foreign-integer-type
       (let* ((bits (foreign-integer-type-bits ftype))
	      (align (foreign-integer-type-alignment ftype))
	      (signed (foreign-integer-type-signed ftype)))
         (if (= bits align)
	   (case bits
	     (1 (values #'%get-bit #'%set-bit))
	     (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte)
			#'%set-byte))
	     (16 (values (if signed #'%get-signed-word #'%get-unsigned-word)
			 #'%set-word))
	     (32 (values (if signed #'%get-signed-long #'%get-unsigned-long)
			 #'%set-long))
	     (64 (if signed
		   (values #'%%get-signed-longlong #'%%set-signed-longlong)
		   (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)))
             (t (values #'(lambda (ptr offset)
                       (%get-bitfield ptr offset bits))
                   #'(lambda (ptr offset new)
                       (setf (%get-bitfield ptr offset bits) new)))))
           (values #'(lambda (ptr offset)
                       (%get-bitfield ptr offset bits))
                   #'(lambda (ptr offset new)
                       (setf (%get-bitfield ptr offset bits) new))))))
      (foreign-double-float-type
       (values #'%get-double-float #'%set-double-float))
      (foreign-single-float-type
       (values #'%get-single-float #'%set-single-float))
      (foreign-pointer-type
       (if (objc-id-type-p ftype)
         (values #'%get-ptr #'%set-ptr)
         (let* ((to (foreign-pointer-type-to ftype))
                (to-ordinal (if to (foreign-type-ordinal to) 0)))
           (values #'(lambda (ptr offset)
                       (let* ((p (%null-ptr)))
                         (%setf-macptr p (%get-ptr ptr offset))
                         (unless (%null-ptr-p p)
                           (%set-macptr-domain p 1)
                           (%set-macptr-type p to-ordinal))
                         p))
                   #'%set-ptr))))
      (foreign-mem-block-type
       (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
	 (values #'(lambda (ptr offset)
                     (let* ((p (%inc-ptr ptr offset)))
                       (%set-macptr-type p ordinal)
                       p))
                 #'(lambda (pointer offset new)
				(setf (%composite-pointer-ref
				       nbytes
				       pointer
				       offset)
				      new))))))))
    


;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a
;;; method for OBJC-CLASSes that sets up foreign slot info.

(defmethod compute-effective-slot-definition :around ((class objc:objc-class-object)
						      name
						      direct-slots)
  (let* ((first (first direct-slots)))
    (if (not (typep first 'foreign-direct-slot-definition))
      (call-next-method)
      (let* ((initer (dolist (s direct-slots)
		       (when (%slot-definition-initfunction s)
			 (return s))))
	     (documentor (dolist (s direct-slots)
			   (when (%slot-definition-documentation s)
			     (return s))))
	     (initargs (let* ((initargs nil))
			 (dolist (dslot direct-slots initargs)
			   (dolist (dslot-arg (%slot-definition-initargs  dslot))
			     (pushnew dslot-arg initargs :test #'eq)))))
	     (eslotd
	       (make-effective-slot-definition
		class
		:name name
		:allocation :instance
		:type (or (%slot-definition-type first) t)
		:documentation (when documentor (nth-value
				      1
				      (%slot-definition-documentation
				       documentor)))
		:class (%slot-definition-class first)
		:initargs initargs
		:initfunction (if initer
				(%slot-definition-initfunction initer))
		:initform (if initer (%slot-definition-initform initer))
		:foreign-type (foreign-slot-definition-foreign-type first))))
      (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd)
	(setf (foreign-slot-definition-getter eslotd) getter)
	(setf (foreign-slot-definition-setter eslotd) setter))
      eslotd))))

(defun bit-offset-to-location (bit-offset foreign-type)
  (ensure-foreign-type-bits foreign-type)
  (let* ((bits (foreign-type-bits foreign-type)))
    (if (or (= bits 1)
            (and (not (typep foreign-type 'foreign-mem-block-type))
                 (not (= bits (foreign-type-alignment foreign-type)))))
      bit-offset
      (ash bit-offset -3))))

;;; Determine the location of each slot
;;; An effective slot's location is
;;; a) a function of the class's origin (superclass-instance-size)
;;;    and the corresponding direct class's offset, if it's defined in the
;;;    class (has a corresponding direct-slot-definition in the class)
;;; b) Exactly the same as the superclass's version's location, because
;;;    of single inheritance.

(defun determine-foreign-slot-location (class slot-name)
  (or
   (dolist (d (class-direct-slots class))
     (when (and (eq slot-name (slot-definition-name d))
                (typep d 'foreign-direct-slot-definition))
       (return (bit-offset-to-location
                (foreign-direct-slot-definition-bit-offset d)
                (foreign-slot-definition-foreign-type d )))))
   (dolist (super (class-direct-superclasses class))
     (when (typep super 'objc:objc-class) ; can be at most 1
       (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name)))
	 (when e (return (slot-definition-location e))))))
   (error "Can't find slot definition for ~s in ~s" slot-name class)))
	  

(defmethod compute-slots :around ((class objc:objc-class-object))
  (flet ((foreign-slot-p (s) (typep s 'foreign-effective-slot-definition)))
    (let* ((cpl (%class-precedence-list class))
	   (slots (call-next-method))
	   (instance-slots 
	    (remove-if #'foreign-slot-p 
		       (remove :class slots :key #'%slot-definition-allocation)))
	   (class-slots (remove :instance slots :key #'%slot-definition-allocation))
	   (foreign-slots (remove-if-not #'foreign-slot-p slots)))
      (setq instance-slots
	    (sort-effective-instance-slotds instance-slots class cpl))
      (when *objc-clos-debug*
	(format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%"
		instance-slots class-slots foreign-slots))
      (loop for islot in instance-slots
	    for loc = 1 then (1+ loc)
	    do (setf (%slot-definition-location islot) loc))
      (dolist (cslot class-slots)
	(setf (%slot-definition-location cslot)
	      (assoc (%slot-definition-name cslot)
		     (%class-get (%slot-definition-class cslot) :class-slots)
		     :test #'eq)))
      (dolist (fslot foreign-slots)
	(setf (%slot-definition-location fslot)
	      (determine-foreign-slot-location
	       class
	       (%slot-definition-name fslot))))
      (append instance-slots class-slots foreign-slots))))


;;; Accessing foreign slots

(defmethod slot-boundp-using-class ((class objc:objc-class-object)
				    instance
				    (slotd foreign-effective-slot-definition))
  (declare (ignore class instance slotd))
  ;; foreign slots are always bound
  t)

(defmethod slot-makunbound-using-class ((class objc:objc-class-object)
					instance
					(slotd foreign-effective-slot-definition))
  (declare (ignore instance))
  (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd)))

(defmethod slot-value-using-class ((class objc:objc-class-object)
				   instance
				   (slotd foreign-effective-slot-definition))
  (funcall (foreign-slot-definition-getter slotd)
	   instance
	   (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value
					  (class objc:objc-class-object)
					  instance
					  (slotd foreign-effective-slot-definition))
  (funcall (foreign-slot-definition-setter slotd)
	   instance
	   (slot-definition-location slotd)
	   value))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;            Instance Allocation and Initialization Protocols            ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod make-instance ((class objc:objc-class-object) &rest initargs)
  (setq initargs (default-initargs class initargs))
  (let ((instance (apply #'allocate-instance class initargs)))
    (if (%null-ptr-p instance)
      instance
      (apply #'initialize-instance instance initargs))))


(defun remove-slot-initargs (class initargs)
  (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe
    (collect ((new-initargs))
    (loop for l = initargs then (cddr l)
	  when (null l) do (return-from remove-slot-initargs (new-initargs))
	  unless (member (first l)  slot-initargs :test #'eq)
          do
          (new-initargs (car l))
          (new-initargs (cadr l))))))

(defun create-foreign-instance-slot-vector (class)
  (let* ((max 0))
    (dolist (slotd (class-slots class)
	     (unless (zerop max)
	       (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker))))
      (when (typep slotd 'standard-effective-slot-definition)
	(let* ((loc (slot-definition-location slotd)))
	  (if (> loc max)
	    (setq max loc)))))))


(defun ensure-lisp-slots (instance class)
  (unless (%null-ptr-p instance)
    (or (gethash instance *objc-object-slot-vectors*)
        (let* ((slot-vector (create-foreign-instance-slot-vector class)))
          (when slot-vector
            (let* ((copy (%inc-ptr instance 0)))
              (setf (slot-vector.instance slot-vector) copy)
            (setf (gethash copy *objc-object-slot-vectors*) slot-vector))))))
  instance)
	       
(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys)
  (unless (class-finalized-p class)
    (finalize-inheritance class))
  (send-init-message-for-class class initargs))


(defmethod initialize-instance ((instance objc:objc-object) &rest initargs)
  (apply #'shared-initialize instance t initargs))

(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs)
  (apply #'shared-initialize instance nil initargs))

(defmethod initialize-instance :after ((class objc:objc-class)
				       &key name objc-protocols
					 &allow-other-keys)
  (unless (slot-value class 'foreign)
    #-(or apple-objc-2.0 cocotron-objc)
    (multiple-value-bind (ivars instance-size)
	(%make-objc-ivars class)
      (%add-objc-class class ivars instance-size))
    #+(or apple-objc-2.0 cocotron-objc)
    (%add-objc-class class)
    (setf (find-class name) class)
    (dolist (name objc-protocols)
      (let ((p (%get-objc-protocol (objc-class-name-string name))))
	(%add-objc-protocol class p)))
    (ensure-dealloc-method-for-class class)))

(defmethod shared-initialize ((instance objc:objc-object) slot-names 
			      &rest initargs)
  (let ((class (class-of instance)))
    ;; Initialize CLOS slots
    (dolist (slotd (class-slots class))
      (let* ((foreign (typep slotd 'foreign-effective-slot-definition))
             (sname (slot-definition-name slotd))
             (slot-type (slot-definition-type slotd))
             (typepred (unless foreign (slot-value slotd 'type-predicate)))
             (initfunction (unless foreign (slot-definition-initfunction slotd))))
        (multiple-value-bind (ignore newval foundp)
            (get-properties initargs
                            (slot-definition-initargs slotd))
          (declare (ignore ignore))
          (if foundp
            (if (or (null typepred)
                    (funcall typepred newval))
              (setf (slot-value instance sname) newval)
              (report-bad-arg newval slot-type))
            (unless foreign
              (let* ((loc (slot-definition-location slotd))
		     (curval (%standard-instance-instance-location-access
                              instance loc)))
		(when (and (or (eq slot-names t) 
			       (member sname slot-names :test #'eq))
			   (eq curval (%slot-unbound-marker))
			   initfunction)
		  (let ((newval (funcall initfunction)))
		    (unless (or (null typepred)
                                (funcall typepred newval))
		      (report-bad-arg newval slot-type))
		    (setf (%standard-instance-instance-location-access
			   instance loc)
			  newval)))))))))
    instance))

(defmethod shared-initialize :after ((spec foreign-effective-slot-definition)
				     slot-names
				     &key &allow-other-keys)
  (declare (ignore slot-names))
  (setf (slot-value spec 'type-predicate) #'true))

;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS,
;;; but not necessarily the one specified as a :metaclass option to
;;; DEFCLASS or ENSURE-CLASS.  Allow an existing class to be reinitialized,
;;; as long as the specified :metaclass and the class's own class have
;;; the same metaclass and specified metaclass is a root class.

(defmethod ensure-class-using-class ((class objc:objc-class)
				     name
				     &rest keys &key)
  (multiple-value-bind (metaclass initargs)
      (ensure-class-metaclass-and-initargs class keys)
    (let* ((existing-metaclass (class-of class)))
      (if (and (eq (class-of metaclass)
		   (class-of existing-metaclass))
	       ;; A root metaclass has the corresponding class as
	       ;; its superclass, and that class has no superclass.
	       (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc)
                                     (#_class_getSuperclass metaclass)
                                     #-(or apple-objc-2.0 cocotron-objc)
                                     (pref metaclass :objc_class.super_class)))
		 (and (not (%null-ptr-p super))
		      (not (%objc-metaclass-p super))
		      (%null-ptr-p
                       #+(or apple-objc-2.0 cocotron-objc)
                       (#_class_getSuperclass super)
                       #-(or apple-objc-2.0 cocotron-objc)
                       (pref super :objc_class.super_class)))))
	;; Whew! it's ok to reinitialize the class.
	(progn
	  (apply #'reinitialize-instance class initargs)
	  (setf (find-class name) class)
          (ensure-dealloc-method-for-class class)
          class)
	(error "Can't change metaclass of ~s to ~s." class metaclass)))))

  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;              Class Definition and Finalization Protocols               ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Create the ObjC class/metaclass pair and dress it up in its minimal CLOS garb
;;; This currently requires that exactly one of DIRECT-SUPERCLASSES be a
;;; already existing subclass of OBJC:OBJC-CLASS

(defun compute-objc-variable-name (sym)
  (let* ((pname (string sym))
	 (first-alpha (position-if #'alpha-char-p pname)))
    (string-downcase
     (apply #'string-cat 
	    (mapcar #'string-capitalize (split-if-char #\- pname :elide)))
     :end (if first-alpha (1+ first-alpha) 1))))

(defmethod allocate-instance ((metaclass objc:objc-metaclass) 
			      &key name direct-superclasses
			      &allow-other-keys)
  (let ((superclass
	 (loop for s in direct-superclasses
	       when (typep s 'objc:objc-class)
	         collect s into objc-supers
	       finally 
	       (if (= (length objc-supers) 1)
		   (return (first objc-supers))
		 (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" 
			direct-superclasses
			(length objc-supers))))))
    (%allocate-objc-class name superclass)))

(defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs)
  (%shared-initialize class slot-names initargs))

(defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class))
  t)

(defmethod make-instances-obsolete ((class objc:objc-class))
  class)

;;; Reader/writer methods for instances of OBJC:OBJC-CLASS
(defmethod reader-method-class ((class objc:objc-class)
				(dslotd direct-slot-definition)
				&rest initargs)
  (declare (ignore initargs))
  (find-class 'standard-reader-method))

(defmethod writer-method-class ((class objc:objc-class)
				(dslotd direct-slot-definition)
				&rest initargs)
  (declare (ignore initargs))
  (find-class 'standard-writer-method))


;;; By the time we see this, the slot name has been transformed to the form
;;; "(load-time-value (ensure-slot-id <slot-name>))".
;;; This only works if the setter is SETF inverse of the getter.
(define-compiler-macro slot-id-value (&whole call instance slot-name &environment env)
  (or
   (let* ((type nil))
     (if (and (symbolp instance)
              (subtypep (setq type (cdr (assq 'type (nth-value 2 (variable-information instance env)))))
                        'objc:objc-object
                        env)
              (consp slot-name)
              (eq (car slot-name) 'load-time-value)
              (consp (cdr slot-name))
              (null (cddr slot-name))
              (eq (caadr slot-name) 'ensure-slot-id)
              (consp (cdadr slot-name))
              (null (cddadr slot-name))
              (setq slot-name (cadadr slot-name))
              (quoted-form-p slot-name)
              (setq slot-name (cadr slot-name)))
       (let* ((class (find-class type nil env))
              (eslotd (when class (find slot-name (class-slots class)
                                        :key #'slot-definition-name))))
         (when (typep eslotd 'foreign-effective-slot-definition)
           (let* ((getter (foreign-slot-definition-getter eslotd))
                  (name (if (typep getter 'compiled-function)
                          (function-name getter))))
             (when name
               `(,name ,instance ,(slot-definition-location eslotd))))))))
   call))


