diff options
| -rw-r--r-- | libobjcl.h | 45 | ||||
| -rw-r--r-- | libobjcl.m | 157 | ||||
| -rw-r--r-- | objcl.lisp | 243 |
3 files changed, 362 insertions, 83 deletions
@@ -1,22 +1,53 @@ /* -*- mode: objc; coding: utf-8 -*- */ +#import "Foundation/Foundation.h" +#include <objc/objc-api.h> + +typedef struct objcl_object +{ + char* type; + + union + { + id id_val; + SEL sel_val; + char char_val; + short short_val; + int int_val; + long long_val; + long long long_long_val; + float float_val; + double double_val; + BOOL bool_val; + char *charptr_val; + void *ptr_val; + } data; +} *OBJCL_OBJ_DATA; + + void -objcl_initialise_runtime (); +objcl_initialise_runtime (void); void -objcl_shutdown_runtime (); +objcl_shutdown_runtime (void); void * -objcl_invoke_instance_method (void *receiver, - char *const method_name, +objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver, + const char *method_name, int argc, ...); void * -objcl_invoke_class_method (void *class, - char *const method_name, +objcl_invoke_class_method (OBJCL_OBJ_DATA class, + const char *method_name, int argc, ...); void * -objcl_find_class (char *const class_name); +objcl_find_class (const char *class_name); + +/* Return a null-terminated list of type information strings. + The first entry describes the type of the method's return value. */ +char ** +objcl_query_arglist_info (void *receiver, + const char *method_name); @@ -6,7 +6,7 @@ #include <objc/objc-api.h> -NSAutoreleasePool *objcl_autorelease_pool = NULL; +static NSAutoreleasePool *objcl_autorelease_pool = NULL; void @@ -23,59 +23,36 @@ objcl_shutdown_runtime () } -#define _OBJCL_ARG_DECL(typespec, c_type) \ - c_type __##typespec##_tmp - - -#define _OBJCL_ARG_CASE(typespec, c_type) \ +#define _OBJCL_ARG_CASE(typespec, field_name) \ case typespec: \ - __##typespec##_tmp = va_arg (arglist, c_type); \ - memmove (buffer, &__##typespec##_tmp, objc_sizeof_type (type)); \ + memmove (buffer, &argdata->data.field_name##_val, \ + objc_sizeof_type (argdata->type)); \ break; -void -_objcl_get_arg_pointer (void *buffer, const char *type, va_list arglist) +static void +_objcl_get_arg_pointer (void *buffer, OBJCL_OBJ_DATA argdata) { - _OBJCL_ARG_DECL(_C_ID, id); - _OBJCL_ARG_DECL(_C_CLASS, id); - _OBJCL_ARG_DECL(_C_SEL, SEL); - _OBJCL_ARG_DECL(_C_CHR, char); - _OBJCL_ARG_DECL(_C_UCHR, unsigned char); - _OBJCL_ARG_DECL(_C_SHT, short); - _OBJCL_ARG_DECL(_C_USHT, unsigned short); - _OBJCL_ARG_DECL(_C_INT, int); - _OBJCL_ARG_DECL(_C_UINT, unsigned int); - _OBJCL_ARG_DECL(_C_LNG, long); - _OBJCL_ARG_DECL(_C_ULNG, unsigned long); - _OBJCL_ARG_DECL(_C_LNG_LNG, long long); - _OBJCL_ARG_DECL(_C_ULNG_LNG, unsigned long long); - _OBJCL_ARG_DECL(_C_FLT, float); - _OBJCL_ARG_DECL(_C_DBL, double); - _OBJCL_ARG_DECL(_C_BOOL, BOOL); - _OBJCL_ARG_DECL(_C_PTR, void *); - _OBJCL_ARG_DECL(_C_CHARPTR, char *); - - switch (type[0]) + switch (argdata->type[0]) { _OBJCL_ARG_CASE(_C_ID, id); _OBJCL_ARG_CASE(_C_CLASS, id); - _OBJCL_ARG_CASE(_C_SEL, SEL); - _OBJCL_ARG_CASE(_C_CHR, int); - _OBJCL_ARG_CASE(_C_UCHR, int); - _OBJCL_ARG_CASE(_C_SHT, int); - _OBJCL_ARG_CASE(_C_USHT, int); + _OBJCL_ARG_CASE(_C_SEL, sel); + _OBJCL_ARG_CASE(_C_CHR, char); + _OBJCL_ARG_CASE(_C_UCHR, char); + _OBJCL_ARG_CASE(_C_SHT, short); + _OBJCL_ARG_CASE(_C_USHT, short); _OBJCL_ARG_CASE(_C_INT, int); - _OBJCL_ARG_CASE(_C_UINT, unsigned int); + _OBJCL_ARG_CASE(_C_UINT, int); _OBJCL_ARG_CASE(_C_LNG, long); - _OBJCL_ARG_CASE(_C_ULNG, unsigned long); - _OBJCL_ARG_CASE(_C_LNG_LNG, long long); - _OBJCL_ARG_CASE(_C_ULNG_LNG, unsigned long long); - _OBJCL_ARG_CASE(_C_FLT, double); + _OBJCL_ARG_CASE(_C_ULNG, long); + _OBJCL_ARG_CASE(_C_LNG_LNG, long_long); + _OBJCL_ARG_CASE(_C_ULNG_LNG, long_long); + _OBJCL_ARG_CASE(_C_FLT, float); _OBJCL_ARG_CASE(_C_DBL, double); - _OBJCL_ARG_CASE(_C_BOOL, int); - _OBJCL_ARG_CASE(_C_PTR, void *); - _OBJCL_ARG_CASE(_C_CHARPTR, char *); + _OBJCL_ARG_CASE(_C_BOOL, bool); + _OBJCL_ARG_CASE(_C_PTR, ptr); + _OBJCL_ARG_CASE(_C_CHARPTR, charptr); /* _OBJCL_ARG_CASE(_C_VOID, void); _OBJCL_ARG_CASE(_C_BFLD, bitfield); @@ -88,13 +65,14 @@ _objcl_get_arg_pointer (void *buffer, const char *type, va_list arglist) */ case _C_UNDEF: default: - NSLog (@"Dammit. What the heck is `%s' supposed to mean?", type); + NSLog (@"Dammit. What the heck is `%s' supposed to mean?", + argdata->type); break; } } -void * +static void * _objcl_invoke_method (id self_, NSMethodSignature *signature, SEL selector, @@ -103,13 +81,55 @@ _objcl_invoke_method (id self_, { int i; NSInvocation *invocation; - id result = NULL; + void *result_ptr = NULL; + OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); + const char *type = [signature methodReturnType]; + + result->type = malloc (strlen (type) + 1); + strcpy (result->type, type); if (signature == NULL) { return NULL; } + + switch (type[0]) + { + case _C_ID: result_ptr = &(result->data.id_val); break; + case _C_CLASS: result_ptr = &result->data.id_val; break; + case _C_SEL: result_ptr = &result->data.sel_val; break; + case _C_CHR: result_ptr = &result->data.char_val; break; + case _C_UCHR: result_ptr = &result->data.char_val; break; + case _C_SHT: result_ptr = &result->data.short_val; break; + case _C_USHT: result_ptr = &result->data.short_val; break; + case _C_INT: result_ptr = &result->data.int_val; break; + case _C_UINT: result_ptr = &result->data.int_val; break; + case _C_LNG: result_ptr = &result->data.long_val; break; + case _C_ULNG: result_ptr = &result->data.long_val; break; + case _C_LNG_LNG: result_ptr = &result->data.long_long_val; break; + case _C_ULNG_LNG: result_ptr = &result->data.long_long_val; break; + case _C_FLT: result_ptr = &result->data.float_val; break; + case _C_DBL: result_ptr = &result->data.double_val; break; + case _C_BOOL: result_ptr = &result->data.bool_val; break; + case _C_PTR: result_ptr = &result->data.ptr_val; break; + case _C_CHARPTR: result_ptr = &result->data.charptr_val; break; + /* + case _C_BFLD: result_ptr = &result->data._val; break; + case _C_VOID: result_ptr = &result->data._val; break; + case _C_UNDEF: result_ptr = &result->data._val; break; + case _C_ATOM: result_ptr = &result->data._val; break; + case _C_ARY_B: result_ptr = &result->data._val; break; + case _C_ARY_E: result_ptr = &result->data._val; break; + case _C_UNION_B: result_ptr = &result->data._val; break; + case _C_UNION_E: result_ptr = &result->data._val; break; + case _C_STRUCT_B: result_ptr = &result->data._val; break; + case _C_STRUCT_E: result_ptr = &result->data._val; break; + case _C_VECTOR: result_ptr = &result->data._val; break; + case _C_COMPLEX: result_ptr = &result->data._val; break; + */ + } + invocation = [NSInvocation invocationWithMethodSignature: signature]; [invocation setTarget: self_]; [invocation setSelector: selector]; @@ -117,10 +137,14 @@ _objcl_invoke_method (id self_, for (i = 0; i < argc; i++) { const char* type = [signature getArgumentTypeAtIndex: (i + 2)]; - NSLog (@"Argument %d: type %s.", i, type); - void *buffer = malloc (objc_sizeof_type (type)); - _objcl_get_arg_pointer (buffer, type, arglist); + OBJCL_OBJ_DATA arg = va_arg (arglist, OBJCL_OBJ_DATA); + _objcl_get_arg_pointer (buffer, arg); + + if (type[0] == '#') + NSLog (@"Argument %d: %@ (type %s)", i, buffer, type); + else + NSLog (@"Argument %d: type %s.", i, type); [invocation setArgument: buffer atIndex: (i + 2)]; @@ -132,16 +156,17 @@ _objcl_invoke_method (id self_, NSLog (@"Invoking %@ on %@.", invocation, self_); [invocation invoke]; NSLog (@"Fetching return value."); - [invocation getReturnValue: &result]; - NSLog (@"Returning: %@", result); + [invocation getReturnValue: result_ptr]; + if (result->type[0] == '#') + NSLog (@"Returning: %@", result->data.id_val); return result; } void * -objcl_invoke_instance_method (void *receiver, - char *const method_name, +objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver, + const char *method_name, int argc, ...) { @@ -151,7 +176,9 @@ objcl_invoke_instance_method (void *receiver, NSMethodSignature *signature; void *result; - self_ = (id) receiver; + assert (receiver->type[0] == '#' + || receiver->type[0] == '@'); + self_ = receiver->data.id_val; selector = NSSelectorFromString ([NSString stringWithUTF8String: method_name]); @@ -166,8 +193,8 @@ objcl_invoke_instance_method (void *receiver, void * -objcl_invoke_class_method (void *class, - char *const method_name, +objcl_invoke_class_method (OBJCL_OBJ_DATA class, + const char *method_name, int argc, ...) { @@ -177,7 +204,9 @@ objcl_invoke_class_method (void *class, NSMethodSignature *signature; void *result; - self_ = (id) class; + assert (class->type[0] == '#' + || class->type[0] == '@'); + self_ = class->data.id_val; selector = NSSelectorFromString ([NSString stringWithUTF8String: method_name]); @@ -192,8 +221,16 @@ objcl_invoke_class_method (void *class, void * -objcl_find_class (char *const class_name) +objcl_find_class (const char *class_name) { - return NSClassFromString ([NSString stringWithUTF8String: class_name]); -} + id class = + NSClassFromString ([NSString stringWithUTF8String: class_name]); + OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); + const char *const typespec = "#8@0:4"; + + result->type = malloc (strlen (typespec) + 1); + strcpy (result->type, typespec); + result->data.id_val = class; + return result; +} @@ -8,33 +8,244 @@ (defctype pointer-array :pointer "An array of void pointers.") -#+nil -(defmethod translate-to-foreign ((vector vector) - (type (eql 'pointer-array))) - (foreign-alloc :pointer - :count (length vector) - :null-terminated-p nil - :initial-contents vector)) -#+nil -(defmethod translate-from-foreign (foreign-value - (type (eql 'pointer-array))) - ) +(deftype c-pointer () + '(satisfies pointerp)) + + +(defclass c-pointer-wrapper () + ((pointer :type c-pointer + :accessor pointer-to + :initarg :pointer))) + + +(defclass objc-selector (c-pointer-wrapper) ()) +(defclass objc-id (c-pointer-wrapper) ()) +(defclass objc-class (c-pointer-wrapper) ()) + + +(defcunion obj-data-union + (id-val :pointer) + (sel-val :pointer) + (char-val :char) + (short-val :short) + (int-val :int) + (long-val :long) + (long-long-val :long-long) + (float-val :float) + (double-val :double) + (bool-val :boolean) + (charptr-val :pointer) + (ptr-val :pointer)) + + +(defcstruct obj-data + (type :string) + (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-free obj-data)) (defcfun "objcl_initialise_runtime" :void) (defcfun "objcl_shutdown_runtime" :void) -(defcfun "objcl_invoke_instance_method" :pointer - (receiver :pointer) +(defcfun ("objcl_invoke_instance_method" + %objcl-invoke-instance-method) obj-data + (receiver obj-data) (method-name :string) (argc :int) &rest) -(defcfun "objcl_invoke_class_method" :pointer - (receiver :void) +(defcfun "objcl_invoke_class_method" obj-data + (receiver obj-data) (method-name :string) (argc :int) &rest) -(defcfun "objcl_find_class" :pointer +(defcfun ("objcl_find_class" %objcl-find-class) :pointer (class-name :string)) + + +;;; Copied from objc-api.h +;;; Probably ought to be generated by C code at initialisation time. +(defparameter *objcl-api-type-names* + '((id . #\@) + (class . #\#) + (sel . #\:) + (chr . #\c) + (uchr . #\C) + (sht . #\s) + (usht . #\S) + (int . #\i) + (uint . #\I) + (lng . #\l) + (ulng . #\L) + (lng-lng . #\q) + (ulng-lng . #\Q) + (flt . #\f) + (dbl . #\d) + (bfld . #\b) + (bool . #\B) + (void . #\v) + (undef . #\?) + (ptr . #\^) + (charptr . #\*) + (atom . #\%) + (ary-b . #\[) + (ary-e . #\]) + (union-b . #\() + (union-e . #\)) + (struct-b . #\{) + (struct-e . #\}) + (vector . #\!) + (complex . #\j))) + + +(defparameter *objcl-data-map* + '((id . id-val) + (class . id-val) + (sel . sel-val) + (chr . char-val) + (uchr . char-val) + (sht . short-val) + (usht . short-val) + (int . int-val) + (uint . int-val) + (lng . long-val) + (ulng . long-val) + (lng-lng . long-long-val) + (ulng-lng . long-long-val) + (flt . float-val) + (dbl . double-val) + (bool . bool-val) + (ptr . ptr-val) + (charptr . charptr-val))) + + +(defparameter *objcl-type-map* + '((id . objc-id) + (class . objc-class) + (sel . objc-selector) + (chr . character) + (int . integer) + (uint . integer) + (lng . integer) + (ulng . integer) + (sht . integer) + (usht . integer) + (lng-lng . integer) + (ulng-lng . integer) + (flt . single-float) + (dbl . double-float) + (bool . boolean) + (ptr . c-pointer) + (charptr . string))) + +(defparameter *objcl-c-type-map* + '((id . :pointer) + (class . :pointer) + (sel . :pointer) + (chr . :char) + (int . :int) + (uint . :unsigned-int) + (lng . :long) + (ulng . :unsigned-long) + (sht . :short) + (usht . :unsigned-short) + (lng-lng . :long-long) + (ulng-lng . :unsigned-long-long) + (flt . :float) + (dbl . :double) + (bool . :boolean) + (ptr . :pointer) + (charptr . :pointer))) + + +(defun apply-macro (macro-name arg &rest args) + "Because FOREIGN-FUNCALL is a macro. Why, oh why is this?" + (funcall + (compile nil + `(lambda () + (,macro-name ,@(butlast (cons arg args)) + ,@(car (last (cons arg args)))))))) + + +(defun lisp-value->type-name (value) + (car (rassoc-if #'(lambda (type) + (typep value type)) + *objcl-type-map*))) + +(defun type-name->lisp-type (type-name) + (cdr (assoc type-name *objcl-type-map*))) + +(defun type-name->slot-name (type-name) + (cdr (assoc type-name *objcl-data-map*))) + +(defun type-name->type-id (type-name) + (string (cdr (assoc type-name *objcl-api-type-names*)))) + +(defun type-id->type-name (type-id) + (car (rassoc (char type-id 0) *objcl-api-type-names*))) + +(defun type-name->c-type (type-name) + (cdr (assoc type-name *objcl-c-type-map*))) + +(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)) + arg))) + arglist)) + + +(defun objcl-invoke-instance-method (receiver method-name &rest args) + (let* ((arglist (arglist-intersperse-types + (mapcar #'lisp->obj-data args))) + (return-value (apply-macro '%objcl-invoke-instance-method + (lisp->obj-data receiver) + method-name + (length args) + arglist))) + (prog1 + (obj-data->lisp return-value) + (dealloc-obj-data return-value)))) + + +(defun lisp->obj-data (value) + (let ((obj-data (foreign-alloc 'obj-data)) + (type-name (lisp-value->type-name value))) + (with-foreign-slots ((type data) obj-data obj-data) + (setf (foreign-slot-value data + 'obj-data-union + (type-name->slot-name type-name)) + (typecase value + ((or objc-id objc-class objc-selector) + (pointer-to value)) + (otherwise value))) + (setf type + (type-name->type-id type-name))) + 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)) + (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) + (make-instance lisp-type :pointer value)) + (otherwise value))))) + + +(defun objcl-find-class (class-name) + (let ((obj-data (%objcl-find-class class-name))) + (prog1 + (obj-data->lisp obj-data) + (dealloc-obj-data obj-data)))) |