From dec63c3a6cdd5a899447ef46e871bf212cd51cc4 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sat, 26 Apr 2003 13:51:11 +0000
Subject: [PATCH] Begin adding simple inheritance tests for DEFCLASS.

---
 ansi-tests/ansi-aux.lsp     |  26 ++++++++-
 ansi-tests/defclass-02.lsp  | 105 ++++++++++++++++++++++++++++++++++++
 ansi-tests/load-objects.lsp |   1 +
 3 files changed, 131 insertions(+), 1 deletion(-)
 create mode 100644 ansi-tests/defclass-02.lsp

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index 5fac9ada..f946aa91 100644
--- a/ansi-tests/ansi-aux.lsp
+++ b/ansi-tests/ansi-aux.lsp
@@ -1452,4 +1452,28 @@ the condition to go uncaught if it cannot be classified."
 	(eqlt (classify-error (funcall (macro-function ',macro-name)
 				       ',macro-form nil nil))
 	      'program-error))
-       t t t)))
\ No newline at end of file
+       t t t)))
+
+(defun typep* (element type)
+  (not (not (typep element type))))
+
+(defun applyf (fn &rest args)
+  #'(lambda (&rest more-args) (apply fn (append args more-args))))
+
+(defun slot-boundp* (object slot)
+  (notnot (slot-boundp object slot)))
+
+(defun slot-exists-p* (object slot)
+  (notnot (slot-exists-p object slot)))
+
+(defun map-slot-boundp* (c slots)
+  (mapcar (applyf #'slot-boundp c) slots))
+
+(defun map-slot-exists-p* (c slots)
+  (mapcar (applyf #'slot-exists-p* c) slots))
+
+(defun map-slot-value (c slots)
+  (mapcar (applyf #'slot-value c) slots))
+
+(defun map-typep* (object types)
+  (mapcar (applyf #'typep* object) types))
diff --git a/ansi-tests/defclass-02.lsp b/ansi-tests/defclass-02.lsp
new file mode 100644
index 00000000..ccf934d6
--- /dev/null
+++ b/ansi-tests/defclass-02.lsp
@@ -0,0 +1,105 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Fri Apr 25 07:16:57 2003
+;;;; Contains: Tests of DEFCLASS with simple inheritance
+
+(in-package :cl-test)
+
+;;;
+
+(defclass class-0201 ()
+  ((a :initform 'x) (b :allocation :instance) (c :reader class-0201-c)))
+
+(defclass class-0202 (class-0201)
+  (d (e :initform 'y) (f :allocation :instance)))
+
+(deftest class-0201.1
+  (let ((c (make-instance 'class-0201)))
+    (values (map-slot-boundp* c '(a b c))
+	    (map-slot-exists-p* c '(a b c))
+	    (slot-value c 'a)
+	    (map-typep* c (list 'class-0201 'class-0202
+				(find-class 'class-0201)
+				(find-class 'class-0202)))
+	    (class-name (class-of c))
+	    ))
+  (t nil nil)
+  (t t t)
+  x
+  (t nil t nil)
+  class-0201)
+
+(deftest class-0202.1
+  (let ((c (make-instance 'class-0202)))
+    (values (map-slot-boundp* c '(a b c d e f))
+	    (map-slot-value c '(a e))
+	    (map-typep* c (list 'class-0201 'class-0202
+				(find-class 'class-0201)
+				(find-class 'class-0202)))
+	    (class-name (class-of c))
+	    ))
+  (t nil nil nil t nil)
+  (x y)
+  (t t t t)
+  class-0202)
+
+;;;
+
+
+(defclass class-0203 ()
+  ((a :allocation :class) (b :allocation :instance)))
+
+(defclass class-0204 (class-0203)
+  (c d))
+
+(deftest class-0203.1
+  (let ((c1 (make-instance 'class-0203))
+	(c2 (make-instance 'class-0204)))
+    (values
+     (map-slot-boundp* c1 '(a b))
+     (map-slot-boundp* c2 '(a b c d))
+     (setf (slot-value c1 'a) 'x)
+     (map-slot-boundp* c1 '(a b))
+     (map-slot-boundp* c2 '(a b c d))
+     (slot-value c1 'a)
+     (slot-value c2 'a)
+     (eq (slot-makunbound c1 'a) c1)
+     (map-slot-boundp* c1 '(a b))
+     (map-slot-boundp* c2 '(a b c d))))
+  (nil nil)
+  (nil nil nil nil)
+  x
+  (t nil)
+  (t nil nil nil)
+  x x
+  t
+  (nil nil)
+  (nil nil nil nil))
+
+  
+(deftest class-0203.2
+  (let ((c1 (make-instance 'class-0203))
+	(c2 (make-instance 'class-0204)))
+    (values
+     (map-slot-boundp* c1 '(a b))
+     (map-slot-boundp* c2 '(a b c d))
+     (setf (slot-value c1 'a) 'x)
+     (map-slot-boundp* c1 '(a b))
+     (map-slot-boundp* c2 '(a b c d))
+     (slot-value c1 'a)
+     (slot-value c2 'a)
+     (eq (slot-makunbound c2 'a) c1)
+     (map-slot-boundp* c1 '(a b))
+     (map-slot-boundp* c2 '(a b c d))))
+  (nil nil)
+  (nil nil nil nil)
+  x
+  (t nil)
+  (t nil nil nil)
+  x x
+  t
+  (nil nil)
+  (nil nil nil nil))
+
+  
+     
\ No newline at end of file
diff --git a/ansi-tests/load-objects.lsp b/ansi-tests/load-objects.lsp
index f5113753..b9b1bbea 100644
--- a/ansi-tests/load-objects.lsp
+++ b/ansi-tests/load-objects.lsp
@@ -6,6 +6,7 @@
 (compile-and-load "defclass-aux.lsp")
 (load "defclass.lsp")
 (load "defclass-01.lsp")
+(load "defclass-02.lsp")
 (load "defclass-errors.lsp")
 (load "defclass-forward-reference.lsp")
 (load "ensure-generic-function.lsp")
-- 
GitLab