From 0659e7a29136823cba53c05fa94df2db29a3ddbc Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Thu, 7 Feb 2008 22:16:58 +0100
Subject: Objective-C layer: Add objcl_create_imp and assorted functions.

darcs-hash:586394a97ab02a3f8e258cd75c1230dff717a38e
---
 Lisp/libobjcl.lisp     | 15 ++++++++
 Objective-C/libobjcl.h | 14 ++++++++
 Objective-C/libobjcl.m | 93 ++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 122 insertions(+)

diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 07f88ac..fd575d2 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -121,6 +121,21 @@
 (defcfun objcl-get-yes :long)
 (defcfun objcl-get-no :long)
 
+(defcfun ("objcl_create_imp" %objcl-create-imp) :pointer
+  (callback :pointer)
+  (argc :int)
+  (return-typespec :string)
+  (arg-typespecs (:array :string)))
+
+(defcfun ("objcl_acquire_lock" %objcl-release-lock) :pointer
+  (lock :pointer))
+
+(defcfun ("objcl_release_lock" %objcl-acquire-lock) :pointer
+  (lock :pointer))
+
+(defcvar *objcl-current-exception-lock* :pointer)
+(defcvar *objcl-current-exception* :pointer)
+
 (defun objcl-get-nil ()
   ;; %OBJCL-GET-NIL can return NIL for CLISP, which CFFI refuses to
   ;; accept as an argument to POINTER-EQ.  This is weird.
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 09b08ab..270af45 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -44,6 +44,8 @@ typedef struct objc_ivar *IVAR_T;
 #endif
 
 extern NSException *objcl_oom_exception;
+extern id objcl_current_exception;
+extern void *objcl_current_exception_lock;
 
 
 void
@@ -145,3 +147,15 @@ objcl_slot_name (IVAR_T ivar);
 
 const char *
 objcl_slot_type (IVAR_T ivar);
+
+IMP
+objcl_create_imp (IMP callback,
+                  int argc,
+                  const char *return_typespec,
+                  const char *arg_typespecs[]);
+
+void
+objcl_acquire_lock (void *lock);
+
+void
+objcl_release_lock (void *lock);
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 1d6607e..3cbf3e5 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -45,6 +45,9 @@ static NSAutoreleasePool *objcl_autorelease_pool = NULL;
 /* Preallocate an exception to throw when memory is all used up. */
 NSException *objcl_oom_exception = NULL;
 
+id objcl_current_exception = NULL;
+void *objcl_current_exception_lock = NULL;
+
 
 void
 objcl_initialise_runtime (void)
@@ -477,3 +480,93 @@ objcl_slot_type (IVAR_T ivar)
   return ivar->ivar_type;
 #endif
 }
+
+
+
+
+/* In order to be able to do exception propagation from Lisp code, we
+   have the Lisp layer save exceptions to objcl_current_exception.  Our
+   wrapper function is then able to raise the exception from where it
+   ought to be raised from: the Objective-C layer.
+
+   Note that it is the Lisp layer's duty to wrap Objective-C exceptions
+   around Lisp SERIOUS-CONDITIONs in order to propagate them. */
+static void
+imp_closure (ffi_cif *cif, void *result, void **args, void *user_data)
+{
+  id exception;
+
+  ffi_call (cif, user_data, result, args);
+
+  exception = objcl_current_exception;
+  objcl_current_exception = NULL;
+  objcl_release_lock (objcl_current_exception_lock);
+
+  if (exception)
+    [exception raise];
+}
+
+
+IMP
+objcl_create_imp (IMP callback,
+                  int argc,
+                  const char *return_typespec,
+                  const char *arg_typespecs[])
+{
+  ffi_type *return_type;
+  ffi_type *arg_types[argc + 2];
+  ffi_status status;
+  ffi_cif cif;
+  ffi_closure *closure;
+
+  int i;
+
+  static ffi_type *id_type = NULL;
+  static ffi_type *sel_type = NULL;
+
+  if (!id_type)
+    id_type = objcl_pyobjc_arg_signature_to_ffi_type ("@");
+
+  if (!sel_type)
+    sel_type = objcl_pyobjc_arg_signature_to_ffi_type (":");
+
+  return_type = objcl_pyobjc_signature_to_ffi_return_type (return_typespec);
+
+  arg_types[0] = id_type;
+  arg_types[1] = sel_type;
+
+  for (i = 0; i < argc; i++)
+    arg_types[i + 2] = objcl_pyobjc_arg_signature_to_ffi_type (arg_typespecs[i]);
+
+  status = ffi_prep_cif (&cif, FFI_DEFAULT_ABI, argc + 2, return_type, arg_types);
+  if (status != FFI_OK)
+    {
+      [[NSException exceptionWithName: @"MLKInvalidFFITypeException"
+                    reason: @"FFI type is invalid (this is probably a bug)."
+                    userInfo: nil] raise];
+    }
+
+  status = ffi_prep_closure (closure, &cif, imp_closure, (void *)callback);
+  if (status != FFI_OK)
+    {
+      [[NSException exceptionWithName: @"MLKClosureCreationFailure"
+                    reason: @"Creating an IMP closure failed (this is probably a bug)."
+                    userInfo: nil] raise];
+    }
+
+  return (IMP) closure;
+}
+
+
+void
+objcl_acquire_lock (void *lock)
+{
+#warning "FIXME"
+}
+
+
+void
+objcl_release_lock (void *lock)
+{
+#warning "FIXME"
+}
-- 
cgit v1.2.3