;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 17:19:35 2003
;;;; Contains: Tests of DEFINE-SETF-EXPANDER



(def-macro-test define-setf-expander.error.1
  (define-setf-expander nonexistent-access-fn (x)))

;;; Non-error tests

(defun my-car (x) (car x))

(ignore-errors
  (defparameter *define-setf-expander-vals.1*
    (multiple-value-list
     (define-setf-expander my-car (place &environment env)
       (multiple-value-bind (temps vals stores set-form get-form)
           (get-setf-expansion place env)
         (declare (ignore stores set-form))
         (let ((store (gensym))
               (temp (gensym)))
           (values
            `(,@temps ,temp)
            `(,@vals ,get-form)
            `(,store)
            `(progn (rplaca ,temp ,store) ,store)
            `(my-car ,temp))))))))

(deftest define-setf-expander.1
  *define-setf-expander-vals.1*
  (my-car))

(deftest define-setf-expander.2
  (let ((a (list 'x 'y)))
    (values
     (copy-list a)
     (my-car a)
     (setf (my-car a) 'z)
     a))
  (x y) x z (z y))

(deftest define-setf-expander.3
  (multiple-value-bind (temps vals stores set get)
      (get-setf-expansion '(my-car x))
    (values
     (and (listp temps)
          (notnot (every #'symbolp temps)))
     (notnot (listp vals))
     (and (listp stores)
          (= (length stores) 1)
          (notnot (every #'symbolp stores)))
     (equalt get `(my-car ,(second (second set))))))
  t t t t)

(deftest define-setf-expander.4
  (let ((a (list (list 1))))
    (values
     (copy-tree a)
     (my-car (my-car a))
     (setf (my-car (my-car a)) 2)
     a))
  ((1)) 1 2 ((2)))

(defun my-assoc (key alist)
  (loop for pair in alist
        when (and (consp pair) (eql key (car pair)))
        return pair))

(ignore-errors
  (define-setf-expander my-assoc (key place &environment env)
    (multiple-value-bind (temps vals stores set-form get-form)
        (get-setf-expansion place env)
      (let ((store (gensym))
            (key-temp (gensym))
            (pair-temp (gensym))
            (place-temp (gensym)))
        (return-from my-assoc
          (values
           `(,@temps ,key-temp ,place-temp ,pair-temp)
           `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp))
           `(,store)
           `(if (null ,pair-temp)
                (let ((,(car stores)
                       (cons (cons ,key-temp ,store) ,place-temp)))
                  ,set-form
                  ,store)
              (setf (cdr ,pair-temp) ,store))
           `(cdr ,pair-temp)))))))

(deftest define-setf-expander.5
  (let ((x nil))
    (values
     (copy-tree x)
     (setf (my-assoc 'foo x) 1)
     (copy-tree x)
     (setf (my-assoc 'foo x) 2)
     (copy-tree x)
     (setf (my-assoc 'bar x) 3)
     (copy-tree x)))
  nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2)))

(deftest define-setf-expander.6
  (let ((n (gensym))
        (doc "D-S-EX.6"))
    (assert (null (documentation n 'setf)))
    (assert (eql (eval `(define-setf-expander ,n ()
                          ,doc (values nil nil nil nil nil)))
                 n))
    (or (documentation n 'setf) doc))
  "D-S-EX.6")

(deftest define-setf-expander.7
  (let ((n (gensym))
        (doc "D-S-EX.7"))
    (assert (null (documentation n 'setf)))
    (assert (eql (eval `(define-setf-expander ,n ()
                          (values nil nil nil nil nil)))
                 n))
    (assert (null (documentation n 'setf)))
    (values
     (setf (documentation n 'setf) doc)
     (or (documentation n 'setf) doc)))
  "D-S-EX.7"
  "D-S-EX.7")