diff options
Diffstat (limited to 'objcl.lisp')
| -rw-r--r-- | objcl.lisp | 243 |
1 files changed, 227 insertions, 16 deletions
@@ -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)))) |