summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/libobjcl.lisp52
-rw-r--r--Lisp/method-invocation.lisp15
-rw-r--r--Lisp/utilities.lisp13
-rw-r--r--Objective-C/libobjcl.h12
-rw-r--r--Objective-C/libobjcl.m94
5 files changed, 60 insertions, 126 deletions
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 072eb30..9849392 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -42,20 +42,20 @@
(defcfun ("objcl_find_class" %objcl-find-class) :pointer
(class-name :string))
-(defcfun ("objcl_class_name" %objcl-class-name) :pointer
- (class obj-data))
+(defcfun ("objcl_class_name" %objcl-class-name) :string
+ (class :pointer))
(defcfun ("objcl_find_selector" %objcl-find-selector) :pointer
(selector-name :string))
-(defcfun ("objcl_selector_name" %objcl-selector-name) :pointer
- (selector obj-data))
+(defcfun ("objcl_selector_name" %objcl-selector-name) :string
+ (selector :pointer))
(defcfun ("objcl_get_method_implementation"
%objcl-get-method-implementation)
:pointer
- (object obj-data)
- (selector obj-data))
+ (object :pointer)
+ (selector :pointer))
(defcfun ("objcl_object_is_class" %objcl-object-is-class) :boolean
(obj :pointer))
@@ -198,49 +198,43 @@ conventional case for namespace identifiers in Objective C."
(declaim (ftype (function (string) (or null objc-class))
find-objc-class-by-name))
(defun find-objc-class-by-name (class-name)
- (with-obj-data-values ((obj-data (%objcl-find-class class-name)))
- (if (null-pointer-p (foreign-slot-value
- (foreign-slot-value obj-data 'obj-data 'data)
- 'obj-data-union
- 'class-val))
+ (let ((class-ptr (%objcl-find-class class-name)))
+ (if (cffi:null-pointer-p class-ptr)
nil
- (the objc-class (obj-data->lisp obj-data)))))
+ #-openmcl (make-instance 'objc-class :pointer class-ptr)
+ #+openmcl (change-class (make-instance 'c-pointer-wrapper
+ :pointer value)
+ 'objc-class))))
(declaim (ftype (function (string) (or null selector))
find-selector-by-name))
(defun find-selector-by-name (selector-name)
- (with-obj-data-values ((obj-data (%objcl-find-selector selector-name)))
- (if (null-pointer-p (foreign-slot-value
- (foreign-slot-value obj-data 'obj-data 'data)
- 'obj-data-union
- 'sel-val))
+ (let ((selector-ptr (%objcl-find-selector selector-name)))
+ (if (cffi:null-pointer-p selector-ptr)
nil
- (the selector (obj-data->lisp obj-data)))))
+ (make-instance 'selector :pointer selector-ptr))))
(declaim (ftype (function ((or objc-class id exception)) string)
objcl-class-name))
(defun objcl-class-name (class)
(declare (type (or objc-class id exception) class))
- (with-foreign-conversion ((obj-data class))
- (foreign-string-to-lisp/dealloc (%objcl-class-name obj-data))))
+ (%objcl-class-name (pointer-to class)))
(declaim (ftype (function (selector) string) selector-name))
(defun selector-name (selector)
(declare (type selector selector))
- (with-foreign-conversion ((obj-data selector))
- (foreign-string-to-lisp/dealloc (%objcl-selector-name obj-data))))
+ (%objcl-selector-name (pointer-to selector)))
(declaim (ftype (function ((or id objc-class exception) selector) *)
get-method-implementation))
(defun get-method-implementation (object selector)
(declare (type selector selector))
- (with-foreign-conversion ((sel-obj-data selector)
- (obj-obj-data object))
- (%objcl-get-method-implementation obj-obj-data sel-obj-data)))
+ (%objcl-get-method-implementation (pointer-to object)
+ (pointer-to selector)))
(declaim (ftype (function ((or selector string list)) (or null selector))
@@ -425,13 +419,7 @@ If *selector-designator* is a __selector__, it is simply returned.
(type-name->slot-name type-name)))))
(case lisp-type
((id objc-class selector exception)
- #-openmcl (make-instance lisp-type :pointer value)
- #+openmcl (if (eq 'objc-class lisp-type)
- ;; God help me.
- (change-class (make-instance 'c-pointer-wrapper
- :pointer value)
- lisp-type)
- (make-instance lisp-type :pointer value)))
+ (make-instance lisp-type :pointer value) )
((string) (foreign-string-to-lisp value))
(otherwise value)))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index edbdc17..6176553 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -4,7 +4,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (boundp '+nil+)
(defconstant +nil+
- (make-instance 'id :pointer (objcl-get-nil)))))
+ (make-instance 'id :pointer (objcl-get-nil)))))
;;; (@* "Method invocation")
@@ -154,7 +154,8 @@ Returns: *result* --- the return value of the method invocation.
(defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args)
- (let ((real-return-type (if (member return-type '(id objc-class exception))
+ (let ((real-return-type (if (member return-type '(id objc-class exception
+ selector))
:pointer
return-type))
(real-receiver (gensym))
@@ -175,13 +176,10 @@ Returns: *result* --- the return value of the method invocation.
(list :pointer (pointer-to ,real-selector))
objc-arglist
(list ,real-return-type)))))
- ,(if (member return-type '(id objc-class exception))
+ ,(if (member return-type '(id objc-class exception selector))
`(let (,@(when (constructor-name-p (selector-name selector))
`((*skip-retaining* t))))
- (make-instance ',(case return-type
- ((id) 'id)
- ((objc-class) 'objc-class)
- ((exception) 'exception))
+ (make-instance return-type
:pointer return-value))
`return-value))
(dealloc-objc-arglist objc-arglist)))))))
@@ -277,8 +275,7 @@ Returns: *result* --- the return value of the method invocation.
return-c-type)))
(if (cffi:null-pointer-p pointer)
nil
- (make-instance return-type
- :pointer pointer))))
+ (make-instance return-type :pointer pointer))))
((:void) (values))
(otherwise (cffi:mem-ref return-value-cell
return-c-type)))))))))))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index a81b61c..b44c05d 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -6,8 +6,9 @@
(defun truep (b)
- (not (or (zerop b)
- (null b))))
+ (or (eq b t)
+ (and (numberp b)
+ (not (zerop b)))))
(defun id-eql (x y)
@@ -16,17 +17,17 @@
(defun id-equal (x y)
(truep (if (typep x '(or id objc-class exception))
- (invoke x :is-equal y)
+ (primitive-invoke x :is-equal :boolean y)
(progn
(assert (typep y '(or id objc-class exception)))
- (invoke y :is-equal x)))))
+ (primitive-invoke y :is-equal :boolean x)))))
(defun objc-typep (x class-designator)
- (objc-eql (invoke x 'class)
+ (objc-eql (object-get-class x)
(etypecase x
(class x)
- (id (invoke x 'class))
+ (id (object-get-class x))
((or string symbol) (find-objc-class class-designator t)))))
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 9c673f7..a912748 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -57,10 +57,10 @@ objcl_invoke_with_types (int argc,
void *return_value,
void **argv);
-OBJCL_OBJ_DATA
+Class
objcl_find_class (const char *class_name);
-OBJCL_OBJ_DATA
+SEL
objcl_find_selector (const char *selector_name);
/* Return a null-terminated list of type information strings.
@@ -71,14 +71,14 @@ objcl_query_arglist_info (void *receiver,
const char *
-objcl_class_name (OBJCL_OBJ_DATA class);
+objcl_class_name (Class class);
const char *
-objcl_selector_name (OBJCL_OBJ_DATA class);
+objcl_selector_name (SEL selector);
IMP
-objcl_get_method_implementation (OBJCL_OBJ_DATA object,
- OBJCL_OBJ_DATA selector);
+objcl_get_method_implementation (id object,
+ SEL selector);
BOOL
objcl_object_is_class (id obj);
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 1a17a44..eaffb8c 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -336,61 +336,27 @@ objcl_invoke_with_types (int argc,
#endif
-OBJCL_OBJ_DATA
+Class
objcl_find_class (const char *class_name)
{
- Class class =
- NSClassFromString ([NSString stringWithUTF8String: class_name]);
- OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object));
- const char *const typespec = @encode (Class);
-
- result->type = malloc (strlen (typespec) + 1);
- strcpy (result->type, typespec);
- result->data.class_val = class;
-
- return result;
+ return NSClassFromString ([NSString stringWithUTF8String: class_name]);
}
-OBJCL_OBJ_DATA
+SEL
objcl_find_selector (const char *class_name)
{
- SEL selector =
- NSSelectorFromString ([NSString stringWithUTF8String: class_name]);
- OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object));
- const char *const typespec = @encode (SEL);
-
- result->type = malloc (strlen (typespec) + 1);
- strcpy (result->type, typespec);
- result->data.sel_val = selector;
-
- return result;
+ return NSSelectorFromString ([NSString stringWithUTF8String: class_name]);
}
const char *
-objcl_class_name (OBJCL_OBJ_DATA class)
+objcl_class_name (Class class)
{
const char *ns_name;
char *name;
- Class cls = NULL;
- switch (class->type[0])
- {
- case '#':
- cls = class->data.class_val;
- break;
- case '@':
- cls = class->data.id_val;
- break;
- case 'E':
- cls = (id) class->data.exc_val;
- break;
- default:
- return NULL;
- }
-
- ns_name = [(NSStringFromClass (cls)) UTF8String];
+ ns_name = [(NSStringFromClass (class)) UTF8String];
name = malloc (strlen (ns_name) + 1);
strcpy (name, ns_name);
@@ -399,16 +365,12 @@ objcl_class_name (OBJCL_OBJ_DATA class)
const char *
-objcl_selector_name (OBJCL_OBJ_DATA selector)
+objcl_selector_name (SEL selector)
{
const char *ns_name;
char *name;
- if (strcmp (selector->type, @encode (SEL)) != 0)
- return NULL;
-
- ns_name = [(NSStringFromSelector (selector->data.sel_val))
- UTF8String];
+ ns_name = [(NSStringFromSelector (selector)) UTF8String];
name = malloc (strlen (ns_name) + 1);
strcpy (name, ns_name);
@@ -417,34 +379,20 @@ objcl_selector_name (OBJCL_OBJ_DATA selector)
IMP
-objcl_get_method_implementation (OBJCL_OBJ_DATA object,
- OBJCL_OBJ_DATA selector)
+objcl_get_method_implementation (id object,
+ SEL selector)
{
- id obj;
-
- if (strcmp (selector->type, @encode (SEL)) != 0)
- return NULL;
-
- switch (object->type[0])
+#ifdef __NEXT_RUNTIME__
+ if (objcl_object_is_class (object))
{
- case '#':
- obj = object->data.class_val;
- break;
- case '@':
- obj = object->data.id_val;
- break;
- case 'E':
- obj = (id) object->data.exc_val;
- break;
- default:
- return NULL;
+ return class_getClassMethod (object, selector)->method_imp;
+ }
+ else
+ {
+ return class_getInstanceMethod ([object class], selector)->method_imp;
}
-
-#ifdef __NEXT_RUNTIME__
- return class_getInstanceMethod ([obj class],
- selector->data.sel_val)->method_imp;
#else
- return objc_msg_lookup (obj, selector->data.sel_val);
+ return objc_msg_lookup (object, selector);
#endif
}
@@ -453,7 +401,7 @@ BOOL
objcl_object_is_class (id obj)
{
#ifdef __NEXT_RUNTIME__
- return [obj class] == obj
+ return [obj class] == obj;
#else
/* return CLS_ISCLASS (obj); */
return object_is_class (obj);
@@ -466,7 +414,7 @@ objcl_object_is_meta_class (id obj)
{
#ifdef __NEXT_RUNTIME__
/* FIXME: What to do here? */
- return [[obj class] metaClass] == obj;
+ return objcl_object_get_meta_class (obj) == obj;
#else
/* return CLS_ISMETA (ptr); */
if (objcl_object_is_class (obj))
@@ -494,7 +442,7 @@ objcl_object_get_meta_class (id obj)
{
#ifdef __NEXT_RUNTIME__
/* FIXME: What to do here? */
- return [[obj class] metaClass];
+ return objc_getMetaClass ([(NSStringFromClass ([obj class])) UTF8String]);
#else
if (objcl_object_is_class (obj))
return class_get_meta_class (obj);