From c1c2795b7fbfc9ff117f95b86668e6f4bd6ca733 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Mon, 21 Apr 2003 12:20:33 +0000
Subject: [PATCH] Begin adding 'manual' defclass tests,

---
 ansi-tests/defclass-01.lsp  | 171 ++++++++++++++++++++++++++++++++++++
 ansi-tests/defclass-aux.lsp |  13 ++-
 ansi-tests/defclass.lsp     |   3 -
 ansi-tests/load-objects.lsp |   1 +
 4 files changed, 183 insertions(+), 5 deletions(-)
 create mode 100644 ansi-tests/defclass-01.lsp

diff --git a/ansi-tests/defclass-01.lsp b/ansi-tests/defclass-01.lsp
new file mode 100644
index 00000000..e36cc89c
--- /dev/null
+++ b/ansi-tests/defclass-01.lsp
@@ -0,0 +1,171 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Apr 20 20:58:54 2003
+;;;; Contains: Tests for DEFCLASS, part 01
+
+
+(in-package :cl-test)
+
+;;; I've decided to write some 'manual' tests, then refactor these back
+;;; to the automatic mechanisms I'll put into defclass-aux.lsp after
+;;; I have a better understanding of the object system
+
+(defclass class-01 () (s1 s2 s3))
+
+(deftest class-01.1
+  (notnot-mv (typep (make-instance 'class-01) 'class-01))
+  t)
+
+(deftest class-01.2
+  (notnot-mv (typep (make-instance (find-class 'class-01)) 'class-01))
+  t)
+
+(deftest class-01.3
+  (let ((c (make-instance 'class-01)))
+    (values
+     (setf (slot-value c 's1) 12)
+     (setf (slot-value c 's2) 18)
+     (setf (slot-value c 's3) 27)
+     (loop for s in '(s1 s2 s3) collect (slot-value c s))))
+  12 18 27
+  (12 18 27))
+
+;;;;
+
+(defclass class-02 () ((s1) (s2) (s3)))
+  
+(deftest class-02.1
+  (notnot-mv (typep (make-instance 'class-02) 'class-02))
+  t)
+
+(deftest class-02.2
+  (notnot-mv (typep (make-instance (find-class 'class-02)) 'class-02))
+  t)
+
+(deftest class-02.3
+  (let ((c (make-instance 'class-02)))
+    (values
+     (setf (slot-value c 's1) 12)
+     (setf (slot-value c 's2) 18)
+     (setf (slot-value c 's3) 27)
+     (loop for s in '(s1 s2 s3) collect (slot-value c s))))
+  12 18 27
+  (12 18 27))
+
+;;;;
+
+(defclass class-03 () ((s1 :type integer) (s2 :type t) (s3 :type fixnum)))
+  
+(deftest class-03.1
+  (notnot-mv (typep (make-instance 'class-03) 'class-03))
+  t)
+
+(deftest class-03.2
+  (notnot-mv (typep (make-instance (find-class 'class-03)) 'class-03))
+  t)
+
+(deftest class-03.3
+  (let ((c (make-instance 'class-03)))
+    (values
+     (setf (slot-value c 's1) 12)
+     (setf (slot-value c 's2) 'a)
+     (setf (slot-value c 's3) 27)
+     (loop for s in '(s1 s2 s3) collect (slot-value c s))))
+  12 a 27
+  (12 a 27))
+
+;;;;
+
+(defclass class-04 () ((s1 :reader s1-r) (s2 :writer s2-w) (s3 :accessor s3-a)))
+
+;;; Readers, writers, and accessors
+(deftest class-04.1
+  (let ((c (make-instance 'class-04)))
+    (values
+     (setf (slot-value c 's1) 'a)
+     (setf (slot-value c 's2) 'b)
+     (setf (slot-value c 's3) 'c)
+     (s1-r c)
+     (slot-value c 's2)
+     (s2-w 'd c)
+     (slot-value c 's2)
+     (s3-a c)
+     (setf (s3-a c) 'e)
+     (slot-value c 's3)
+     (s3-a c)))
+  a b c a b d d c e e e)
+
+;;;;
+
+(defclass class-05 () (s1 (s2 :allocation :instance) (s3 :allocation :class)))
+  
+(deftest class-05.1
+  (let ((c1 (make-instance 'class-05))
+	(c2 (make-instance 'class-05)))
+    (values
+     (not (eql c1 c2))
+     (list
+      (setf (slot-value c1 's1) 12)
+      (setf (slot-value c2 's1) 17)
+      (slot-value c1 's1)
+      (slot-value c2 's1))
+     (list
+      (setf (slot-value c1 's2) 'a)
+      (setf (slot-value c2 's2) 'b)
+      (slot-value c1 's2)
+      (slot-value c2 's2))
+     (list
+      (setf (slot-value c1 's3) 'x)
+      (slot-value c1 's3)
+      (slot-value c2 's3)
+      (setf (slot-value c2 's3) 'y)
+      (slot-value c1 's3)
+      (slot-value c2 's3)
+      (setf (slot-value c1 's3) 'z)
+      (slot-value c1 's3)
+      (slot-value c2 's3))
+     (slot-value (make-instance 'class-05) 's3)))
+  t
+  (12 17 12 17)
+  (a b a b)
+  (x x x y y y z z z)
+  z)
+
+;;;;
+
+(defclass class-06 () ((s1 :reader s1-r1 :reader s1-r2 :writer s1-w1 :writer s1-w2)))
+(defclass class-06a () ((s1 :reader s1-r1) s3))
+
+(deftest class-06.1
+  (let ((c (make-instance 'class-06)))
+    (values
+     (setf (slot-value c 's1) 'x)
+     (slot-value c 's1)
+     (s1-r1 c)
+     (s1-r2 c)
+     (s1-w1 'y c)
+     (slot-value c 's1)
+     (s1-r1 c)
+     (s1-r2 c)
+     (s1-w2 'z c)
+     (slot-value c 's1)
+     (s1-r1 c)
+     (s1-r2 c)))
+  x x x x y y y y z z z z)
+
+(deftest class-06.2
+  (let ((c1 (make-instance 'class-06))
+	(c2 (make-instance 'class-06a)))
+    (values
+     (setf (slot-value c1 's1) 'x)
+     (setf (slot-value c2 's1) 'y)
+     (mapcar #'s1-r1 (list c1 c2))))
+  x y (x y))
+
+;;;;
+
+
+     
+
+
+
diff --git a/ansi-tests/defclass-aux.lsp b/ansi-tests/defclass-aux.lsp
index 9fdcab9c..10c1e189 100644
--- a/ansi-tests/defclass-aux.lsp
+++ b/ansi-tests/defclass-aux.lsp
@@ -112,6 +112,10 @@
 	 (initforms
 	  (loop for slot-option in slot-options
 		collect (collect-properties slot-option :initform)))
+	 (class-var-name
+	  (intern (concatenate 'string "*CLASS-" (symbol-name class-name)
+			       "-RETURNED-BY-DEFCLASS*")
+		  (find-package :cl-test)))
 	 )
 
     (declare (ignorable readers writers accessors allocations
@@ -161,9 +165,14 @@
       (setf (gethash class-name *my-classes*) my-class-obj))
 
     `(progn
-
+       (declaim (special ,class-var-name))
+       
        (eval-when (load eval compile)
-	 (ignore-errors (defclass ,@(cdr args))))
+	 (ignore-errors (setq ,class-var-name (defclass ,@(cdr args)))))
+
+       (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS")
+	 (eqt (find-class ',class-name) ,class-var-name)
+	 t)
 
        (deftest ,(make-defclass-test-name class-name
 					  "-IS-IN-ITS-METACLASS")
diff --git a/ansi-tests/defclass.lsp b/ansi-tests/defclass.lsp
index 1b5b8161..1b3790d1 100644
--- a/ansi-tests/defclass.lsp
+++ b/ansi-tests/defclass.lsp
@@ -80,6 +80,3 @@
 (generate-slot-tests) ;; a macro
 
 
-
-
-
diff --git a/ansi-tests/load-objects.lsp b/ansi-tests/load-objects.lsp
index cb0c854b..eca05d67 100644
--- a/ansi-tests/load-objects.lsp
+++ b/ansi-tests/load-objects.lsp
@@ -5,6 +5,7 @@
 
 (compile-and-load "defclass-aux.lsp")
 (load "defclass.lsp")
+(load "defclass-01.lsp")
 (load "defclass-forward-reference.lsp")
 (load "ensure-generic-function.lsp")
 
-- 
GitLab