summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libobjcl.h4
-rw-r--r--libobjcl.m105
-rw-r--r--objcl.lisp78
3 files changed, 131 insertions, 56 deletions
diff --git a/libobjcl.h b/libobjcl.h
index ca959c3..4d6d092 100644
--- a/libobjcl.h
+++ b/libobjcl.h
@@ -11,6 +11,7 @@ typedef struct objcl_object
{
id id_val;
Class class_val;
+ NSException *exc_val;
SEL sel_val;
char char_val;
short short_val;
@@ -26,6 +27,9 @@ typedef struct objcl_object
} *OBJCL_OBJ_DATA;
+#define EXCEPTION_TYPESPEC "ERROR"
+
+
void
objcl_initialise_runtime (void);
diff --git a/libobjcl.m b/libobjcl.m
index 24ab072..a32ea1f 100644
--- a/libobjcl.m
+++ b/libobjcl.m
@@ -72,8 +72,9 @@ _objcl_get_arg_pointer (void *buffer, OBJCL_OBJ_DATA argdata)
}
-static void *
+static void
_objcl_invoke_method (id self_,
+ OBJCL_OBJ_DATA result,
NSMethodSignature *signature,
SEL selector,
int argc,
@@ -82,7 +83,6 @@ _objcl_invoke_method (id self_,
int i;
NSInvocation *invocation;
void *result_ptr = NULL;
- OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object));
const char *type = [signature methodReturnType];
result->type = malloc (strlen (type) + 1);
@@ -90,7 +90,9 @@ _objcl_invoke_method (id self_,
if (signature == NULL)
{
- return NULL;
+ [[NSException exceptionWithName: @"MLKNoSignatureFoundException"
+ reason: @"No signature found"
+ userInfo: NULL] raise];
}
@@ -159,8 +161,6 @@ _objcl_invoke_method (id self_,
[invocation getReturnValue: result_ptr];
if (result->type[0] == '#')
NSLog (@"Returning: %@", result->data.id_val);
-
- return result;
}
@@ -174,24 +174,38 @@ objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver,
id self_ = NULL;
SEL selector;
NSMethodSignature *signature;
- void *result;
+ OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object));
- assert (receiver->type[0] == '#'
- || receiver->type[0] == '@');
- switch (receiver->type[0])
+ NS_DURING
{
- case '#': self_ = receiver->data.class_val;
- case '@': self_ = receiver->data.id_val;
+ fprintf (stderr, "! ---------> %s <--------\n", receiver->type);
+ assert (receiver->type[0] == '#'
+ || receiver->type[0] == '@'
+ || receiver->type[0] == 'E');
+ switch (receiver->type[0])
+ {
+ case '#': self_ = receiver->data.class_val;
+ case '@': self_ = receiver->data.id_val;
+ case 'E': self_ = receiver->data.exc_val;
+ }
+
+ selector = NSSelectorFromString ([NSString
+ stringWithUTF8String: method_name]);
+
+ signature = [self_ instanceMethodSignatureForSelector: selector];
+
+ va_start (arglist, argc);
+ _objcl_invoke_method (self_, result, signature, selector, argc, arglist);
+ va_end (arglist);
}
-
- selector = NSSelectorFromString ([NSString
- stringWithUTF8String: method_name]);
-
- signature = [self_ instanceMethodSignatureForSelector: selector];
-
- va_start (arglist, argc);
- result = _objcl_invoke_method (self_, signature, selector, argc, arglist);
- va_end (arglist);
+ NS_HANDLER
+ {
+ result->type = malloc (strlen (EXCEPTION_TYPESPEC) + 1);
+ strcpy (result->type, EXCEPTION_TYPESPEC);
+ result->data.exc_val = localException;
+ NS_VALUERETURN (result, void *);
+ }
+ NS_ENDHANDLER
return result;
}
@@ -207,26 +221,39 @@ objcl_invoke_class_method (OBJCL_OBJ_DATA class,
id self_ = NULL;
SEL selector;
NSMethodSignature *signature;
- void *result;
+ OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object));
- assert (class->type[0] == '#'
- || class->type[0] == '@');
- switch (class->type[0])
+ NS_DURING
{
- case '#': self_ = class->data.class_val;
- case '@': self_ = class->data.id_val;
+ assert (class->type[0] == '#'
+ || class->type[0] == '@'
+ || class->type[0] == 'E');
+ switch (class->type[0])
+ {
+ case '#': self_ = class->data.class_val;
+ case '@': self_ = class->data.id_val;
+ case 'E': self_ = class->data.exc_val;
+ }
+
+ selector = NSSelectorFromString ([NSString
+ stringWithUTF8String: method_name]);
+
+ signature = [self_ methodSignatureForSelector: selector];
+
+ va_start (arglist, argc);
+ _objcl_invoke_method (self_, result, signature, selector, argc, arglist);
+ va_end (arglist);
}
+ NS_HANDLER
+ {
+ result->type = malloc (strlen (EXCEPTION_TYPESPEC) + 1);
+ strcpy (result->type, EXCEPTION_TYPESPEC);
+ result->data.exc_val = localException;
+ NS_VALUERETURN (result, void *);
+ }
+ NS_ENDHANDLER
- selector = NSSelectorFromString ([NSString
- stringWithUTF8String: method_name]);
-
- signature = [self_ methodSignatureForSelector: selector];
-
- va_start (arglist, argc);
- result = _objcl_invoke_method (self_, signature, selector, argc, arglist);
- va_end (arglist);
-
- return result;
+ return result;
}
@@ -251,12 +278,16 @@ objcl_class_name (OBJCL_OBJ_DATA class)
{
Class cls = NULL;
+ fprintf (stderr, "---------> %s <--------\n", class->type);
+ fflush (stderr);
assert (class->type[0] == '#'
- || class->type[0] == '@');
+ || class->type[0] == '@'
+ || class->type[0] == 'E');
switch (class->type[0])
{
case '#': cls = class->data.class_val;
case '@': cls = class->data.id_val;
+ case 'E': cls = (id) class->data.exc_val;
}
return class_get_class_name (cls);
diff --git a/objcl.lisp b/objcl.lisp
index 2b7d2ee..49085f8 100644
--- a/objcl.lisp
+++ b/objcl.lisp
@@ -13,6 +13,19 @@
'(satisfies pointerp))
+(defctype char-pointer :pointer)
+
+(defmethod translate-to-foreign ((value string) (type (eql 'char-pointer)))
+ #+nil
+ (let ((buffer (foreign-alloc :char :count (length value))))
+ (cffi:lisp-string-to-foreign value buffer (length value))
+ buffer)
+ (foreign-string-alloc value))
+
+(defmethod translate-from-foreign (c-value (type (eql 'char-pointer)))
+ (foreign-string-to-lisp c-value))
+
+
(defclass c-pointer-wrapper ()
((pointer :type c-pointer
:accessor pointer-to
@@ -23,10 +36,22 @@
(defclass objc-id (c-pointer-wrapper) ())
(defclass objc-class (c-pointer-wrapper) ())
+(define-condition objc-exception (error)
+ ((pointer :type c-pointer
+ :accessor pointer-to
+ :initarg :pointer))
+ (:documentation "The condition type for Objective C exceptions.")
+ (:report (lambda (condition stream)
+ (format stream
+ "The Objective C runtime has issued an exception of ~
+ type `~A'."
+ (objcl-invoke-class-method condition "name")))))
+
(defcunion obj-data-union
(id-val :pointer)
(class-val :pointer)
+ (exc-val :pointer)
(sel-val :pointer)
(char-val :char)
(short-val :short)
@@ -41,14 +66,13 @@
(defcstruct obj-data
- (type :string)
+ (type char-pointer)
(data obj-data-union))
(defun dealloc-obj-data (obj-data)
- #+nil
(with-foreign-slots ((type data) obj-data obj-data)
- (free-translated-object type :string '(t)))
+ (foreign-string-free type))
(foreign-free obj-data))
@@ -80,6 +104,7 @@
(defparameter *objcl-api-type-names*
'((id . #\@)
(class . #\#)
+ (exc . #\E)
(sel . #\:)
(chr . #\c)
(uchr . #\C)
@@ -113,6 +138,7 @@
(defparameter *objcl-data-map*
'((id . id-val)
(class . class-val)
+ (exc . exc-val)
(sel . sel-val)
(chr . char-val)
(uchr . char-val)
@@ -135,6 +161,7 @@
'((id . objc-id)
(class . objc-class)
(sel . objc-selector)
+ (exc . objc-exception)
(chr . character)
(int . integer)
(uint . integer)
@@ -154,6 +181,7 @@
'((id . :pointer)
(class . :pointer)
(sel . :pointer)
+ (exc . :pointer)
(chr . :char)
(int . :int)
(uint . :unsigned-int)
@@ -202,7 +230,8 @@
(defun arglist-intersperse-types (arglist)
(mapcan #'(lambda (arg)
(with-foreign-slots ((type data) arg obj-data)
- (list (type-name->c-type (type-id->type-name type))
+ (list (type-name->c-type (type-id->type-name
+ (foreign-string-to-lisp type)))
arg)))
arglist))
@@ -229,7 +258,13 @@
(length args)
arglist)))
(prog1
- (obj-data->lisp return-value)
+ (let ((value (obj-data->lisp return-value)))
+ (if (typep value 'condition)
+ (cerror "Return NIL from OBJCL-INVOKE-CLASS-METHOD" value)
+ value))
+ #+nil (print (foreign-string-to-lisp (foreign-slot-value return-value
+ 'obj-data
+ 'type)))
(dealloc-obj-data return-value))))
@@ -241,24 +276,26 @@
'obj-data-union
(type-name->slot-name type-name))
(typecase value
- ((or objc-id objc-class objc-selector)
+ ((or objc-id objc-class objc-selector objc-exception)
(pointer-to value))
(otherwise value)))
(setf type
- (type-name->type-id type-name)))
+ (foreign-string-alloc (type-name->type-id type-name)))
+ #+nil (print (foreign-string-to-lisp type)))
obj-data))
(defun obj-data->lisp (obj-data)
(with-foreign-slots ((type data) obj-data obj-data)
- (let* ((type-name (type-id->type-name type))
+ (let* ((type-name (type-id->type-name (foreign-string-to-lisp type)))
(lisp-type (type-name->lisp-type type-name))
(value (foreign-slot-value data
'obj-data-union
(type-name->slot-name type-name))))
(case lisp-type
- ((objc-id objc-class objc-selector)
+ ((objc-id objc-class objc-selector objc-exception)
(make-instance lisp-type :pointer value))
+ ((string) (foreign-string-to-lisp value))
(otherwise value)))))
@@ -275,20 +312,22 @@
(defun objcl-class-name (class)
- (declare (type (or objc-class objc-id) class))
+ (declare (type (or objc-class objc-id objc-exception) class))
(let ((obj-data (foreign-alloc 'obj-data)))
(with-foreign-slots ((type data) obj-data obj-data)
- (setf type (typecase class
- (objc-class "#")
- (objc-id "@")))
(setf (foreign-slot-value obj-data
'obj-data-union
- (typecase class
- (objc-class 'class-val)
- (objc-id 'id-val)))
- (pointer-to class)))
+ (etypecase class
+ (objc-class 'class-val)
+ (objc-id 'id-val)
+ (objc-exception 'exc-val)))
+ (pointer-to class))
+ (setf type (foreign-string-alloc (etypecase class
+ (objc-class "#")
+ (objc-id "@")
+ (objc-exception "E")))))
(prog1
- (%objcl-class-name (pointer-to class))
+ (%objcl-class-name obj-data)
(dealloc-obj-data obj-data))))
@@ -352,7 +391,8 @@
(setf args (nreverse args))
`(,(if class-method-p
'objcl-invoke-class-method
- 'objcl-invoke-instance-method)
+ #+nil 'objcl-invoke-instance-method
+ #-nil 'objcl-invoke-class-method)
,receiver
,(make-array (list (length message))
:element-type 'character
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-26 12:13:14 +0000