define-setf-expander.lsp 3.49 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 17:19:35 2003
;;;; Contains: Tests of DEFINE-SETF-EXPANDER

6

7 8 9

(def-macro-test define-setf-expander.error.1
  (define-setf-expander nonexistent-access-fn (x)))
10 11 12 13 14

;;; Non-error tests

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

15 16 17 18 19
(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)
sds's avatar
sds committed
20 21 22 23 24 25 26 27 28 29
           (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))))))))
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48

(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)
sds's avatar
sds committed
49
          (notnot (every #'symbolp temps)))
50 51
     (notnot (listp vals))
     (and (listp stores)
sds's avatar
sds committed
52 53
          (= (length stores) 1)
          (notnot (every #'symbolp stores)))
54 55 56 57 58 59 60 61 62 63 64 65 66 67
     (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
sds's avatar
sds committed
68 69
        when (and (consp pair) (eql key (car pair)))
        return pair))
70 71 72 73

(ignore-errors
  (define-setf-expander my-assoc (key place &environment env)
    (multiple-value-bind (temps vals stores set-form get-form)
sds's avatar
sds committed
74
        (get-setf-expansion place env)
75
      (let ((store (gensym))
sds's avatar
sds committed
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
            (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)))))))
91 92 93 94 95 96 97 98 99 100 101 102 103

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

pfdietz's avatar
pfdietz committed
104 105
(deftest define-setf-expander.6
  (let ((n (gensym))
sds's avatar
sds committed
106
        (doc "D-S-EX.6"))
pfdietz's avatar
pfdietz committed
107 108
    (assert (null (documentation n 'setf)))
    (assert (eql (eval `(define-setf-expander ,n ()
sds's avatar
sds committed
109 110
                          ,doc (values nil nil nil nil nil)))
                 n))
pfdietz's avatar
pfdietz committed
111 112 113 114 115
    (or (documentation n 'setf) doc))
  "D-S-EX.6")

(deftest define-setf-expander.7
  (let ((n (gensym))
sds's avatar
sds committed
116
        (doc "D-S-EX.7"))
pfdietz's avatar
pfdietz committed
117 118
    (assert (null (documentation n 'setf)))
    (assert (eql (eval `(define-setf-expander ,n ()
sds's avatar
sds committed
119 120
                          (values nil nil nil nil nil)))
                 n))
pfdietz's avatar
pfdietz committed
121 122 123 124 125 126
    (assert (null (documentation n 'setf)))
    (values
     (setf (documentation n 'setf) doc)
     (or (documentation n 'setf) doc)))
  "D-S-EX.7"
  "D-S-EX.7")