Index: /trunk/ccl/examples/bridge.lisp
===================================================================
--- /trunk/ccl/examples/bridge.lisp	(revision 5864)
+++ /trunk/ccl/examples/bridge.lisp	(revision 5865)
@@ -359,6 +359,7 @@
 
 (defun result-type-requires-structure-return (result-type)
-  (and (typep result-type 'foreign-record-type)
-       (> (ensure-foreign-type-bits result-type) 32)))
+  ;; Use objc-msg-send-stret for all methods that return
+  ;; record types.
+  (typep result-type 'foreign-record-type))
 
 (defun postprocess-objc-message-info (message-info)
@@ -455,5 +456,7 @@
                (lookup-objc-message-info message-name info)
                (postprocess-objc-message-info info))
-           *objc-message-info*))
+           *objc-message-info*)
+  ;; Update info about init messages.
+  (register-objc-init-messages))
 
 
@@ -496,7 +499,4 @@
 
 
-
-
-
 ;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID
 
@@ -508,85 +508,6 @@
 
 
-;;; Convert a Lisp object X to a desired foreign type FTYPE 
-;;; The following conversions are currently done:
-;;;   - T/NIL => #$YES/#$NO
-;;;   - NIL => (%null-ptr)
-;;;   - Lisp string => NSString
-;;;   - Lisp numbers  => SINGLE-FLOAT when possible
-
-(defmacro coerce-to-bool (x)
-  (let ((x-temp (gensym)))
-    `(let ((,x-temp ,x))
-       (if (or (eq ,x-temp 0) (null ,x-temp)) #$NO #$YES))))
-
-(defmacro coerce-to-address (x)
-  (let ((x-temp (gensym)))
-    `(let ((,x-temp ,x))
-       (cond ((null ,x-temp) (%null-ptr))
-	     ((stringp ,x-temp) (%make-nsstring ,x-temp))
-	     (t ,x-temp)))))
-
-(defmacro coerce-to-foreign-type (x ftype)
-   (cond ((and (constantp x) (constantp ftype))
-          (case ftype
-            (:id (if (null x) `(%null-ptr) (coerce-to-address x)))
-            (:<BOOL> (coerce-to-bool (eval x)))
-            (t x)))
-         ((constantp ftype)
-          (case ftype
-            (:id `(coerce-to-address ,x))
-            (:<BOOL> `(coerce-to-bool ,x))
-            (t x)))
-         (t `(case ,(if (atom ftype) ftype)
-               (:id (coerce-to-address ,x))
-               (:<BOOL> (coerce-to-bool ,x))
-               (t ,x)))))
-
-;;; Convert a foreign object X to T or NIL 
-
-(defun coerce-from-bool (x)
-  (cond
-   ((eq x #$NO) nil)
-   ((eq x #$YES) t)
-   (t (error "Cannot coerce ~S to T or NIL" x))))
-
-
-;;; Convert a set of ARGS with given foreign types to an argspec suitable 
-;;; for %FF-CALL 
-
-(defun convert-to-argspecs (argtypes result-ftype args evalargs)
-  (setq argtypes (mapcar #'fudge-objc-type argtypes))
-  (setq result-ftype (fudge-objc-type result-ftype))
-  (flet ((foo (ftype &optional for-result)
-	   (let* ((translated
-		   (if (member ftype
-			       '(:unsigned-doubleword :signed-doubleword) 
-			       :test #'eq)
-		       ftype
-		     (if for-result
-			 (translate-foreign-result-type ftype)
-		       (translate-foreign-arg-type ftype)))))
-	     (if (and (consp translated) (eq (first translated) :record))
-	       #+apple-objc
-	       (ceiling (second translated) target::nbits-in-word)
-	       #+gnu-objc `(:* ,ftype)
-	       translated))))
-    (nconc
-     (loop
-       for a in args
-       for ftype in argtypes
-       do (ensure-foreign-type-bits (parse-foreign-type ftype))
-       append (list (foo ftype) 
-                    (if evalargs
-                      (coerce-to-foreign-type a
-					      #+apple-objc ftype
-					      #+gnu-objc (foo ftype))
-                      `(coerce-to-foreign-type ,a #+apple-objc ,ftype #+gnu-objc ,(foo ftype)))))
-     (list (foo result-ftype t)))))
- 
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;                       Boolean Return Hackery                           ;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -827,8 +748,5 @@
                (arg (car args)))
           (specs reptype)
-          (case reptype
-            (:<BOOL> (specs `(coerce-to-bool ,arg)))
-            (:id (specs `(coerce-to-address ,arg)))
-            (t (specs arg)))))
+          (specs arg)))
       ;;(break "~& arglist = ~s" arglist)
       (if (result-type-requires-structure-return
@@ -847,7 +765,5 @@
                          `(objc-message-send-super ,super ,msg ,@arglist ,result-spec)
                          `(objc-message-send ,o ,msg ,@arglist ,result-spec))))
-            (if (eq result-spec :<BOOL>)
-              `(coerce-from-bool ,form)
-              form)))))))
+            form))))))
   
 (defun build-call-from-method-info (method-info args vargs o  msg  svarforms sinitforms s super)
@@ -864,106 +780,4 @@
         super))))
 
-
-
-;;; The %SEND and %SEND/STRET functions for sending general messages 
-
-(defmacro make-general-send (o msg args &optional s super sclassname)
-  (declare (ignorable sclassname))
-  `(let ((vargs nil))
-     (with-ns-exceptions-as-errors
-      ;; Ensure that MSG is a string
-      (multiple-value-setq (msg args vargs) (%parse-message (cons ,msg ,args)))
-      (check-type ,msg string)          ; What else could it be ?
-      (let* ((message-info (get-objc-message-info ,msg))
-             (message-accepts-varargs
-              (getf (objc-message-info-flags message-info)
-                                    :accepts-varargs)))
-        ;; If a vararg exists, make sure that the message can accept it
-        (when (and vargs (not message-accepts-varargs))
-          (error "Message ~S cannot accept a variable number of arguments" msg))
-        ;; Lookup method signature.  We can do a runtime type dispatch
-        ;; on the receiver (if there's any ambiguity) even if we're doing
-        ;; some flavor of SEND-SUPER, since the next method must have
-        ;; the same type signature as the receiver.
-        (let* ((method-info (%lookup-objc-method-info message-info ,o))
-               (sel (get-selector ,msg)))
-          ;; Check arg count
-          (unless (= (length ,args) (objc-message-info-req-args message-info))
-            (error "Message ~S requires ~a ~d args, but ~d were provided."
-                   (if vargs "at least" "exactly")
-                   (objc-message-info-req-args message-info)
-                   (length args)))
-          ;; Get method type signature
-          (let* ((mtsig (objc-method-info-signature method-info))
-                 (argtypes (rest mtsig))
-                 (result-type (first mtsig))
-                 (argspecs1 (convert-to-argspecs argtypes result-type ,args t))
-                 (argspecs (append (butlast argspecs1) vargs (last argspecs1)))
-                 (result-spec (first (last argspecs))))
-            ;; Yes, we're doing all of this at runtime.  Don't even get
-            ;; me started on %FF-CALL.
-            ;; Call method
-            (if (requires-stret-p result-spec)
-	      ,(if (null s)
-		   ;; STRET required but not provided
-		   `(error "The message ~S must be sent using SEND/STRET" ,msg)
-                   ;; STRET required and provided
-                   (if (null super)
-		     ;; Regular stret send, invoke objc_msgSend_stret 
-		     `(progn
-                       (apply #'%ff-call
-                        (%reference-external-entry-point 
-                         (load-time-value 
-                          (external "_objc_msgSend_stret")))
-                        :address ,s
-                        :address ,o
-                        :address sel
-                        (progn (setf (car (last argspecs)) :void) argspecs))
-                       ,s)
-                     ;; Stret send to super, invoke objc_msgSendSuper_stret
-                     `(progn 
-                       (apply #'%ff-call
-                        (%reference-external-entry-point 
-                         (load-time-value 
-                          (external "_objc_msgSendSuper_stret")))
-                        :address ,s
-                        :address ,super
-                        :address sel
-                        (progn (setf (car (last argspecs)) :void) argspecs)))))
-              ,(if (null s)
-                   ;; STRET not required and not provided
-                   (if (null super)
-		     ;; Regular send, invoke objc_msgSend
-		     `(let ((r (apply #'%ff-call
-				      (%reference-external-entry-point 
-				       (load-time-value 
-					(external "_objc_msgSend")))
-				      :address ,o
-				      :address sel
-				      argspecs)))
-                       (if (eq result-type :<BOOL>)
-                         (coerce-from-bool r)
-                         r))
-		  ;;; Send to super, invoke objc_msgSendSuper
-                     `(let ((r (apply #'%ff-call
-                                      (%reference-external-entry-point 
-                                       (load-time-value 
-                                        (external "_objc_msgSendSuper")))
-                                      :address ,super
-                                      :address sel
-                                      argspecs)))
-                       (if (eq result-type :<BOOL>)
-                         (coerce-from-bool r)
-                         r)))
-                   ;; STRET not required but provided
-                   `(error "The message ~S must be sent using SEND" msg)))))))))
-
-(defun %send (o msg &rest args)
-  (declare (optimize (speed 3)) (dynamic-extent args))
-  (make-general-send o msg args))
-  
-(defun %send/stret (s o msg &rest args)
-  (declare (optimize (speed 3)) (dynamic-extent args))
-  (make-general-send o msg args s))
  
 
@@ -980,10 +794,7 @@
     (when (not (stringp cname))
       (setf cname (lisp-to-objc-classname cname)))
-    (apply #'%send 
-           (send (find-objc-class cname) 'alloc)
-           (lisp-to-objc-init ks)
-           vs)))
-
-
+    (send-objc-init-message (send (find-objc-class cname) 'alloc)
+                            ks
+                            vs)))
 
 ;;; Provide the BRIDGE module
Index: /trunk/ccl/examples/objc-clos.lisp
===================================================================
--- /trunk/ccl/examples/objc-clos.lisp	(revision 5864)
+++ /trunk/ccl/examples/objc-clos.lisp	(revision 5865)
@@ -747,6 +747,5 @@
 						       class
 						       initargs))
-	    ; The second %SEND below should be SEND eventually
-	    (apply #'%send (%send class 'alloc) (lisp-to-objc-init ks) vs))))
+	    (send-objc-init-message (allocate-objc-object class) ks vs))))
     (unless (%null-ptr-p instance)
       (let* ((raw-ptr (raw-macptr-for-instance instance)) 
Index: /trunk/ccl/examples/objc-runtime.lisp
===================================================================
--- /trunk/ccl/examples/objc-runtime.lisp	(revision 5864)
+++ /trunk/ccl/examples/objc-runtime.lisp	(revision 5865)
@@ -954,4 +954,61 @@
   `(load-objc-selector ,(objc-selector-name s)))
 
+
+;;; Convert a Lisp object X to a desired foreign type FTYPE 
+;;; The following conversions are currently done:
+;;;   - T/NIL => #$YES/#$NO
+;;;   - NIL => (%null-ptr)
+;;;   - Lisp string => NSString
+;;;   - Lisp numbers  => SINGLE-FLOAT when possible
+
+(defmacro coerce-to-bool (x)
+  (let ((x-temp (gensym)))
+    `(let ((,x-temp ,x))
+       (if (or (eq ,x-temp 0) (null ,x-temp)) #.#$NO #.#$YES))))
+
+(defmacro coerce-to-address (x)
+  (let ((x-temp (gensym)))
+    `(let ((,x-temp ,x))
+       (cond ((null ,x-temp) (%null-ptr))
+	     ((stringp ,x-temp) (%make-nsstring ,x-temp))
+	     (t ,x-temp)))))
+
+(defmacro coerce-to-foreign-type (x ftype)
+   (cond ((and (constantp x) (constantp ftype))
+          (case ftype
+            (:id (if (null x) `(%null-ptr) (coerce-to-address x)))
+            (:<BOOL> (coerce-to-bool (eval x)))
+            (t x)))
+         ((constantp ftype)
+          (case ftype
+            (:id `(coerce-to-address ,x))
+            (:<BOOL> `(coerce-to-bool ,x))
+            (t x)))
+         (t `(case ,(if (atom ftype) ftype)
+               (:id (coerce-to-address ,x))
+               (:<BOOL> (coerce-to-bool ,x))
+               (t ,x)))))
+
+(defun objc-arg-coerce (typespec arg)
+  (coerce-to-foreign-type arg typespec))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                       Boolean Return Hackery                           ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Convert a foreign object X to T or NIL 
+
+(defun coerce-from-bool (x)
+  (cond
+   ((eq x #$NO) nil)
+   ((eq x #$YES) t)
+   (t (error "Cannot coerce ~S to T or NIL" x))))
+
+(defun objc-result-coerce (type result)
+  (cond ((eq type :<BOOL>)
+         `(coerce-from-bool ,result))
+        (t result)))
+
 ;;; Add a faster way to get the message from a SEL by taking advantage of the
 ;;; fact that a selector is really just a canonicalized, interned C string
@@ -977,8 +1034,9 @@
     (setq argspecs (append argspecs '(:id))))
   #+apple-objc
-  `(external-call "_objc_msgSend"
-    :id ,receiver
-    :<SEL> (@selector ,selector-name)
-    ,@argspecs)
+  (funcall (ftd-ff-call-expand-function *target-ftd*)
+           `(external-call "_objc_msgSend")
+           `(:id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
+           :arg-coerce 'objc-arg-coerce
+           :result-coerce 'objc-result-coerce)  
   #+gnu-objc
     (let* ((r (gensym))
@@ -991,24 +1049,45 @@
 					:<SEL> ,s
 					:<IMP>)))
-      (ff-call ,imp :id ,r :<SEL> ,s ,@argspecs))))
-
-;;; A method that returns a structure (whose size is > 4 bytes on
-;;; darwin, in all cases on linuxppc) does so by copying the structure
-;;; into a pointer passed as its first argument; that means that we
-;;; have to invoke the method via #_objc_msgSend_stret in the #+apple-objc
-;;; case.
+      (funcall (ftd-ff-call-expand-function *target-ftd*)
+       `(%ff-call ,imp)
+       `(:id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
+       :arg-coerce 'objc-arg-coerce
+       :result-coerce 'objc-result-coerce))))
+
+;;; A method that returns a structure does so by platform-dependent
+;;; means.  One of those means (which is fairly common) is to pass a
+;;; pointer to an instance of a structure type as a first argument to
+;;; the method implementation function (thereby making SELF the second
+;;; argument, etc.), but whether or not it's actually done that way
+;;; depends on the platform and on the structure type.  The special
+;;; variable CCL::*TARGET-FTD* holds a structure (of type
+;;; CCL::FOREIGN-TYPE-DATA) which describes some static attributes of
+;;; the foreign type system on the target platform and contains some
+;;; functions which can determine dynamic ABI attributes.  One such
+;;; function can be used to determine whether or not the "invisible
+;;; first arg" convention is used to return structures of a given
+;;; foreign type; another function in *TARGET-FTD* can be used to
+;;; construct a foreign function call form that handles
+;;; structure-return and structure-types-as-arguments details.  In the
+;;; Apple ObjC runtime, #_objc_msgSend_stret must be used if the
+;;; invisible-first-argument convention is used to return a structure
+;;; and must NOT be used otherwise. (The Darwin ppc64 and all
+;;; supported x86-64 ABIs often use more complicated structure return
+;;; conventions than ppc32 Darwin or ppc Linux.)  We should use
+;;; OBJC-MESSAGE-SEND-STRET to send any message that returns a
+;;; structure or union, regardless of how that structure return is
+;;; actually implemented.
 
 (defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs)
-  (if (evenp (length argspecs))
-    (setq argspecs (append argspecs '(:void)))
-    (unless (member (car (last argspecs)) '(:void nil))
-      (error "Invalid result spec for structure return: ~s"
-	     (car (last argspecs)))))
-  #+apple-objc
-  `(external-call "_objc_msgSend_stret"
-    :address ,structptr
-    :id ,receiver
-    :<SEL> (@selector ,selector-name)
-    ,@argspecs)
+    #+apple-objc
+    (let* ((return-typespec (car (last argspecs)))
+           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
+                         "_objc_msgSend_stret"
+                         "_objc-msgSend")))
+      (funcall (ftd-ff-call-expand-function *target-ftd*)
+               `(%ff-call (external ,entry-name))
+               `(,structptr :id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
+               :arg-coerce 'objc-arg-coerce
+               :result-coerce 'objc-result-coerce))
     #+gnu-objc
     (let* ((r (gensym))
@@ -1021,5 +1100,9 @@
 					 :<SEL> ,s
 					 :<IMP>)))
-      (ff-call ,imp :address ,structptr :id ,r :<SEL> ,s ,@argspecs))))
+      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
+               `(%ff-call ,imp)
+              `(,structptr :id , :<SEL> ,s ,@argspecs)
+               :arg-coerce 'objc-arg-coerce
+               :result-coerce 'objc-result-coerce))))
 
 ;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument
@@ -1031,8 +1114,9 @@
     (setq argspecs (append argspecs '(:id))))
   #+apple-objc
-  `(external-call "_objc_msgSendSuper"
-    :address ,super
-    :<SEL> (@selector ,selector-name)
-    ,@argspecs)
+  (funcall (ftd-ff-call-expand-function *target-ftd*)
+           `(%ff-call (external "_objc_msgSendSuper"))
+           `(:address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
+           :arg-coerce 'objc-arg-coerce
+           :result-coerce 'objc-result-coerce)
   #+gnu-objc
   (let* ((sup (gensym))
@@ -1045,23 +1129,23 @@
 					 :<SEL> ,sel
 					 :<IMP>)))
-      (ff-call ,imp
-       :id (pref ,sup :<S>uper.self)
-       :<SEL> ,sel
-       ,@argspecs))))
-
-;;; Send to superclass method, returning a structure.
+  (funcall (ftd-ff-call-expand-function *target-ftd*)
+   `(%ff-call ,imp)
+   `(:id (pref ,sup :<S>uper.self)
+     :<SEL> ,sel
+     ,@argspecs)))))
+
+;;; Send to superclass method, returning a structure. See above.
 (defmacro objc-message-send-super-stret
     (structptr super selector-name &rest argspecs)
-  (if (evenp (length argspecs))
-    (setq argspecs (append argspecs '(:void)))
-    (unless (member (car (last argspecs)) '(:void nil))
-      (error "Invalid result spec for structure return: ~s"
-	     (car (last argspecs)))))
   #+apple-objc
-  `(external-call "_objc_msgSendSuper_stret"
-    :address ,structptr
-    :address ,super
-    :<SEL> (@selector ,selector-name)
-    ,@argspecs)
+    (let* ((return-typespec (car (last argspecs)))
+           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
+                         "_objc_msgSendSuper_stret"
+                         "_objc-msgSendSuper")))
+      (funcall (ftd-ff-call-expand-function *target-ftd*)
+               `(%ff-call (external ,entry-name))
+               `(,structptr :address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
+               :arg-coerce 'objc-arg-coerce
+               :result-coerce 'objc-result-coerce))
   #+gnu-objc
   (let* ((sup (gensym))
@@ -1074,6 +1158,7 @@
 					 :<SEL> ,sel
 					 :<IMP>)))
-      (ff-call ,imp
-       :address ,structptr
+      (funcall (ftd-ff-call-expand-function *target-ftd*)
+       `(%ff-call ,imp)
+       ,structptr
        :id (pref ,sup :<S>uper.self)
        :<SEL> ,sel
@@ -1430,4 +1515,163 @@
      "initWithCString:" :address s)))
 
+
+(let* ((objc-init-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
+  (defun %objc-init-message-arg (n)
+    (let* ((len (length objc-init-message-args)))
+      (do* ((i len (1+ i)))
+           ((> i n) (aref objc-init-message-args n))
+        (vector-push-extend (intern (format nil "ARG~d" i)) objc-init-message-args)))))
+
+(defun objc-init-message-arglist (n)
+  (collect ((args))
+    (dotimes (i n (args)) (args (%objc-init-message-arg i)))))
+
+
+(defun %make-objc-init-function-for-signature (signature)
+  ;; No structure returns or send-supers involved.
+  (let* ((types (cdr signature))
+         (args (objc-init-message-arglist (length types))))
+    (collect ((call))
+      (dolist (arg args)
+        (let* ((type (pop types)))
+          (call type)
+          (case type
+            (:<BOOL> (call `(coerce-to-bool ,arg)))
+            (:id (call `(coerce-to-address ,arg)))
+            (otherwise (call arg)))))
+      ;; all "init" messages return :id
+      (call :id)
+      (compile nil
+               `(lambda (self selector ,@args)
+                 #+apple-objc
+                 (external-call "_objc_msgSend"
+                  :id self
+                  :<SEL> (%get-selector selector)
+                  ,@(call))
+                 #+gnu-objc
+                 (let* ((s (%get-selector selector))
+                        (imp (external-call "objc_msg_lookup"
+                                            :id self
+                                            :<SEL> s
+                                            :<IMP>)))
+                   (ff-call imp :id self :<SEL> s ,@(call))))))))
+
+(defstruct objc-init-method-signature-info
+  signature
+  function)
+
+(defvar *objc-init-method-signatures* (make-hash-table :test #'equal)
+  "Maps signature lists to OBJC-INIT-METHOD-SIGNATURE-INFO structures.")
+
+(defun get-objc-init-method-signature-info (list)
+  (or (gethash list *objc-init-method-signatures*)
+      (setf (gethash list *objc-init-method-signatures*)
+            (make-objc-init-method-signature-info
+             :signature list
+             :function (%make-objc-init-function-for-signature list)))))
+
+(defstruct objc-init-message-info
+  selector
+  method-signature-alist
+  )
+
+(defvar  *objc-init-messages-for-message-names* (make-hash-table :test #'equal)
+  "Maps from init message names to OBJC-INIT-MESSAGE-INFO structures.")
+
+(defun register-objc-init-message (message-info)
+  (when (dolist (m (objc-message-info-methods message-info))
+          (unless (getf (objc-method-info-flags m) :protocol)
+            (let* ((sig (objc-method-info-signature m)))
+              (unless (eq (car (last sig)) :void)
+                (when (eq :id (car (objc-method-info-signature m)))
+                  (return t))))))
+    (let* ((name (objc-message-info-message-name message-info))
+           (init-info
+            (or (gethash name *objc-init-messages-for-message-names*)
+                (setf (gethash name *objc-init-messages-for-message-names*)
+                      (make-objc-init-message-info
+                       :selector (load-objc-selector name)
+                       :method-signature-alist nil))))
+           (alist (objc-init-message-info-method-signature-alist init-info)))
+      (dolist (m (objc-message-info-methods message-info))
+        (let* ((sig (objc-method-info-signature m)))
+          (when (and (eq :id (car sig))
+                     (not (getf (objc-method-info-flags m) :protocol)))
+            ;; Looks like a real init method.
+            (let* ((class (canonicalize-registered-class (lookup-objc-class (objc-method-info-class-name m))))
+                   (siginfo (get-objc-init-method-signature-info sig))
+                   (pair (assoc siginfo alist :test #'eq)))
+              (if (null pair)
+                (push (cons siginfo (list class)) alist)
+                (pushnew class (cdr pair) :test #'eq))))))
+      (setf (objc-init-message-info-method-signature-alist init-info) alist)
+      init-info)))
+
+(defun send-init-message-with-info (instance init-info args)
+  (let* ((selector (objc-init-message-info-selector init-info))
+         (alist (objc-init-message-info-method-signature-alist init-info))
+         (pair (do* ((alist alist (cdr alist)))
+                    ((null (cdr alist))
+                     (car alist)
+                     (let* ((pair (car alist)))
+                       (dolist (class (cdr pair))
+                         (when (typep instance class)
+                           (return pair))))))))
+    (with-ns-exceptions-as-errors
+        (apply (objc-init-method-signature-info-function (car pair))
+               instance
+               selector
+               args))))
+                                                       
+
+;;; Register init-message-info for all known init messages.  (A
+;;; message is an "init message" if it starts with the string "init",
+;;; accepts a fixed number of arguments, and has at least one declared
+;;; method that returns :ID and is not a protocol method.
+(defun register-objc-init-messages ()
+  (do-interface-dirs (d)
+    (dolist (init (cdb-enumerate-keys (db-objc-methods d)
+                                      #'(lambda (string)
+                                          (string= string "init" :end1 (min (length string) 4)))))
+      (register-objc-init-message (get-objc-message-info init)))))
+
+    
+(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal)
+  "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures")
+
+(defun send-objc-init-message-with-info (instance init-info args)
+  (let* ((selector (objc-init-message-info-selector init-info))
+         (alist (objc-init-message-info-method-signature-alist init-info))
+         (pair (do* ((alist alist (cdr alist)))
+                    ((null (cdr alist))
+                     (car alist)
+                     (let* ((pair (car alist)))
+                       (dolist (class (cdr pair))
+                         (when (typep instance class)
+                           (return pair))))))))
+    (with-ns-exceptions-as-errors
+        (apply (objc-init-method-signature-info-function (car pair))
+               instance
+               selector
+               args))))
+
+
+(defun send-objc-init-message (instance init-keywords args)
+  (let* ((info (gethash init-keywords *objc-init-messages-for-init-keywords*)))
+    (unless info
+      (let* ((name (lisp-to-objc-init init-keywords))
+             (name-info (gethash name *objc-init-messages-for-message-names*)))
+        (unless name-info
+          (error "Unknown ObjC init message: ~s" name))
+        (setf (gethash init-keywords *objc-init-messages-for-init-keywords*)
+              (setq info name-info))))
+    (send-objc-init-message-with-info instance info args)))    
+                   
+(defun allocate-objc-object (class)
+  (send class 'alloc))
+  
+
+                  
+
 ;;; Return the "canonical" version of P iff it's a known ObjC class
 (defun objc-class-p (p)
@@ -1710,15 +1954,14 @@
 	(t (bad-selector "general failure")))
       ;; If the result type is of the form (:STRUCT <typespec> <name>),
-      ;; make <name> be the first argument (of type :address) and
-      ;; make the resulttype :void
+      ;; make <name> be the first argument.
       (when (and (consp resulttype)
 		 (eq (car resulttype) :struct))
 	(destructuring-bind (typespec name) (cdr resulttype)
-	(if (and (typep name 'symbol)
-		 (typep (parse-foreign-type `(:struct ,typespec))
-			'foreign-record-type))
-          (setq struct-return name
-                resulttype `(:struct ,typespec))
-	  (bad-selector "Bad struct return type"))))
+          (let* ((rtype (%foreign-type-or-record typespec)))
+            (if (and (typep name 'symbol)
+                     (typep rtype 'foreign-record-type))
+              (setq struct-return name
+                    resulttype (unparse-foreign-type rtype))
+              (bad-selector "Bad struct return type")))))
       (values selector
 	      class-name
@@ -1766,6 +2009,5 @@
 	       (params `(:id ,self :<sel> ,_cmd)))
           (when struct-return
-            (setq params `(:address ,struct-return ,@params)
-                  resulttype :void))
+            (push struct-return params))
           (setq params (nconc params argspecs))
 	  `(progn
@@ -1798,10 +2040,5 @@
                            (send-super/stret (s msg &rest args &environment env) 
                              (make-optimized-send nil msg args env s ',super ,class-name)))
-                  (flet ((%send-super (msg &rest args)
-                           (make-general-send nil msg args nil ,super ,class-name))
-                         (%send-super/stret (s msg &rest args)
-                           (make-general-send nil msg args s ,super ,class-name))
-                         (super () ,super))
-                    ,@body))))
+                  ,@body)))
 	    (%define-lisp-objc-method
 	     ',impname
Index: /trunk/ccl/examples/objc-support.lisp
===================================================================
--- /trunk/ccl/examples/objc-support.lisp	(revision 5864)
+++ /trunk/ccl/examples/objc-support.lisp	(revision 5865)
@@ -74,4 +74,5 @@
 
 (map-objc-classes)
+(register-objc-init-messages)
 
 #+gnu-objc