Index: /branches/objc-gf/ccl/examples/bridge.lisp
===================================================================
--- /branches/objc-gf/ccl/examples/bridge.lisp	(revision 6055)
+++ /branches/objc-gf/ccl/examples/bridge.lisp	(revision 6056)
@@ -23,4 +23,561 @@
 (require "OBJC-RUNTIME")
 (require "NAME-TRANSLATION")
+
+#-apple-objc-2.0
+(progn
+  (def-foreign-type :<CGF>loat :float)
+  (def-foreign-type :<NSUI>nteger :unsigned)
+  (def-foreign-type :<NSI>nteger :signed)
+  )
+
+(defconstant +cgfloat-zero+
+  #+(and apple-objc-2.0 64-bit-target) 0.0d0
+  #-(and apple-objc-2.0 64-bit-target) 0.0f0)
+
+(deftype cgfloat ()
+  #+(and apple-objc-2.0 64-bit-target) 'double-float
+  #-(and apple-objc-2.0 64-bit-target) 'single-float)
+
+(deftype cg-float () 'cgfloat)
+
+(deftype nsuinteger ()
+  #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64)
+  #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32))
+
+(deftype nsinteger ()
+  #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64)
+  #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32))
+
+
+;;; Associate foreign structure types with lisp structure types
+(defstruct foreign-struct-association
+  import-function                       ; set lisp struct from foreign
+  export-function                       ; set foreign struct from lisp
+  return-function                       ; create lisp struct from foreign
+  type-predicate                        ; sanity check
+  )
+
+(defparameter *foreign-struct-associations* (make-hash-table :test #'equalp))
+
+(defun create-foreign-struct-association (foreign-structure-type import export return type-predicate)
+  (setf (gethash foreign-structure-type *foreign-struct-associations*)
+        (make-foreign-struct-association :import-function import
+                                         :export-function export
+                                         :return-function return
+                                         :type-predicate type-predicate)))
+
+(defun get-foreign-struct-association (type)
+  (let* ((ftype (if (typep type 'foreign-record-type)
+                  type
+                  (%foreign-type-or-record type))))
+    (values (gethash ftype *foreign-struct-associations*))))
+
+;;; Next, define some lisp structure types that're equivalent to
+;;; Cocoa/CG foreign structure types that're known to be returned
+;;; from Cocoa methods and/or passed by value.  We'll need to be
+;;; able to extend this mechanism to deal with things not used
+;;; in Foundation/AppKit; hopefully, that process can be automated.
+
+;;; There are a bunch of tradeoffs here.  One attractive approach
+;;; is to simply wrap a lisp DEFSTRUCT around some foreign data
+;;; and define some lisp-level accessors for that data, allocating
+;;; the typically small block of data with CCL::%NEW-GCABLE-PTR.
+;;; When the GC discovers that the pointer to that data is no
+;;; longer referenced from lisp, the data will be freed (so be
+;;; careful about cases where foreign code hangs on to pointers
+;;; it doesn't "own.")  This freeing will typically happen at
+;;; some point after a full GC discovers that the encapsulating
+;;; structure has become garbage.  A downside of this scheme is
+;;; that it's possible to have millions of foreign pointers
+;;; floating around between full GCs.
+;;; An upside is that this scheme simplifies cases where
+;;; structures are passed by reference; another is that it
+;;; keeps us from having to worry about structure-layout/endianness
+;;; issues, and a third upside is that it (probably) lends itself
+;;; better to automation. The upsides seem to win out.
+
+(defstruct foreign-struct-encapsulation
+  data)
+
+(defun return-function-for-encapsulation (foreign-size constructor)
+  #'(lambda (pointer)
+      (let* ((data (%new-gcable-ptr foreign-size)))
+        (#_memcpy data pointer foreign-size)
+        (funcall constructor data))))
+
+(defun export-encapsulation (encapsulation pointer)
+  (%setf-macptr pointer (foreign-struct-encapsulation-data encapsulation)))
+
+(defun create-foreign-struct-association-for-encapsulation (foreign-type constructor predicate)
+  (create-foreign-struct-association
+   foreign-type
+   nil
+   'export-encapsulation
+   (return-function-for-encapsulation
+    (%foreign-type-or-record-size foreign-type :bytes) constructor)
+   predicate))
+
+;;; AEDesc (Apple Event Descriptor)
+
+(defconstant aedesc-size (%foreign-type-or-record-size :<AED>esc :bytes))
+
+(defstruct (aedesc (:include foreign-struct-encapsulation)
+                   (:constructor %make-aedesc (data))))
+
+(defun make-aedesc (descriptor-type data-handle)
+  (let* ((data (%new-gcable-ptr aedesc-size)))
+    (setf (pref data :<AED>esc.descriptor<T>ype) descriptor-type
+          (pref data :<AED>esc.data<H>andle) data-handle)
+    (%make-aedesc data)))
+
+(declaim (inline aedesc-descriptor-type aedesc-data-handle
+                 (setf aedesc-descriptor-type) (setf aedesc-data-handle)))
+
+(defun aedesc-descriptor-type (aedesc)
+  (pref (aedesc-data aedesc) :<AED>esc.descriptor<T>ype))
+
+(defun (setf aedesc-descriptor-type) (new aedesc)
+  (setf (pref (aedesc-data aedesc) :<AED>esc.descriptor<T>ype) new))
+
+(defun aedesc-data-handle (aedesc)
+  (pref (aedesc-data aedesc) :<AED>esc.data<H>andle))
+
+(defun (setf aedesc-data-handle) (new aedesc)
+  (setf (pref (aedesc-data aedesc) :<AED>esc.data<H>andle) new))
+
+(defmethod print-object ((a aedesc) stream)
+  (print-unreadable-object (a stream :type t :identity t)
+    (format stream "~s ~s" (aedesc-descriptor-type a) (aedesc-data-handle a))))
+
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<AED>esc)
+ '%make-aedesc
+ 'aedesc-p)
+
+#+apple-objc-2.0
+(progn
+  ;;; It's not clear how useful this would be; I think that it's
+  ;;; part of the ObjC 2.0 extensible iteration stuff ("foreach").
+
+  (defconstant fast-enumeration-state-size (%foreign-type-or-record-size :<NSF>ast<E>numeration<S>tate :bytes))
+  
+  (defstruct (ns-fast-enumeration-state
+               (:include foreign-struct-encapsulation)
+               (:constructor %make-ns-fast-enumeration-state (data))))
+
+  (defun make-ns-fast-enumeration-state ()
+    (%make-ns-fast-enumeration-state (%new-gcable-ptr fast-enumeration-state-size  t)))
+
+  (create-foreign-struct-association-for-encapsulation
+   (parse-foreign-type :<NSF>ast<E>numeration<S>tate)
+   '%make-ns-fast-enumeration-state
+   'ns-fast-enumeration-state-p)
+  )
+
+;;; CGAffineTransform
+
+(defconstant cg-affine-transform-size
+  (%foreign-type-or-record-size :<CGA>ffine<T>ransform :bytes))
+
+(defstruct (cg-affine-transform
+             (:include foreign-struct-encapsulation)
+             (:constructor %make-cg-affine-transform (data))))
+
+(defun make-cg-affine-transform (a b c d tx ty)
+  (let* ((data (%new-gcable-ptr cg-affine-transform-size)))
+    (setf (pref data :<CGA>ffine<T>ransform.a) (float a +cgfloat-zero+)
+          (pref data :<CGA>ffine<T>ransform.b) (float b +cgfloat-zero+)
+          (pref data :<CGA>ffine<T>ransform.c) (float c +cgfloat-zero+)
+          (pref data :<CGA>ffine<T>ransform.d) (float d +cgfloat-zero+)
+          (pref data :<CGA>ffine<T>ransform.tx) (float tx +cgfloat-zero+)
+          (pref data :<CGA>ffine<T>ransform.ty) (float ty +cgfloat-zero+))
+    (%make-cg-affine-transform data)))
+
+(declaim (inline cg-affine-transform-a
+                 cg-affine-transform-b
+                 cg-affine-transform-c
+                 cg-affine-transform-d
+                 cg-affine-transform-tx
+                 cg-affine-transform-ty
+                 (setf cg-affine-transform-a)
+                 (setf cg-affine-transform-b)
+                 (setf cg-affine-transform-c)
+                 (setf cg-affine-transform-d)
+                 (setf cg-affine-transform-tx)
+                 (setf cg-affine-transform-ty)))
+
+(defun cg-affine-transform-a (transform)
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.a))
+
+(defun (setf cg-affine-transform-a) (new transform)
+  (setf
+   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.a)
+   (float new +cgfloat-zero+)))
+
+(defun cg-affine-transform-b (transform)
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.b))
+
+(defun (setf cg-affine-transform-b) (new transform)
+  (setf
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.b)
+   (float new +cgfloat-zero+)))
+
+(defun cg-affine-transform-c (transform)
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.c))
+
+(defun (setf cg-affine-transform-c) (new transform)
+  (setf
+   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.c)
+   (float new +cgfloat-zero+)))
+
+(defun cg-affine-transform-d (transform)
+   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.d))
+
+(defun (setf cg-affine-transform-d) (new transform)
+  (setf
+   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.d)
+   (float new +cgfloat-zero+)))
+
+(defun cg-affine-transform-tx (transform)
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.tx))
+
+(defun (setf cg-affine-transform-tx) (new transform)
+  (setf
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.tx)
+   (float new +cgfloat-zero+)))
+
+(defun cg-affine-transform-ty (transform)
+  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.ty))
+
+(defun (setf cg-affine-transform-ty) (new transform)
+  (setf
+   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.ty)
+   (float new +cgfloat-zero+)))
+
+(defmethod print-object ((transform cg-affine-transform) stream)
+  (print-unreadable-object (transform stream :type t :identity t)
+    (format stream "~s ~s ~s ~s ~s ~s"
+            (cg-affine-transform-a transform)
+            (cg-affine-transform-b transform)
+            (cg-affine-transform-c transform)
+            (cg-affine-transform-d transform)
+            (cg-affine-transform-tx transform)
+            (cg-affine-transform-ty transform))))
+
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type '(:struct :<CGA>ffine<T>ransform))
+ '%make-cg-affine-transform
+ 'cg-affine-transform-p)
+
+
+;;; An <NSA>ffine<T>ransform<S>truct is identical to a
+;;; (:struct :<GGA>ffine<T>ransform), except for the names of its fields.
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<NSA>ffine<T>ransform<S>truct)
+ '%make-cg-affine-transform
+ 'cg-affine-transform-p)
+
+;;; NSDecimal
+
+(defconstant ns-decimal-size (%foreign-type-or-record-size :<NSD>ecimal :bytes))
+
+(defstruct (ns-decimal
+             (:include foreign-struct-encapsulation)
+             (:constructor %make-ns-decimal (data)))
+  )
+
+(defun make-ns-decimal (exponent length is-negative is-compact mantissa)
+  (let* ((data (%new-gcable-ptr ns-decimal-size)))
+    (setf (pref data :<NSD>ecimal._exponent) exponent
+          (pref data :<NSD>ecimal._length) length
+          (pref data :<NSD>ecimal._is<N>egative) (if is-negative 1 0)
+          (pref data :<NSD>ecimal._is<C>ompact) (if is-compact 1 0))
+    (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8))))
+      (declare (type (simple-array (unsigned-byte 16) (8)) v))
+      (with-macptrs ((m (pref data :<NSD>ecimal._mantissa)))
+        (dotimes (i 8 (%make-ns-decimal data))
+          (setf (paref m (:* (:unsigned 16)) i) (aref v i)))))))
+
+(declaim (inline ns-decimal-exponent ns-decimal-length ns-decimal-is-negative
+                 ns-decimal-is-compact ns-decimal-mantissa
+                 (setf ns-decimal-exponent) (setf ns-decimal-length)
+                 (setf ns-decimal-is-negative)
+                 (setf ns-decimal-is-compact) (setf ns-decimal-mantissa)))
+
+(defun ns-decimal-exponent (decimal)
+  (pref (ns-decimal-data decimal) :<NSD>ecimal._exponent))
+
+(defun (setf ns-decimal-exponent) (new decimal)
+  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._exponent) new))
+
+(defun ns-decimal-length (decimal)
+  (pref (ns-decimal-data decimal) :<NSD>ecimal._length))
+
+
+(defun (setf ns-decimal-length) (new decimal)
+  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._length) new))
+
+(defun ns-decimal-is-negative (decimal)
+  (not (zerop (pref (ns-decimal-data decimal) :<NSD>ecimal._is<N>egative))))
+
+(defun (setf ns-decimal-is-negative) (new decimal)
+  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._is<N>egative)
+        (if new 1 0))
+  new)
+
+(defun ns-decimal-is-compact (decimal)
+  (pref (ns-decimal-data decimal) :<NSD>ecimal._is<C>ompact))
+
+(defun (setf ns-decimal-is-compact) (new decimal)
+  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._is<C>ompact)
+        (if new 1 0))
+  new)
+
+(defun ns-decimal-mantissa (decimal)
+  (let* ((data (ns-decimal-data decimal))
+         (dest (make-array 8 :element-type '(unsigned-byte 16))))
+    (with-macptrs ((m (pref data :<NSD>ecimal._mantissa)))
+      (dotimes (i 8 dest)
+        (setf (aref dest i) (paref m (:* (:unsigned 16)) i))))))
+
+(defun (setf ns-decimal-mantissa) (new decimal)
+  (let* ((data (ns-decimal-data decimal))
+         (src (coerce new '(simple-array (unsigned-byte 16) (8)))))
+    (declare (type (simple-array (unsigned-byte 16) 8) src))
+    (with-macptrs ((m (pref data :<NSD>ecimal._mantissa)))
+      (dotimes (i 8 new)
+        (setf (paref m (:* (:unsigned 16)) i) (aref src i))))))
+
+(defmethod print-object ((d ns-decimal) stream)
+  (print-unreadable-object (d stream :type t :identity t)
+    (format stream "exponent = ~d, length = ~s, is-negative = ~s, is-compact = ~s, mantissa = ~s" (ns-decimal-exponent d) (ns-decimal-length d) (ns-decimal-is-negative d) (ns-decimal-is-compact d) (ns-decimal-mantissa d))))
+
+
+
+    
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<NSD>ecimal)
+ '%make-ns-decimal
+ 'ns-decimal-p)    
+
+;;; NSRect
+
+(defconstant ns-rect-size (%foreign-type-or-record-size :<NSR>ect :bytes))
+
+(defstruct (ns-rect (:include foreign-struct-encapsulation)
+                    (:constructor %make-ns-rect (data))))
+
+
+(defun make-ns-rect (x y width height)
+  (let* ((data (%new-gcable-ptr ns-rect-size)))
+    (setf (pref data :<NSR>ect.origin.x) (float x +cgfloat-zero+)
+          (pref data :<NSR>ect.origin.y) (float y +cgfloat-zero+)
+          (pref data :<NSR>ect.size.width) (float width +cgfloat-zero+)
+          (pref data :<NSR>ect.size.height) (float height +cgfloat-zero+))
+    (%make-ns-rect data)))
+
+(declaim (inline ns-rect-x ns-rect-y ns-rect-width ns-rect-height
+                 (setf ns-rect-x) (setf ns-rect-y) (setf ns-rect-width)
+                 (setf ns-rect-height)))
+
+(defun ns-rect-x (rect)
+  (pref (ns-rect-data rect) :<NSR>ect.origin.x))
+
+(defun (setf ns-rect-x) (new rect)
+  (setf (pref (ns-rect-data rect) :<NSR>ect.origin.x)
+        (float new +cgfloat-zero+)))
+
+(defun ns-rect-y (rect)
+  (pref (ns-rect-data rect) :<NSR>ect.origin.y))
+
+(defun (setf ns-rect-y) (new rect)
+  (setf (pref (ns-rect-data rect) :<NSR>ect.origin.y)
+        (float new +cgfloat-zero+)))
+
+(defun ns-rect-width (rect)
+  (pref (ns-rect-data rect) :<NSR>ect.size.width))
+
+(defun (setf ns-rect-width) (new rect)
+  (setf (pref (ns-rect-data rect) :<NSR>ect.size.width)
+        (float new +cgfloat-zero+)))
+
+(defun ns-rect-height (rect)
+  (pref (ns-rect-data rect) :<NSR>ect.size.height))
+
+(defun (setf ns-rect-height) (new rect)
+  (setf (pref (ns-rect-data rect) :<NSR>ect.size.height)
+        (float new +cgfloat-zero+)))
+
+(defmethod print-object ((r ns-rect) stream)
+  (print-unreadable-object (r stream :type t :identity t)
+    (flet ((maybe-round (x)
+             (multiple-value-bind (q r) (round x)
+               (if (zerop r) q x))))
+      (format stream "~s X ~s @ ~s,~s"
+              (maybe-round (ns-rect-width r))
+              (maybe-round (ns-rect-height r))
+              (maybe-round (ns-rect-x r))
+              (maybe-round (ns-rect-y r))))))
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<NSR>ect)
+ '%make-ns-rect
+ 'ns-rect-p)
+
+;;; NSSize
+
+(defconstant ns-size-size (%foreign-type-or-record-size :<NSS>ize))
+
+(defstruct (ns-size (:include foreign-struct-encapsulation)
+                    (:constructor %make-ns-size (data))))
+
+(defun make-ns-size (width height)
+  (let* ((data (%new-gcable-ptr ns-size-size)))
+    (setf (pref data :<NSS>ize.width) (float width +cgfloat-zero+)
+          (pref data :<NSS>ize.height) (float height +cgfloat-zero+))
+    (%make-ns-size data)))
+
+(declaim (inline ns-size-width ns-size-heigh
+                 (setf ns-size-width) (setf ns-size-height)))
+
+(defun ns-size-width (size)
+  (pref (ns-size-data size) :<NSS>ize.width))
+
+(defun (setf ns-size-width) (new size)
+  (setf (pref (ns-size-data size) :<NSS>ize.width)
+        (float new +cgfloat-zero+)))
+
+(defun ns-size-height (size)
+  (pref (ns-size-data size) :<NSS>ize.height))
+
+(defun (setf ns-size-height) (new size)
+  (setf (pref (ns-size-data size) :<NSS>ize.height)
+        (float new +cgfloat-zero+)))
+
+(defmethod print-object ((s ns-size) stream)
+  (flet ((maybe-round (x)
+           (multiple-value-bind (q r) (round x)
+             (if (zerop r) q x))))
+    (print-unreadable-object (s stream :type t :identity t)
+      (format stream "~s X ~s"
+              (maybe-round (ns-size-width s))
+              (maybe-round (ns-size-height s))))))
+
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<NSS>ize)
+ '%make-ns-size
+ 'ns-size-p)
+
+;;; NSPoint
+(defconstant ns-point-size (%foreign-type-or-record-size :<NSP>oint :bytes))
+
+(defstruct (ns-point (:include foreign-struct-encapsulation)
+                     (:constructor %make-ns-point (data))))
+
+(defun make-ns-point (x y)
+  (let* ((data (%new-gcable-ptr ns-point-size)))
+    (setf (pref data :<NSP>oint.x) (float x +cgfloat-zero+)
+          (pref data :<NSP>oint.y) (float y +cgfloat-zero+))
+    (%make-ns-point data)))
+
+(declaim (inline ns-point-x ns-point-y (setf ns-point-x) (setf ns-point-y)))
+
+(defun ns-point-x (point)
+  (pref (ns-point-data point) :<NSP>oint.x))
+
+(defun (setf ns-point-x) (new point)
+  (setf (pref (ns-point-data point) :<NSP>oint.x)
+        (float new +cgfloat-zero+)))
+
+(defun ns-point-y (point)
+  (pref (ns-point-data point) :<NSP>oint.y))
+
+(defun (setf ns-point-y) (new point)
+  (setf (pref (ns-point-data point) :<NSP>oint.y)
+        (float new +cgfloat-zero+)))
+
+(defmethod print-object ((p ns-point) stream)
+  (flet ((maybe-round (x)
+           (multiple-value-bind (q r) (round x)
+             (if (zerop r) q x))))
+    (print-unreadable-object (p stream :type t :identity t)
+      (format stream "~s,~s"
+              (maybe-round (ns-point-x p))
+              (maybe-round (ns-point-y p))))))
+
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<NSP>oint)
+ '%make-ns-point
+ 'ns-point-p)
+
+;;; NSRange
+
+(defconstant ns-range-size (%foreign-type-or-record-size :<NSR>ange :bytes))
+
+(defstruct (ns-range (:include foreign-struct-encapsulation)
+                     (:constructor %make-ns-range (data))))
+
+(defun make-ns-range (location length)
+  (let* ((data (%new-gcable-ptr ns-range-size)))
+    (setf (pref data :<NSR>ange.location) location
+          (pref data :<NSR>ange.length) length)
+    (%make-ns-range data)))
+
+(declaim (inline ns-range-location ns-range-length
+                 (setf ns-range-location)
+                 (setf ns-range-length)))
+
+(defun ns-range-location (range)
+  (pref (ns-range-data range) :<NSR>ange.location))
+
+(defun (setf ns-range-location) (new range)
+  (setf (pref (ns-range-data range) :<NSR>ange.location)
+        new))
+
+(defun ns-range-length (range)
+  (pref (ns-range-data range) :<NSR>ange.length))
+
+(defun (setf ns-range-length) (new range)
+  (setf (pref (ns-range-data range) :<NSR>ange.length)
+        new))
+
+
+(defmethod print-object ((r ns-range) stream)
+  (print-unreadable-object (r stream :type t :identity t)
+    (format stream "~s/~s" (ns-range-location r) (ns-range-length r))))
+
+
+
+(create-foreign-struct-association-for-encapsulation
+ (parse-foreign-type :<NSR>ange)
+ '%make-ns-range
+ 'ns-range-p)
+
+
+(set-dispatch-macro-character #\# #\/ 
+                              (lambda (stream subchar numarg)
+                                (declare (ignorable subchar numarg))
+                                (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t))
+                                       (attrtab (rdtab.ttab *readtable*)))
+                                  (when (peek-char t stream nil nil)
+                                    (loop
+                                      (multiple-value-bind (char attr)
+                                          (%next-char-and-attr stream attrtab)
+                                        (unless (eql attr $cht_cnst)
+                                          (when char (unread-char char stream))
+                                          (return))
+                                        (vector-push-extend char token))))
+                                  (unless *read-suppress*
+                                    (unless (> (length token) 0)
+                                      (signal-reader-error stream "Invalid token after #/."))
+                                    (let* ((symbol (intern token "NS")))
+                                      (get-objc-message-info (symbol-name symbol))
+                                      symbol)))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -366,16 +923,159 @@
   (typep result-type 'foreign-record-type))
 
+(defvar *objc-method-signatures* (make-hash-table :test #'equal))
+
+(defstruct objc-method-signature-info
+  type-signature
+  function
+  super-function)
+
+(defun objc-method-signature-info (sig)
+  (or (gethash sig *objc-method-signatures*)
+      (setf (gethash sig *objc-method-signatures*)
+            (make-objc-method-signature-info :type-signature sig))))
+
+(defun concise-foreign-type (ftype)
+  (if (typep ftype 'foreign-record-type)
+    (let* ((name (foreign-record-type-name ftype)))
+      (if name
+        `(,(foreign-record-type-kind ftype) ,name)
+        (unparse-foreign-type ftype)))
+    (if (objc-id-type-p ftype)
+      :id
+      (if (typep ftype 'foreign-pointer-type)
+        (let* ((to (foreign-pointer-type-to ftype)))
+          (if (null to)
+            '(:* :void)
+            `(:* ,(concise-foreign-type to))))
+        (unparse-foreign-type ftype)))))
+
+
+;;; Not a perfect mechanism.
+(defclass objc-dispatch-function (funcallable-standard-object)
+    ()
+  (:metaclass funcallable-standard-class))
+
+(defmethod print-object ((o objc-dispatch-function) stream)
+  (print-unreadable-object (o stream :type t :identity t)
+    (let* ((name (function-name o)))
+      (when name
+        (format stream "~s" name)))))
+
+(declaim (inline check-receiever))
+
+;;; Return a NULL pointer if RECEIVER is a null pointer.
+;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL.
+(defun check-receiver (receiver)
+  (if (%null-ptr-p receiver)
+    (%null-ptr)
+    (let* ((domain (%macptr-domain receiver))
+           (valid (eql domain *objc-object-domain*)))
+      (declare (fixnum domain))
+      (when (zerop domain)
+        (if (recognize-objc-object receiver)
+          (progn (%set-macptr-domain receiver *objc-object-domain*)
+                 (setq valid t))))
+      (unless valid
+        (report-bad-arg receiver 'objc:objc-object)))))
+
+(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys)
+  (declare (ignore slot-names))
+  (if message-info
+    (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous))
+           (selector (objc-message-info-selector message-info))
+           (first-method (car (objc-message-info-methods message-info))))
+      (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
+                         $lfbits-numreq
+                         (lfun-bits gf)))
+      (flet ((signature-function-for-method (m)
+               (let* ((signature-info (objc-method-info-signature-info m)))
+                 (or (objc-method-signature-info-function signature-info)
+                     (setf (objc-method-signature-info-function signature-info)
+                           (compile-send-function-for-signature
+                                    (objc-method-signature-info-type-signature signature-info)))))))
+                      
+      (if (null ambiguous-methods)
+        ;; Pick an arbitrary method, since all methods have the same
+        ;; signature.
+        (let* ((function (signature-function-for-method first-method)))
+          (set-funcallable-instance-function
+           gf
+           (nfunction
+            send-unambiguous-message
+            (lambda (receiver &rest args)
+               (declare (dynamic-extent args))
+               (or (check-receiver receiver)
+                   (with-ns-exceptions-as-errors 
+                       (apply function receiver selector args)))))))
+        (let* ((protocol-pairs (mapcar #'(lambda (pm)
+                                           (cons (lookup-objc-protocol
+                                                  (objc-method-info-class-name pm))
+                                                 (signature-function-for-method
+                                                  pm)))
+                                       (objc-message-info-protocol-methods message-info)))
+               (method-pairs (mapcar #'(lambda (group)
+                                         (cons (mapcar #'(lambda (m)
+                                                           (get-objc-method-info-class m))
+                                                       group)
+                                               (signature-function-for-method (car group))))
+                                     (objc-message-info-ambiguous-methods message-info)))
+               (default-function (if method-pairs
+                                   (prog1 (cdar (last method-pairs))
+                                     (setq method-pairs (nbutlast method-pairs)))
+                                   (prog1 (cdr (last protocol-pairs))
+                                     (setq protocol-pairs (nbutlast protocol-pairs))))))
+          (set-funcallable-instance-function
+           gf
+           (nfunction
+            send-unambiguous-message
+            (lambda (receiver &rest args)
+               (declare (dynamic-extent args))
+               (or (check-receiver receiver)
+                   (let* ((function
+                           (or (dolist (pair protocol-pairs)
+                                 (when (conforms-to-protocol receiver (car pair))
+                                   (return (cdr pair))))
+                               (block m
+                                 (dolist (pair method-pairs default-function)
+                                   (dolist (class (car pair))
+                                     (when (typep receiver class)
+                                       (return-from m (cdr pair)))))))))
+                     (with-ns-exceptions-as-errors
+                         (apply function receiver selector args)))))))))))
+    (with-slots (name) gf
+      (set-funcallable-instance-function
+       gf
+       #'(lambda (&rest args)
+           (error "Unknown ObjC message ~a called with arguments ~s"
+                  (symbol-name name) args))))))
+                                             
+
+
 (defun postprocess-objc-message-info (message-info)
+  (let* ((objc-name (objc-message-info-message-name message-info))
+         (lisp-name (or (objc-message-info-lisp-name message-info)
+                            (setf (objc-message-info-lisp-name message-info)
+                                  (compute-objc-to-lisp-function-name  objc-name))))
+         (gf (or (fboundp lisp-name)
+                 (setf (fdefinition lisp-name)
+                       (make-instance 'objc-dispatch-function :name lisp-name)))))
+
+    (unless (objc-message-info-selector message-info)
+      (setf (objc-message-info-selector message-info)
+            (ensure-objc-selector (objc-message-info-message-name message-info))))
+    
   (flet ((reduce-to-ffi-type (ftype)
-           (if (objc-id-type-p ftype)
-             :id
-             (unparse-foreign-type ftype))))
+           (concise-foreign-type ftype)))
     (flet ((ensure-method-signature (m)
              (or (objc-method-info-signature m)
                  (setf (objc-method-info-signature m)
-                       (cons (reduce-to-ffi-type
-                              (objc-method-info-result-type m))
-                             (mapcar #'reduce-to-ffi-type
-                                     (objc-method-info-arglist m)))))))
+                       (let* ((sig 
+                               (cons (reduce-to-ffi-type
+                                      (objc-method-info-result-type m))
+                                     (mapcar #'reduce-to-ffi-type
+                                             (objc-method-info-arglist m)))))
+                         (setf (objc-method-info-signature-info m)
+                               (objc-method-signature-info sig))
+                         sig)))))
       (let* ((methods (objc-message-info-methods message-info))
              (signatures ())
@@ -436,16 +1136,19 @@
                     (setf (getf (objc-message-info-flags message-info)
                                 :accepts-varargs) t)
-                    (decf (objc-message-info-req-args message-info))))))))))))
+                    (decf (objc-message-info-req-args message-info)))))))))
+      (reinitialize-instance gf :message-info message-info)))))
           
 ;;; -may- need to invalidate cached info whenever new interface files
 ;;; are made accessible.  Probably the right thing to do is to insist
 ;;; that (known) message signatures be updated in that case.
