Index: /trunk/ccl/examples/objc-clos.lisp
===================================================================
--- /trunk/ccl/examples/objc-clos.lisp	(revision 532)
+++ /trunk/ccl/examples/objc-clos.lisp	(revision 533)
@@ -16,9 +16,5 @@
 ;;;
 ;;; TO DO
-;;;  - Issues with OFFSET/LOCATION in foreign direct and effective slot definitions
-;;;  - MAP-OBJC-CLASS needs to INITIALIZE-INSTANCE and FINALIZE-INHERITANCE
-;;;    for predefined classes
 ;;;  - Need to fully handle init keywords and ObjC init messages
-;;;  - Need to add getter and setter functions for more foreign slot types
 ;;;  - Canonicalization and retention for ObjC objects
 ;;;  - Support redef of CLOS parts, but not changes in ObjC parts
@@ -495,5 +491,4 @@
 ;;; 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)
@@ -715,6 +710,6 @@
 						       class
 						       initargs))
-	    (apply #'%send ; For now; Use SEND macro eventually
-		   (%send class 'alloc) (lisp-to-objc-init ks) vs))))
+	    ; The second %SEND below should be SEND eventually
+	    (apply #'%send (%send class 'alloc) (lisp-to-objc-init ks) vs))))
     (unless (%null-ptr-p instance)
       (let* ((len (length (%wrapper-instance-slots (class-own-wrapper class))))
@@ -809,19 +804,8 @@
 ;;;;              Class Definition and Finalization Protocols               ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-(defclass demo-view (ns:ns-view) 
-  ((x :foreign t)
-   y
-   (r :foreign t :type :<NSR>ect))
-  (:metaclass ns:+ns-object))
-|#
 
 ;;; 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)
@@ -854,11 +838,5 @@
   t)
 
-(defmethod finalize-inheritance ((class objc:objc-class))
-  ;; *** compute class precedence list
-  ;; *** create effective slot definition objects
-  )
-
 (defmethod make-instances-obsolete ((class objc:objc-class))
-  ;; What should we do here?
   class)
 
@@ -875,2 +853,113 @@
   (declare (ignore initargs))
   (find-class 'standard-reader-method))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                 Generic Function and Method  Protocols                 ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; The classes of ObjC generic functions and methods
+
+(defclass objc-generic-function (standard-generic-function) 
+  ()
+  (:metaclass funcallable-standard-class))
+
+(defclass objc-method (standard-method) ())
+
+
+;;; Return the generic function name and lambda list corresponding to
+;;; a given ObjC MSG
+;;; NOTE: Gary wants to handle "init..." messages specially
+
+(defun gfify (msg)
+  (let ((mcomps (split-if-char #\: msg :elide)))
+    (values
+     (compute-lisp-name (first mcomps) (find-package "NS"))
+     (case (count #\: msg)
+       (0 '(self))
+       (1 '(self arg))
+       (t `(self arg &key ,@(mapcar #'compute-lisp-name (rest mcomps))))))))
+
+
+;;; Ensure that the generic function corresponding to MSG exists
+
+(defun ensure-objc-generic-function (msg)
+  (multiple-value-bind (gf-name lambda-list) (gfify msg)	    
+    (when (and (fboundp gf-name) (generic-function-p (symbol-function gf-name)))
+      (setq lambda-list 
+	    (generalize-lambda-list
+	     (generic-function-lambda-list (symbol-function gf-name))
+	     lambda-list)))
+    (ensure-generic-function
+     gf-name
+     :lambda-list lambda-list
+     :generic-function-class (find-class 'objc-generic-function)
+     :method-class (find-class 'objc-method))))
+
+
+;;; Generalize a lambda list of an existing objc generic function to be
+;;; consistent with a new lambda list
+
+(defun generalize-lambda-list (oldll newll)
+  (if (equal oldll newll) 
+      oldll
+    (let (req opt keys)
+      (multiple-value-bind (reqold optold keysold) 
+			   (parse-objc-gf-lambda-list oldll)
+        (multiple-value-bind (reqnew ignore keysnew) (parse-objc-gf-lambda-list newll)
+	  (declare (ignore ignore))
+	  (setq opt optold)
+	  (if (/= (length reqold) (length reqnew))
+	      (setq req '(self) opt '(arg))
+	    (setq req reqold))
+	  (setq keys (union keysold keysnew))
+	  `(,@req ,@(when opt (cons '&optional opt)) ,@(when keys (cons '&key keys))))))))
+
+(defun parse-objc-gf-lambda-list (ll)
+  (let ((optpos (position '&optional ll :test #'eq))
+	(keypos (position '&key ll :test #'eq)))
+    (values
+     (subseq ll 0 (or optpos keypos))
+     (if optpos (subseq ll (1+ optpos) keypos))
+     (if keypos (subseq ll (1+ keypos))))))
+
+
+;;; Ensure that the method corresponding to CLASS's method for MSG exists
+
+(defun ensure-objc-method (msg class)
+  (multiple-value-bind (gf-name lambda-list) (gfify msg)
+    (let* ((keypos (position '&key lambda-list :test #'eq))
+	   (required-args (subseq lambda-list 0 keypos))
+	   (keyword-args 
+	    (if keypos (subseq lambda-list (1+ keypos)) nil)))
+      (ensure-objc-generic-function msg)
+      (ensure-method 
+       gf-name 
+       (cons (class-name class)
+	     (make-list (1- (length required-args)) :initial-element t))
+       :function
+       (compile nil
+	 `(lambda ,lambda-list 
+	    ,(case (length lambda-list)
+	       (1 `(send self ,msg))
+	       (2 `(send self ,msg arg))
+	       (t `(send self ,msg arg ,@(append keyword-args '(&allow-other-keys)))))))
+       :qualifiers nil
+       :lambda-list lambda-list))))
+
+
+;;; Someday, this might even work...
+
+(defun define-all-objc-gfs ()
+  (declare (special *type-signature-table*))
+  (maphash #'(lambda (msg ignore) 
+	       (declare (ignore ignore))
+	       (ensure-objc-generic-function msg))
+	   *type-signature-table*))
+
+
+;;; ISSUES
+;;;  - Generic function conflicts
+;;;  - Currently invokes compiler
+;;;  - How to handle messages requiring STRETs?
+;;;  - How to handle variable arity messages?