From d9ac18064cf40f6fbbb09ec8ca74de212c012326 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Sat, 15 Sep 2007 23:52:00 +0200 Subject: Reimplement PRIMITIVE-INVOKE and rename the old version UNSAFE-PRIMITIVE-INVOKE. darcs-hash:a941bade2677db3d5773c20ffda171c7c9721a98 --- Lisp/constant-data.lisp | 4 +++ Lisp/data-types.lisp | 2 +- Lisp/defpackage.lisp | 1 + Lisp/libobjcl.lisp | 28 ++++++++++++---- Lisp/memory-management.lisp | 4 +-- Lisp/method-invocation.lisp | 80 +++++++++++++++++++++++++++++++++++++++++---- Lisp/utilities.lisp | 6 ++-- Objective-C/libobjcl.m | 5 +++ 8 files changed, 112 insertions(+), 18 deletions(-) diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp index 29169de..efda456 100644 --- a/Lisp/constant-data.lisp +++ b/Lisp/constant-data.lisp @@ -108,6 +108,10 @@ (typep value type)) *objcl-type-map*))) +(declaim (ftype (function (symbol) symbol) lisp-type->type-name)) +(defun lisp-type->type-name (lisp-type) + (cdr (rassoc lisp-type *objcl-type-map*))) + (declaim (ftype (function (symbol) symbol) type-name->lisp-type)) (defun type-name->lisp-type (type-name) (cdr (assoc type-name *objcl-type-map*))) diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index 6f66e8c..c757070 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -42,7 +42,7 @@ ((pointer :type c-pointer :reader pointer-to :initarg :pointer - :initform nil))) + :initform (cffi:null-pointer)))) (defclass selector (c-pointer-wrapper) () diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp index c6d65a0..46114d5 100644 --- a/Lisp/defpackage.lisp +++ b/Lisp/defpackage.lisp @@ -1,6 +1,7 @@ (defpackage #:mulk.objective-cl (:nicknames #:objcl #:objective-cl #:mulk.objcl) (:use #:cl #:cffi #:split-sequence) + (:shadow #:foreign-pointer) ;; Functions (:export #:initialise-runtime diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index d5d7379..d1efe53 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -32,6 +32,15 @@ (argc :int) &rest) +(defcfun ("objcl_invoke_with_types" %objcl-invoke-with-types) :pointer + (receiver (:pointer :void)) + (method_selector (:pointer :void)) + (argc :int) + (return_typespec (:pointer :char)) + (arg_typespecs (:pointer (:pointer :char))) + (return_value (:pointer :void)) + (argv (:pointer (:pointer :void)))) + (defcfun ("objcl_find_class" %objcl-find-class) :pointer (class-name :string)) @@ -175,7 +184,7 @@ conventional case for namespace identifiers in Objective C." (declaim (ftype (function (string) (or null objc-class)) find-objc-class-by-name)) (defun find-objc-class-by-name (class-name) - (with-foreign-objects ((obj-data (%objcl-find-class class-name))) + (with-obj-data-values ((obj-data (%objcl-find-class class-name))) (if (null-pointer-p (foreign-slot-value (foreign-slot-value obj-data 'obj-data 'data) 'obj-data-union @@ -187,7 +196,7 @@ conventional case for namespace identifiers in Objective C." (declaim (ftype (function (string) (or null selector)) find-selector-by-name)) (defun find-selector-by-name (selector-name) - (with-foreign-objects ((obj-data (%objcl-find-selector selector-name))) + (with-obj-data-values ((obj-data (%objcl-find-selector selector-name))) (if (null-pointer-p (foreign-slot-value (foreign-slot-value obj-data 'obj-data 'data) 'obj-data-union @@ -285,9 +294,10 @@ by which __invoke__ converts its arguments into a *message name*. ;; to use CHECK-TYPE in the method body. (unless (find-class 'foreign-pointer nil) (setf (find-class 'foreign-pointer nil) - (class-of (make-pointer 0)))) - (deftype foreign-pointer () - '(satisfies cffi:pointerp))) + (class-of (make-pointer 0))) + (ignore-errors + (deftype foreign-pointer () + '(satisfies cffi:pointerp))))) (declaim (ftype (function ((or selector string symbol list)) selector) @@ -380,7 +390,13 @@ If *selector-designator* is a __selector__, it is simply returned. (type-name->slot-name type-name))))) (case lisp-type ((id objc-class selector exception) - (make-instance lisp-type :pointer value)) + #-openmcl (make-instance lisp-type :pointer value) + #+openmcl (if (eq 'objc-class lisp-type) + ;; God help me. + (change-class (make-instance 'c-pointer-wrapper + :pointer value) + lisp-type) + (make-instance lisp-type :pointer value))) ((string) (foreign-string-to-lisp value)) (otherwise value))))) diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp index 4dec98e..849e9d0 100644 --- a/Lisp/memory-management.lisp +++ b/Lisp/memory-management.lisp @@ -30,7 +30,7 @@ :incomplete) (let ((new-obj (call-next-method))) (unless *skip-retaining* - (primitive-invoke new-obj "retain" :id)) + (unsafe-primitive-invoke new-obj "retain" id)) (unless *skip-finalization* ;; We only put the new object into the hash ;; table if it is a regular wrapper object @@ -56,7 +56,7 @@ (*skip-retaining* t)) (make-instance saved-type :pointer saved-pointer)))) - (primitive-invoke temp "release" :id)))) + (unsafe-primitive-invoke temp "release" id)))) (trivial-garbage:finalize new-obj #'finalizer)))) new-obj)) (t obj)))) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 9d5eada..43a3365 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -147,8 +147,8 @@ Returns: *result* --- the return value of the method invocation. (dealloc-objc-arglist objc-arglist))))) -(defmacro primitive-invoke (receiver method-name return-type &rest args) - (let ((real-return-type (if (member return-type '(:id :class :exception)) +(defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args) + (let ((real-return-type (if (member return-type '(id class exception)) :pointer return-type)) (real-receiver (gensym)) @@ -169,18 +169,86 @@ Returns: *result* --- the return value of the method invocation. (list :pointer (pointer-to ,real-selector)) objc-arglist (list ,real-return-type))))) - ,(if (member return-type '(:id :class :exception)) + ,(if (member return-type '(id class exception)) `(let (,@(when (constructor-name-p (selector-name selector)) `((*skip-retaining* t)))) (make-instance ',(case return-type - ((:id) 'id) - ((:class) 'objc-class) - ((:exception) 'exception)) + ((id) 'id) + ((class) 'objc-class) + ((exception) 'exception)) :pointer return-value)) `return-value)) (dealloc-objc-arglist objc-arglist))))))) +(defun primitive-invoke (receiver method-name return-type &rest args) + (let ((return-c-type (case return-type + ((id class exception selector) :pointer) + (otherwise return-type))) + (return-type-cell (cffi:foreign-string-alloc + (type-name->type-id return-type))) + (selector (selector method-name))) + (cffi:with-foreign-objects ((arg-types '(:pointer :char) (length args)) + (objc-args '(:pointer :void) (length args)) + (return-value-cell return-c-type)) + (flet ((ad-hoc-arglist->objc-arglist! (args) + (loop for arg in args + for i from 0 + do (let* ((type-name (lisp-value->type-name arg)) + #+(or) + (cffi-type (type-name->lisp-type type-name))) + (setf (cffi:mem-aref objc-args '(:pointer :void) i) + (typecase arg + #+(or) + (c-pointer + ;; Assume that arg points to a struct, + ;; and that the method wants a copy of + ;; that struct, not the pointer itself. + arg) + (t (cffi:foreign-alloc + #+(or) cffi-type + :pointer + :initial-element (typecase arg + (c-pointer-wrapper + (print (pointer-to arg))) + (t arg)))))) + (setf (cffi:mem-aref arg-types '(:pointer :char) i) + (cffi:foreign-string-alloc + (typecase arg + #+(or) (c-pointer "{?=}") + (t (type-name->type-id type-name)))))))) + (dealloc-ad-hoc-objc-arglist () + (dotimes (i (length args)) + (cffi:foreign-free + (cffi:mem-aref objc-args '(:pointer :void) i)) + (cffi:foreign-string-free + (cffi:mem-aref arg-types '(:pointer :char) i))))) + (ad-hoc-arglist->objc-arglist! args) + (unwind-protect + (let ((error-cell + (%objcl-invoke-with-types (pointer-to receiver) + (pointer-to selector) + (length args) + return-type-cell + arg-types + return-value-cell + objc-args))) + (unless (cffi:null-pointer-p error-cell) + (error (make-instance 'exception :pointer error-cell))) + (case return-type + ((id class exception selector) + (let ((*skip-retaining* + (or *skip-retaining* + (constructor-name-p (selector-name selector))))) + (make-instance return-type + :pointer (cffi:mem-ref return-value-cell + return-c-type)))) + (otherwise (cffi:mem-ref return-value-cell + return-c-type)))) + (dealloc-ad-hoc-objc-arglist) + (foreign-string-free return-type-cell)))))) + + ;;; (@* "Helper functions") (defun arglist->objc-arglist (arglist) (arglist-intersperse-types (mapcar #'lisp->obj-data arglist))) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index be6f8b4..405cacf 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -96,8 +96,8 @@ (defmethod print-object ((object id) stream) (print-unreadable-object (object stream) (format stream "~A `~A' {~X}" - (objcl-class-name (primitive-invoke object "class" :id)) - (primitive-invoke (primitive-invoke object "description" :id) + (objcl-class-name (primitive-invoke object "class" 'id)) + (primitive-invoke (primitive-invoke object "description" 'id) "UTF8String" :string) (primitive-invoke object "hash" :unsigned-int)))) @@ -121,6 +121,6 @@ (print-unreadable-object (exception stream) (format stream "~S ~A {~X}" 'exception - (primitive-invoke (primitive-invoke exception "name" :id) + (primitive-invoke (primitive-invoke exception "name" 'id) "UTF8String" :string) (primitive-invoke exception "hash" :unsigned-int)))) diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m index d89693a..7dc5de2 100644 --- a/Objective-C/libobjcl.m +++ b/Objective-C/libobjcl.m @@ -299,6 +299,11 @@ objcl_invoke_with_types (void *receiver, method = objc_msg_lookup (receiver, method_selector); #endif + if (method == NULL) + [[NSException exceptionWithName: @"MLKNoApplicableMethod" + reason: @"Tried to call a non-existent method." + userInfo: nil] raise]; + return_type = objcl_pyobjc_signature_to_ffi_return_type (return_typespec); arg_types[0] = id_type; arg_types[1] = sel_type; -- cgit v1.2.3