summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-17 15:48:50 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-17 15:48:50 +0100
commitf8f1ca8ef2e4d5daee1f43cd6c8a0f18fec955ba (patch)
tree940eb307161e5982935b3689c1f4be4863c120fe /Lisp
parent3dc931431a122de70b9c1d2d7b7bd7becfc46d7f (diff)
Add a class definition test to the test suite.
darcs-hash:d6774028b28a45e5983c6100e2dc44b8eccb2dcf
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/tests.lisp45
1 files changed, 44 insertions, 1 deletions
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 96d15a9..8c17ef5 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -24,7 +24,7 @@
#:inout #:const #:parse-typespec #:objective-c-class
#:bit-field #:opaque #:bycopy #:byref
#:primitive-invoke #:print-typespec-to-string
- #:nominally))
+ #:nominally #:find-objc-meta-class))
(in-package #:mulk.objective-cl.tests)
(in-root-suite)
@@ -345,3 +345,46 @@
:with-object (invoke
(find-objc-class 'ns-object)
'self)))))
+
+
+(defvar *class-counter* 0)
+
+
+(deftest class-definition ()
+ ;; FIXME: This test is broken.
+ ;;
+ ;; Reason:
+ ;;
+ ;; OBJECTIVE-CL> (invoke-by-name
+ ;; (invoke #<EXCEPTION NSGenericException {845E8E0}> 'reason)
+ ;; "UTF8String")
+ ;; "subclass MLKTestString0(instance) should override length"
+ ;;
+ (let ((class-name (intern (format nil "~A~D"
+ '#:mlk-test-string
+ (incf *class-counter*))))
+ (class nil)
+ (instance nil))
+ (setq class
+ (is (c2mop:ensure-class class-name
+ :direct-superclasses
+ (list (find-objc-class "NSString"))
+ :direct-slots '((:name foos
+ :type list
+ :initform nil
+ :initargs (:foos))
+ (:name foo-count
+ :foreign-type (:int ())))
+ :metaclass (find-objc-meta-class "NSObject"))))
+ (is (typep class 'objective-c-class))
+ (setq instance (is (invoke class :string-with-u-t-f-8-string "Mulk.")))
+ #+nil (is (typep instance class))
+ (is (objc-equal instance
+ (invoke (find-objc-class 'ns-string)
+ :string-with-u-t-f-8-string "Mulk.")))
+ (setf (slot-value instance 'foos) '(a b c))
+ (setf (slot-value instance 'foo-count) 3)
+ (is (equal (slot-value instance 'foos)
+ (slot-value (invoke instance 'self) 'foos)))
+ (is (equal (slot-value instance 'foo-count)
+ (slot-value (invoke instance 'self) 'foo-count)))))