-(defun get-objc-message-info (message-name)
+(defun get-objc-message-info (message-name &optional (use-database t))
+  (setq message-name (string message-name))
   (or (gethash message-name *objc-message-info*)
-      (let* ((info (lookup-objc-message-info message-name)))
-        (when info
-          (setf (gethash message-name *objc-message-info*) info)
-          (postprocess-objc-message-info info)
-          info))))
+      (and use-database
+           (let* ((info (lookup-objc-message-info message-name)))
+             (when info
+               (setf (gethash message-name *objc-message-info*) info)
+               (postprocess-objc-message-info info)
+               info)))))
 
 (defun need-objc-message-info (message-name)
@@ -689,14 +1392,17 @@
                       (objc-method-info-class-name m)))
              (class-name mclass))))
+
     (collect ((clauses))
-      (let* ((protocol (gensym)))
+      (let* ((protocol (gensym))
+             (protocol-address (gensym)))
         (dolist (method protocol-methods)
           (let* ((protocol-name (objc-method-info-class-name method)))
-            (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)))
-                         (and ,protocol
-                              (not (zerop (objc-message-send ,receiver
-                                                             "conformsToProtocol:"
-                                                             :address ,protocol
-                                                             :<BOOL>)))))
+            (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name))
+                              (,protocol-address (and ,protocol (protocol-address ,protocol))))
+                         (and ,protocol-address
+                              (objc-message-send ,receiver
+                                                 "conformsToProtocol:"
+                                                 :address ,protocol-address
+                                                 :<BOOL>)))
                        ,(build-internal-call-from-method-info
                          method args vargs receiver msg s super))))))
@@ -704,7 +1410,7 @@
            ((null (cdr methods))
             (when ambiguous-methods
-            (clauses `(t
-                       ,(build-internal-call-from-method-info
-                         (caar methods) args vargs receiver msg s super)))))
+              (clauses `(t
+                         ,(build-internal-call-from-method-info
+                           (caar methods) args vargs receiver msg s super)))))
         (clauses `(,(if (cdar methods)
                         `(or ,@(mapcar #'(lambda (m)