Replace all occurrences of OBJC-CLASS with OBJECTIVE-C-CLASS.

darcs-hash:1ba389d5a50343a134892bde78ba62e21842f684

11 files changed, 96 insertions, 47 deletions

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index 3da1ec2..ea77362 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -39,11 +39,6 @@
      (foreign-slot-definition-mixin c2mop:standard-effective-slot-definition)
   ())
 
-(defclass objective-c-class (standard-class)
-  ((class-ptr :initarg :class-ptr
-              :type c-pointer
-              :accessor pointer-to)))
-
 
 (defmethod c2mop:direct-slot-definition-class ((class objective-c-class)
                                          &rest initargs)
@@ -82,6 +77,15 @@
      (cerror "FIXME" '()))))
 
 
+(defmethod c2mop:slot-boundp-using-class ((class objective-c-class)
+                                          instance
+                                          effective-slot-definition)
+  (declare (ignore instance))
+  (etypecase effective-slot-definition
+    (standard-effective-slot-definition (call-next-method))
+    (foreign-effective-slot-definition t)))
+
+
 (defmethod c2mop:compute-slots ((class objective-c-class))
   ;; FIXME: Maybe add lots of foreign slots here whose presence the
   ;; Objective-C runtime tells us.
@@ -93,7 +97,6 @@
   (let ((class (call-next-method)))
     class))
 
-#+(or)
 (defmethod initialize-instance ((class objective-c-class)
                                 &key documentation
                                      name
@@ -101,11 +104,10 @@
                                      direct-superclasses
                                      direct-slots
                                      direct-default-initargs
-                                     class-ptr
+                                     pointer
                                      wrapped-foreign-class)
   (call-next-method))
 
-#+(or)
 (defmethod reinitialize-instance ((class objective-c-class)
                                   &key documentation
                                        name
@@ -113,7 +115,7 @@
                                        direct-superclasses
                                        direct-slots
                                        direct-default-initargs
-                                       class-ptr
+                                       pointer
                                        wrapped-foreign-class)
   (call-next-method))
 
diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
index c4e8393..85b5584 100644
--- a/Lisp/constant-data.lisp
+++ b/Lisp/constant-data.lisp
@@ -74,7 +74,7 @@
 
 (defparameter *objcl-type-map*
   '((id       . id)
-    (class    . objc-class)
+    (class    . objective-c-class)
     (sel      . selector)
     (exc      . exception)
     (chr      . character)
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index bc66bf3..1f33af6 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -89,12 +89,12 @@ a suitable class method instead as you would in Objective-C.
   __invoke__, __invoke-by-name__, __exception__"))
 
 
-(defclass objc-class (c-pointer-wrapper) ()
-  (:documentation ""))
+(defclass objective-c-class (standard-class c-pointer-wrapper)
+  ())
 
 
 (defclass objc-meta-class (c-pointer-wrapper)
-  ((meta-class-for-class :type (or null id objc-class)
+  ((meta-class-for-class :type (or null id objective-c-class)
                          :initarg :meta-class-for-class
                          :reader meta-class-for-class))
   (:documentation ""))
diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index d7156d0..0543ed5 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -68,4 +68,9 @@
            #:next-runtime))
 
 
+(defpackage #:objective-c-classes
+  (:nicknames #:objc-classes)
+  (:use))
+
+
 #-(or cmu sbcl) (declaim (declaration values))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 752dcf4..dd4ec88 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -158,7 +158,7 @@ objects or classes, let alone send messages to them.
 
 
 (declaim (ftype (function ((or string symbol) &optional t)
-                          (or null objc-class))
+                          (or null objective-c-class))
                 find-objc-class))
 (defun find-objc-class (class-name &optional errorp)
   "Retrieve an Objective-C class by name.
@@ -224,16 +224,18 @@ conventional case for namespace identifiers in Objective-C."
                   nil))))
 
 
-(declaim (ftype (function (string) (or null objc-class))
+(declaim (ftype (function (string) (or null objective-c-class))
                 find-objc-class-by-name))
-(defun find-objc-class-by-name (class-name)
-  (let ((class-ptr (%objcl-find-class class-name)))
+(defun find-objc-class-by-name (class-name-string)
+  (let ((class-ptr (%objcl-find-class class-name-string)))
     (if (objc-pointer-null class-ptr)
         nil
-        #-(or t openmcl) (make-pointer-wrapper 'objc-class :pointer class-ptr)
-        #+(and nil openmcl) (change-class (make-pointer-wrapper 'c-pointer-wrapper
-                                             :pointer value)
-                                          'objc-class))))
+        (let ((class-name (objc-class-name->symbol class-name-string)))
+          (or (find-class class-name nil)
+              (c2mop:ensure-class class-name
+                                  :metaclass 'objective-c-class
+                                  :pointer class-ptr
+                                  :wrapped-foreign-class class-name-string))))))
 
 
 (defun find-objc-meta-class (meta-class-name &optional errorp)
@@ -279,7 +281,7 @@ conventional case for namespace identifiers in Objective-C."
     (make-pointer-wrapper 'selector :pointer selector-ptr)))
 
 
-(declaim (ftype (function ((or objc-class id exception)) string)
+(declaim (ftype (function ((or objective-c-class id exception)) string)
                 objc-class-name))
 (defun objc-class-name (class)
   "Find the name of a class.
@@ -315,7 +317,7 @@ If *name* is the name of an existing class:
 ## See Also:
 
   __find-objc-class__"
-  (declare (type (or objc-class id exception) class))
+  (declare (type (or objective-c-class id exception) class))
   (%objcl-class-name (pointer-to class)))
 
 
@@ -359,7 +361,7 @@ If *name* is the name of an existing selector:
   (%objcl-selector-name (pointer-to selector)))
 
 
-(declaim (ftype (function ((or id objc-class exception) selector) t)
+(declaim (ftype (function ((or id objective-c-class exception) selector) t)
                 get-method-implementation))
 (defun get-method-implementation (object selector)
   (declare (type selector selector))
@@ -563,8 +565,8 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
   (%objcl-object-is-meta-class (pointer-to obj)))
 
 (defun object-get-class (obj)
-  (make-pointer-wrapper 'objc-class
-     :pointer (%objcl-object-get-class (pointer-to obj))))
+  (find-objc-class-by-name
+   (%objcl-class-name (%objcl-object-get-class (pointer-to obj)))))
 
 (defun object-get-meta-class (obj)
   (make-pointer-wrapper 'objc-meta-class
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index caadf60..4b6666e 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -19,16 +19,18 @@
 
 
 (defvar *id-objects* (make-weak-value-hash-table))
-(defvar *class-objects* (make-weak-value-hash-table))
 (defvar *exception-objects* (make-weak-value-hash-table))
 (defvar *selector-objects* (make-weak-value-hash-table))
 (defvar *meta-class-objects* (make-weak-value-hash-table))
 
 
 (defun make-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys)
+  (when (and (not (eq 'selector class))
+             (%objcl-object-is-class pointer))
+    (return-from make-pointer-wrapper
+      (find-objc-class-by-name (%objcl-class-name pointer))))
   (let* ((hash-table (ecase class
                        ((id) *id-objects*)
-                       ((objc-class) *class-objects*)
                        ((exception) *exception-objects*)
                        ((selector) *selector-objects*)
                        ((objc-meta-class) *meta-class-objects*)))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index ef5058a..92a9c92 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -219,7 +219,7 @@ easier to use with __apply__.
     (let* ((raw-argc (the argument-number (length args)))
            (real-argc (+ raw-argc 2))
            (return-c-type (case return-type
-                            ((id objc-class exception selector) :pointer)
+                            ((id objective-c-class exception selector) :pointer)
                             (otherwise return-type)))
            (selector (if (typep method-name 'selector)
                          method-name
@@ -305,7 +305,7 @@ easier to use with __apply__.
                   ;; us.
                   (error (make-condition 'exception :pointer error-cell)))
                 (case return-type
-                  ((id objc-class exception selector)
+                  ((id objective-c-class exception selector)
                    (let ((*skip-retaining*
                           (or *skip-retaining*
                               (constructor-name-p (selector-name selector))))
@@ -357,7 +357,8 @@ easier to use with __apply__.
 
 (defun typespec->c-type (typespec)
   (case (car typespec)
-    ((:pointer struct union id objc-class exception array selector) :pointer)
+    ((:pointer struct union id objective-c-class exception array selector)
+     :pointer)
     ((:string) :string)
     (otherwise (car typespec))))
 
@@ -405,7 +406,7 @@ easier to use with __apply__.
                   do (case (car arg-type)
                        ((:pointer)
                         (setf (argref :pointer i) arg))
-                       ((objc-class exception)
+                       ((objective-c-class exception)
                         (setf (argref :pointer i) (pointer-to arg)))
                        ((selector)
                         (setf (argref :pointer i) (pointer-to (selector arg))))
@@ -457,7 +458,7 @@ easier to use with __apply__.
             (unless (cffi:null-pointer-p error-cell)
               (error (make-condition 'exception :pointer error-cell)))
             (case (car return-type)
-              ((id objc-class exception selector)
+              ((id objective-c-class exception selector)
                (let ((*skip-retaining*
                       (or *skip-retaining*
                           (constructor-name-p (selector-name selector)))))
@@ -489,7 +490,7 @@ easier to use with __apply__.
 (defcoercion id ((x id))
   x)
 
-(defcoercion id ((x objc-class))
+(defcoercion id ((x objective-c-class))
   x)
 
 (defcoercion id ((x exception))
@@ -537,7 +538,7 @@ easier to use with __apply__.
 (defcoercion class ((x exception))
   (object-get-class x))
 
-(defcoercion class ((x objc-class))
+(defcoercion class ((x objective-c-class))
   x)
 
 (defcoercion class ((x string))
diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp
index d8f9a5d..64a42c7 100644
--- a/Lisp/name-conversion.lisp
+++ b/Lisp/name-conversion.lisp
@@ -62,3 +62,40 @@
                                         (string (char (first components) 0))
                                         (string-upcase
                                          (subseq (first components) 1))))))
+
+
+(defun objc-class-name->symbol (class-name)
+  (let ((prefix-end (1- (position-if #'lower-case-p class-name))))
+    (cond ((and prefix-end (> prefix-end 0))
+           ;; There are n upper case chars at the head of the name.
+           ;; Take the first (1- n) of them and downcase them.  Then,
+           ;; put a dash right after them and downcase the n'th char as
+           ;; well, such that "NSFoo" becomes "ns-foo".
+           (setq class-name (concatenate 'string
+                                         (string-downcase
+                                          (subseq class-name 0 prefix-end))
+                                         "-"
+                                         (string
+                                          (char-downcase
+                                           (char class-name prefix-end)))
+                                         (subseq class-name (1+ prefix-end)))))
+          ((and prefix-end (zerop prefix-end))
+           ;; There is exactly one upper case char at the head of the
+           ;; name.  just downcase it and move on.
+           (setq class-name (copy-seq class-name))
+           (setf (char class-name 0) (char-downcase (char class-name 0))))))
+  (loop for delim-position = (position-if #'upper-case-p class-name)
+        while delim-position
+        do (setq class-name (concatenate 'string
+                                         (subseq class-name 0 delim-position)
+                                         "-"
+                                         (string
+                                          (char-downcase
+                                           (char class-name delim-position)))
+                                         (subseq class-name (1+ delim-position)))))
+  (let ((*package* (find-package '#:objective-c-classes)))
+    ;; Why do we use READ-FROM-STRING rather than MAKE-SYMBOL?  That is
+    ;; because we want this procedure to work as expected for any value
+    ;; of (READTABLE-CASE *READTABLE*), which means that 'ns-object
+    ;; should always mean the same thing as "NSObject".
+    (read-from-string class-name)))
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 1df4895..e362774 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -21,7 +21,7 @@
   (:export #:run-all-tests)
   (:shadowing-import-from #:objcl
                           #:struct #:union #:pointer #:oneway #:out #:in
-                          #:inout #:const #:parse-typespec #:objc-class
+                          #:inout #:const #:parse-typespec #:objective-c-class
                           #:bit-field #:opaque #:bycopy #:byref
                           #:primitive-invoke))
 (in-package #:mulk.objective-cl.tests)
@@ -89,7 +89,7 @@
    ((ensure-same (primitive-invoke (find-objc-class 'ns-object)
                                    'self 'id)
                  (primitive-invoke (find-objc-class 'ns-object)
-                                   'class 'objc-class)))
+                                   'class 'objective-c-class)))
    ((ensure-different (primitive-invoke (find-objc-class 'ns-object)
                                    'self 'id)
                       (primitive-invoke (find-objc-class 'ns-number)
@@ -193,7 +193,7 @@
                    (:unsigned-long-long ())
                    (:float ())
                    (:double ())
-                   (id ()) (objc-class ()) (selector ())
+                   (id ()) (objective-c-class ()) (selector ())
                    (:string ())
                    (:unknown ()))))
    ((ensure (let ((funky-spec (parse-typespec "{?=cC}")))
diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp
index bc46e6b..5b5292b 100644
--- a/Lisp/type-handling.lisp
+++ b/Lisp/type-handling.lisp
@@ -172,7 +172,7 @@ Returns: (VALUES typespec byte-position string-position)"
                               (#\d :double)
                               (#\v :void)
                               (#\@ 'id)
-                              (#\# 'objc-class)
+                              (#\# 'objective-c-class)
                               (#\: 'selector)
                               (#\* :string)
                               (#\? :unknown))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index 6619490..ef658f2 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -158,10 +158,10 @@ invocations will return numbers.)
   ;; matter (it only does so on NeXT/x86, but neither on GNUstep nor on
   ;; NeXT/ppc32).
   (or (id-eql x y)
-      (truep (if (typep x '(or id objc-class exception))
+      (truep (if (typep x '(or id objective-c-class exception))
                  (invoke x :is-equal y)
                  (progn
-                   (assert (typep y '(or id objc-class exception)))
+                   (assert (typep y '(or id objective-c-class exception)))
                    (invoke y :is-equal x))))))
 
 
@@ -182,10 +182,10 @@ invocations will return numbers.)
 (defmethod objc-eql (x (y id))
   (id-eql x y))
 
-(defmethod objc-eql ((x objc-class) y)
+(defmethod objc-eql ((x objective-c-class) y)
   (id-eql x y))
 
-(defmethod objc-eql (x (y objc-class))
+(defmethod objc-eql (x (y objective-c-class))
   (id-eql x y))
 
 (defmethod objc-eql ((x exception) y)
@@ -213,10 +213,10 @@ invocations will return numbers.)
 (defmethod objc-equal (x (y id))
   (id-equal x y))
 
-(defmethod objc-equal ((x objc-class) y)
+(defmethod objc-equal ((x objective-c-class) y)
   (id-equal x y))
 
-(defmethod objc-equal (x (y objc-class))
+(defmethod objc-equal (x (y objective-c-class))
   (id-equal x y))
 
 (defmethod objc-equal ((x exception) y)
@@ -248,12 +248,12 @@ invocations will return numbers.)
                   (cffi:pointer-address pointer))))))
 
 
-(defmethod print-object ((class objc-class) stream)
+(defmethod print-object ((class objective-c-class) stream)
   (print-unreadable-object (class stream)
     (with-slots (pointer) class
       (format stream "~S ~A {~X}"
               (type-of class)
-              (objc-class-name class)
+              (class-name class)
               (cffi:pointer-address pointer)))))