Commit c1c2795b authored by pfdietz's avatar pfdietz

Begin adding 'manual' defclass tests,

parent f4ee69e9
;-*- 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))
;;;;
......@@ -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")
......
......@@ -80,6 +80,3 @@
(generate-slot-tests) ;; a macro
......@@ -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")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment