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

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