summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-08-12 19:41:02 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-08-12 19:41:02 +0200
commit048c5db4f7a732376f0a4526502e012a0f29e0c7 (patch)
tree69a9bf3e80fd9e633cfeaf925e4ab5379bed21d2
parentdac89d30fa1e9eabcde3d522a6c5ca0471cce3b1 (diff)
Code cleanup, fix a couple of memory leaks.
darcs-hash:629e2764a4ce319c9a7d9bc3a22e6f254633c73f
-rw-r--r--Lisp/method-invocation.lisp63
-rw-r--r--Lisp/tests.lisp18
-rw-r--r--Lisp/type-conversion.lisp4
3 files changed, 44 insertions, 41 deletions
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 4de8dc6..95784fa 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -121,45 +121,30 @@ Returns: *result* --- the return value of the method invocation.
(check-type receiver (or id objc-class exception)
"an Objective C instance (ID, OBJC-CLASS or EXCEPTION)")
- (let* ((arglist (arglist-intersperse-types
- (mapcar #'lisp->obj-data args)))
- (return-value (apply-macro '%objcl-invoke-method
- (lisp->obj-data receiver)
- method-name
- (length args)
- arglist)))
- (when *trace-method-calls*
- (format t "~&Invoking [~A].~%" method-name))
- (unwind-protect
- (let ((value
- (let ((*skip-retaining* (or *skip-retaining*
- (constructor-name-p method-name))))
- (obj-data->lisp return-value))))
- (if (typep value 'condition)
- (cerror "Return NIL from OBJCL-INVOKE-METHOD" value)
- value))
- (dealloc-obj-data return-value))))
-
-
-#+nil
-(defun invoke-instance-method-by-name (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)))
- (format t "~&Invoking <~A>.~%" method-name)
- (unwind-protect
- (let ((value
- (let ((*skip-retaining* (or *skip-retaining*
- (constructor-name-p method-name))))
- (obj-data->lisp return-value))))
- (if (typep value 'condition)
- (cerror "Return NIL from OBJCL-INVOKE-INSTANCE-METHOD" value)
- value))
- (dealloc-obj-data return-value))))
+ (when *trace-method-calls*
+ (format t "~&Invoking [~A].~%" method-name))
+ (flet ((convert/signal (foreign-value)
+ ;; Convert a foreign value into a Lisp value. If the value
+ ;; to be converted represents an exception, signal it instead
+ ;; of returning it as a value.
+ (let ((lisp-value (obj-data->lisp foreign-value)))
+ (if (typep lisp-value 'condition)
+ (cerror "Return NIL from OBJCL-INVOKE-METHOD." lisp-value)
+ lisp-value))))
+ (let* ((objc-args (mapcar #'lisp->obj-data args))
+ (arglist (arglist-intersperse-types objc-args)))
+ (unwind-protect
+ (with-foreign-conversion ((objc-receiver receiver))
+ (with-foreign-objects ((return-value
+ (apply-macro '%objcl-invoke-method
+ objc-receiver
+ method-name
+ (length args)
+ arglist)))
+ (let ((*skip-retaining* (or *skip-retaining*
+ (constructor-name-p method-name))))
+ (convert/signal return-value))))
+ (mapc #'dealloc-obj-data objc-args)))))
;;; (@* "Helper functions")
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 0cc7379..28c4c9f 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -18,6 +18,12 @@
())
+(defrandom-instance double objective-cl
+ (if (zerop (random 2))
+ (random most-positive-double-float)
+ (- (random (abs most-negative-double-float)))))
+
+
(deftestsuite base-functions (objective-cl)
()
(:equality-test #'objc-equal)
@@ -72,6 +78,18 @@
((ensure (typep [NSString isEqual: [NSObject self]] 'boolean)))))
+(deftestsuite numbers (objective-cl)
+ ()
+ (:equality-test #'objc-equal)
+ (:tests
+ ((ensure-same [[NSDecimalNumber
+ decimalNumberWithString:
+ [NSString stringWithCString:
+ "-12345"]]
+ doubleValue]
+ -12345d0))))
+
+
(deftestsuite exception-handling (objective-cl)
()
(:equality-test #'objc-equal)
diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp
index a11a668..bba40e7 100644
--- a/Lisp/type-conversion.lisp
+++ b/Lisp/type-conversion.lisp
@@ -12,7 +12,7 @@
(typecase value
((or id objc-class selector exception)
(pointer-to value))
- (string (foreign-string-alloc value))
+ (string (foreign-string-alloc value))
(otherwise value)))
(setf type
(foreign-string-alloc (type-name->type-id type-name))))
@@ -31,7 +31,7 @@
(case lisp-type
((id objc-class selector exception)
(make-instance lisp-type :pointer value))
- ((string) (foreign-string-to-lisp value))
+ ((string) (foreign-string-to-lisp value))
(otherwise value)))))