From d5786addd96f099c80a60b2a3e312ebc90bd5eaa Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sun, 4 May 2003 11:48:00 +0000
Subject: [PATCH] Begin adding tests for CHANGE-CLASS.

---
 ansi-tests/ansi-aux.lsp     |   5 +
 ansi-tests/change-class.lsp | 294 ++++++++++++++++++++++++++++++++++++
 ansi-tests/load-objects.lsp |   2 +
 3 files changed, 301 insertions(+)
 create mode 100644 ansi-tests/change-class.lsp

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index f946aa91..ecf03cdc 100644
--- a/ansi-tests/ansi-aux.lsp
+++ b/ansi-tests/ansi-aux.lsp
@@ -1477,3 +1477,8 @@ the condition to go uncaught if it cannot be classified."
 
 (defun map-typep* (object types)
   (mapcar (applyf #'typep* object) types))
+
+(defun slot-value-or-nil (object slot-name)
+  (and (slot-exists-p object slot-name)
+       (slot-boundp object slot-name)
+       (slot-value object slot-name)))
\ No newline at end of file
diff --git a/ansi-tests/change-class.lsp b/ansi-tests/change-class.lsp
new file mode 100644
index 00000000..a0bf8d43
--- /dev/null
+++ b/ansi-tests/change-class.lsp
@@ -0,0 +1,294 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat May  3 14:23:29 2003
+;;;; Contains: Tests of CHANGE-CLASS
+
+(in-package :cl-test)
+
+(defclass change-class-class-01a ()
+  ((a :initarg :a) (b :initarg :b) (c :initarg :c)))
+
+(defclass change-class-class-01b ()
+  ((c :initarg :c2) (d :initarg :d2) (b :initarg :b2)))
+
+(deftest change-class.1.1
+  (let ((obj (make-instance 'change-class-class-01a))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (map-slot-boundp* obj '(a b c))
+     (slot-exists-p obj 'd)
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))))
+  t nil (nil nil nil)
+  nil t nil t nil (nil nil nil))
+
+(deftest change-class.1.2
+  (let ((obj (make-instance 'change-class-class-01a :a 1))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (map-slot-boundp* obj '(a b c))
+     (slot-exists-p obj 'd)
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))))
+  t nil (t nil nil)
+  nil t nil t nil (nil nil nil))
+
+(deftest change-class.1.3
+  (let ((obj (make-instance 'change-class-class-01a :b 2))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (map-slot-boundp* obj '(a b c))
+     (slot-exists-p obj 'd)
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (slot-value obj 'b)))
+  t nil (nil t nil)
+  nil t nil t nil (t nil nil) 2)
+
+(deftest change-class.1.4
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (map-slot-boundp* obj '(a b c))
+     (slot-exists-p obj 'd)
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil (t t t)
+  nil t nil t nil (t t nil) (2 5))
+
+(deftest change-class.1.5
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (eqt obj (change-class obj new-class :b2 8 :c2 76))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil t nil (t t nil) (8 76))
+
+(deftest change-class.1.6
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (eqt obj (change-class obj new-class :b2 19 :b2 34))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil t nil (t t nil) (19 5))
+
+(deftest change-class.1.7
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (eqt obj (change-class obj new-class :allow-other-keys nil))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil t nil (t t nil) (2 5))
+
+(deftest change-class.1.8
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (eqt obj (change-class obj new-class :allow-other-keys t))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil t nil (t t nil) (2 5))
+
+(deftest change-class.1.9
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (eqt obj (change-class obj new-class :allow-other-keys t
+			    :nonsense t))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil t nil (t t nil) (2 5))
+
+(deftest change-class.1.10
+  (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5))
+	(new-class (find-class 'change-class-class-01b)))
+    (values
+     (eqt obj (change-class obj new-class :bad 0 :allow-other-keys t
+			    :allow-other-keys nil :nonsense t))
+     (typep* obj 'change-class-class-01a)
+     (typep* obj 'change-class-class-01b)
+     (slot-exists-p obj 'a)
+     (map-slot-boundp* obj '(b c d))
+     (map-slot-value obj '(b c))))
+  t nil t nil (t t nil) (2 5))
+
+(deftest change-class.1.11
+  (handler-case
+   (eval
+    '(let ((obj (make-instance 'change-class-class-01a))
+	   (new-class (find-class 'change-class-class-01b)))
+       (eqt obj (change-class obj new-class :nonsense t))))
+   (error () :expected-error))
+  :expected-error)
+
+;;; Shared slots
+
+(defclass change-class-class-02a ()
+  ((a :initarg :a :allocation :class)
+   (b :initarg :b :allocation :class)))
+
+(defclass change-class-class-02b ()
+  ((a :initarg :a2)
+   (b :initarg :b2)))
+
+(deftest change-class.2.1
+  (let ((obj (make-instance 'change-class-class-02a))
+	(new-class (find-class 'change-class-class-02b)))
+    (slot-makunbound obj 'a)
+    (slot-makunbound obj 'b)
+    (values
+     (map-slot-boundp* obj '(a b))
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-02a)
+     (typep* obj 'change-class-class-02b)
+     (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b))
+     (map-slot-boundp* obj '(a b))))
+  (nil nil)
+  t nil t
+  (nil nil)
+  (nil nil))
+
+(deftest change-class.2.2
+  (let ((obj (make-instance 'change-class-class-02a))
+	(obj2 (make-instance 'change-class-class-02a))
+	obj3
+	(new-class (find-class 'change-class-class-02b)))
+    (setf (slot-value obj 'a) 'foo)
+    (slot-makunbound obj 'b)
+    (values
+     (map-slot-boundp* obj '(a b))
+     (slot-value obj 'a)
+     (slot-value obj2 'a)
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-02a)
+     (typep* obj 'change-class-class-02b)
+     (map-slot-boundp* (setf obj3 (make-instance 'change-class-class-02a))
+		       '(a b))
+     (map-slot-boundp* obj '(a b))
+     (slot-value obj 'a)
+     (slot-value obj2 'a)
+     (slot-value obj3 'a)
+     (eqt obj obj2) (eqt obj obj3) (eqt obj2 obj3)
+     ))
+  (t nil)
+  foo foo
+  t nil t
+  (t nil)
+  (t nil)
+  foo foo foo
+  nil nil nil)
+
+(deftest change-class.2.3
+  (let ((obj (make-instance 'change-class-class-02a))
+	(obj2 (make-instance 'change-class-class-02a))
+	(new-class (find-class 'change-class-class-02b)))
+    (setf (slot-value obj 'a) 1
+	  (slot-value obj 'b) 16)
+    (values
+     (map-slot-boundp* obj '(a b))
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-02a)
+     (typep* obj 'change-class-class-02b)
+     (map-slot-boundp* obj2 '(a b))
+     (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b))
+     (map-slot-boundp* obj '(a b))
+     (progn (slot-makunbound obj2 'a)
+	    (slot-makunbound obj2 'b)
+	    (map-slot-boundp* obj '(a b)))))
+		 
+  (t t)
+  t nil t
+  (t t)
+  (t t)
+  (t t)
+  (t t))
+
+;;; Destination slots are shared
+
+(defclass change-class-class-03a ()
+  ((a :initarg :a) (b :initarg :b)))
+
+(defclass change-class-class-03b ()
+  ((a :allocation :class :initarg :a2)
+   (b :allocation :class :initarg :b2)))
+
+(deftest change-class.3.1
+  (let* ((obj (make-instance 'change-class-class-03a))
+	 (new-class (find-class 'change-class-class-03b))
+	 (obj2 (make-instance new-class))
+	 obj3)
+    (slot-makunbound obj2 'a)
+    (slot-makunbound obj2 'b)
+    (values
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-03a)
+     (typep* obj 'change-class-class-03b)
+     (typep* obj new-class)
+     (eqt (setq obj3 (make-instance new-class)) obj)
+     (map-slot-boundp* obj '(a b))
+     (map-slot-boundp* obj2 '(a b))
+     (map-slot-boundp* obj3 '(a b))
+     ))
+  t nil t t nil (nil nil) (nil nil) (nil nil))
+
+(deftest change-class.3.2
+  (let* ((obj (make-instance 'change-class-class-03a :a 1))
+	 (new-class (find-class 'change-class-class-03b))
+	 (obj2 (make-instance new-class))
+	 obj3)
+    (slot-makunbound obj2 'a)
+    (setf (slot-value obj2 'b) 17)
+    (values
+     (map-slot-boundp* obj2 '(a b))
+     (eqt obj (change-class obj new-class))
+     (typep* obj 'change-class-class-03a)
+     (typep* obj 'change-class-class-03b)
+     (typep* obj new-class)
+     (eqt (setq obj3 (make-instance new-class)) obj)
+     (map-slot-boundp* obj '(a b))
+     (map-slot-boundp* obj2 '(a b))
+     (map-slot-boundp* obj3 '(a b))
+     (slot-value obj 'b)
+     (slot-value obj2 'b)
+     (slot-value obj3 'b)
+     ))
+  (nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17)
diff --git a/ansi-tests/load-objects.lsp b/ansi-tests/load-objects.lsp
index 31539a0c..3f8da71c 100644
--- a/ansi-tests/load-objects.lsp
+++ b/ansi-tests/load-objects.lsp
@@ -14,3 +14,5 @@
 (load "allocate-instance.lsp")
 (load "reinitialize-instance.lsp")
 (load "shared-initialize.lsp")
+(load "change-class.lsp")
+
-- 
GitLab