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