From b0a5bbccb99f099046dc15c32939dc0d0c735e02 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 3 Aug 2007 21:13:18 +0200 Subject: Add exception handling. darcs-hash:6d186beda9c5b12e5d366afb95a052208dbc7596 --- libobjcl.h | 4 +++ libobjcl.m | 105 +++++++++++++++++++++++++++++++++++++++---------------------- objcl.lisp | 78 ++++++++++++++++++++++++++++++++++----------- 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 -- cgit v1.2.3