summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Lisp/constant-data.lisp4
-rw-r--r--Lisp/data-types.lisp2
-rw-r--r--Lisp/defpackage.lisp1
-rw-r--r--Lisp/libobjcl.lisp28
-rw-r--r--Lisp/memory-management.lisp4
-rw-r--r--Lisp/method-invocation.lisp80
-rw-r--r--Lisp/utilities.lisp6
-rw-r--r--Objective-C/libobjcl.m5
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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 16:10:11 +0000