;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 10 16:16:59 2003
;;;; Contains: Tests of SLOT-VALUE



;;; 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)

;;; Order of evaluation test(s)

(deftest slot-value.order.1
  (let ((obj (make-instance 'slot-value-class-01))
        (i 0) x y)
    (values
     (setf (slot-value obj 'a) t)
     (slot-value (progn (setf x (incf i)) obj)
                 (progn (setf y (incf i)) 'a))
     i x y))
  t t 2 1 2)

(deftest slot-value.order.2
  (let ((obj (make-instance 'slot-value-class-01))
        (i 0) x y)
    (values
     (setf (slot-value (progn (setf x (incf i)) obj)
                       (progn (setf y (incf i)) 'b))
           t)
     (slot-value obj 'b)
     i x y))
  t t 2 1 2)

;;; Error tests

(deftest slot-value.error.1
  (signals-error (slot-value) program-error)
  t)

(deftest slot-value.error.2
  (signals-error (slot-value (make-instance 'slot-value-class-01))
                 program-error)
  t)

(deftest slot-value.error.3
  (signals-error
   (let ((obj (make-instance 'slot-value-class-01)))
     (setf (slot-value obj 'a) t)
     (slot-value obj 'a nil))
   program-error)
  t)

(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)))
    (check-predicate
     #'(lambda (e)
         (let ((class (class-of e)))
           (or (not (eq (class-of class) built-in-class))
               (handler-case (progn (slot-value e slot-name) nil)
                             (error () t)))))))
  nil)

(deftest slot-value.error.6
  (let ((built-in-class (find-class 'built-in-class))
        (slot-name (gensym)))
    (check-predicate
     #'(lambda (e)
         (let ((class (class-of e)))
           (or (not (eq (class-of class) built-in-class))
               (handler-case (setf (slot-value e slot-name) nil)
                                  (error () t)))))))
  nil)