From 53705da2ac13bfab2c9133f46e5bebcff0306cc8 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sun, 17 Feb 2008 18:19:25 +0100
Subject: Improve the CLASS-DEFINITION tests.

darcs-hash:9f7b9a58aab5c7dfed8e9df10c41381935bf772c
---
 Lisp/libobjcl.lisp |  5 ++++-
 Lisp/tests.lisp    | 47 +++++++++++++++++++++++++++++++++++++++--------
 2 files changed, 43 insertions(+), 9 deletions(-)

(limited to 'Lisp')

diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index e9e5f3c..79734cc 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -174,7 +174,7 @@
 (defcfun ("objcl_object_backed_by_lisp_class_p"
           %objcl-object-backed-by-lisp-class-p)
     :int
-  (class :pointer))
+  (instance :pointer))
 
 (defcvar *objcl-current-exception-lock* :pointer)
 (defcvar *objcl-current-exception* :pointer)
@@ -923,3 +923,6 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
 
 (defun objcl-object-backed-by-lisp-class-p/pointer (object-ptr)
   (not (zerop (%objcl-object-backed-by-lisp-class-p object-ptr))))
+
+(defun objcl-object-backed-by-lisp-class-p (instance)
+  (objcl-object-backed-by-lisp-class-p/pointer (pointer-to instance)))
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 1dffac0..d9d116b 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -24,7 +24,8 @@
                           #:inout #:const #:parse-typespec #:objective-c-class
                           #:bit-field #:opaque #:bycopy #:byref
                           #:primitive-invoke #:print-typespec-to-string
-                          #:nominally #:find-objc-meta-class))
+                          #:nominally #:find-objc-meta-class
+                          #:objcl-object-backed-by-lisp-class-p))
 (in-package #:mulk.objective-cl.tests)
 (in-root-suite)
 
@@ -371,22 +372,52 @@
                                   (list (find-objc-class "NSObject"))
                                   :direct-slots '((:name foos
                                                    :type list
-                                                   :initform nil
                                                    :initargs (:foos))
                                                   (:name foo-count
                                                    :foreign-type (:int ())))
                                   :metaclass (find-objc-meta-class "NSObject"))))
+
+    ;; Sanity checks.
     (is (typep class 'objective-c-class))
     (setq instance (is (invoke (invoke class 'alloc) 'init)))
+
+    ;; Object identity preservation.
+    (is (eql instance
+             (invoke instance 'self)))
+
     #+(or) (setq instance (is (invoke class :string-with-u-t-f-8-string "Mulk.")))
-    #+(or) (is (typep instance class))
-    #+(or)
-    (is (objc-equal instance
-                    (invoke (find-objc-class 'ns-string)
-                            :string-with-u-t-f-8-string "Mulk.")))
+    #+(or) (is (objc-equal instance
+                           (invoke (find-objc-class 'ns-string)
+                                   :string-with-u-t-f-8-string "Mulk.")))
+
+    ;; FIXME: What's wrong with the following line?  It makes CMUCL
+    ;; throw weird errors.
+    #+(or) (is (typep instance class-name))
+
+    ;; Slot initialisation.
+    (is (not (slot-boundp instance 'foos)))
+    (is (slot-boundp instance 'foo-count)) ;foreign slots are always SLOT-BOUNDP
+
+    ;; Slot handling.
     (setf (slot-value instance 'foos) '(a b c))
     (setf (slot-value instance 'foo-count) 3)
+
+    (is (slot-boundp instance 'foos))
+
+    ;; Native slots.
+    (is (objcl-object-backed-by-lisp-class-p instance))
+
     (is (equal (slot-value instance 'foos)
                (slot-value (invoke instance 'self) 'foos)))
+    (is (typep (slot-value (invoke instance 'self) 'foos)
+               'list))
+    (is (equal (slot-value (invoke instance 'self) 'foos)
+               '(a b c)))
+
+    ;; Foreign slots.
     (is (equal (slot-value instance 'foo-count)
-               (slot-value (invoke instance 'self) 'foo-count)))))
+               (slot-value (invoke instance 'self) 'foo-count)))
+    (is (typep (slot-value (invoke instance 'self) 'foo-count)
+               'integer))
+    (is (equal (slot-value (invoke instance 'self) 'foo-count)
+               3))))
-- 
cgit v1.2.3