summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/class-definition.lisp20
-rw-r--r--Lisp/constant-data.lisp2
-rw-r--r--Lisp/data-types.lisp6
-rw-r--r--Lisp/defpackage.lisp5
-rw-r--r--Lisp/libobjcl.lisp28
-rw-r--r--Lisp/memory-management.lisp6
-rw-r--r--Lisp/method-invocation.lisp15
-rw-r--r--Lisp/name-conversion.lisp37
-rw-r--r--Lisp/tests.lisp6
-rw-r--r--Lisp/type-handling.lisp2
-rw-r--r--Lisp/utilities.lisp16
-rw-r--r--objective-cl.asd3
12 files changed, 98 insertions, 48 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)))))
diff --git a/objective-cl.asd b/objective-cl.asd
index e710906..82cc2aa 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -59,7 +59,8 @@
"memory-management"))
(:file "memory-management" :depends-on ("defpackage"
"weak-hash-tables"
- "parameters"))
+ "parameters"
+ "conditions"))
(:file "reader-syntax" :depends-on ("defpackage"
"method-invocation"))
(:file "utilities" :depends-on ("init"