Add exception handling.

darcs-hash:6d186beda9c5b12e5d366afb95a052208dbc7596

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