;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 16:16:59 2003 ;;;; Contains: Tests of SLOT-VALUE (in-package :cl-test) ;;; SLOT-VALUE is used extensively elsewhere. (defclass slot-value-class-01 () (a (b :type t) (c :type fixnum) (d :type float) (e :type symbol) (f :type short-float) (g :type single-float) (h :type double-float) (i :type long-float) (j :type rational) (k :type ratio) (l :type cons) (m :type string) (n :type vector) (o :type bit) )) (defparameter *slot-value-test-slot-names* '(a b c d e f g h i j k l m n o)) (defparameter *slot-value-test-slot-values* '(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0 5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1)) (deftest slot-value.1 (let ((obj (make-instance 'slot-value-class-01)) (slot-names *slot-value-test-slot-names*) (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names for val in slot-values unless (and (equal (multiple-value-list (setf (slot-value obj name) val)) (list val)) (equal (multiple-value-list (slot-value obj name)) (list val))) collect name)) nil) (defclass slot-value-class-02 (slot-value-class-01) ((a :allocation :class) (b :allocation :class) (c :allocation :class) (d :allocation :class) (e :allocation :class) (f :allocation :class) (g :allocation :class) (h :allocation :class) (i :allocation :class) (j :allocation :class) (k :allocation :class) (l :allocation :class) (m :allocation :class) (n :allocation :class) (o :allocation :class))) (deftest slot-value.2 (let ((obj (make-instance 'slot-value-class-02)) (slot-names *slot-value-test-slot-names*) (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names for val in slot-values unless (and (equal (multiple-value-list (setf (slot-value obj name) val)) (list val)) (equal (multiple-value-list (slot-value obj name)) (list val))) collect name)) nil) ;;; Error tests (deftest slot-value.error.1 (classify-error (slot-value)) program-error) (deftest slot-value.error.2 (classify-error (slot-value (make-instance 'slot-value-class-01))) program-error) (deftest slot-value.error.3 (classify-error (let ((obj (make-instance 'slot-value-class-01))) (setf (slot-value obj 'a) t) (slot-value obj 'a nil))) program-error) (deftest slot-value.error.4 (handler-case (progn (slot-value (make-instance 'slot-value-class-01) (gensym)) :bad) (error () :good)) :good) (deftest slot-value.error.5 (let ((built-in-class (find-class 'built-in-class)) (slot-name (gensym))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (slot-value e slot-name) t) (error () nil))) collect e)) nil) (deftest slot-value.error.6 (let ((built-in-class (find-class 'built-in-class)) (slot-name (gensym))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (setf (slot-value e slot-name) t) (error () nil))) collect e)) nil)