defsetf.lsp 3.28 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 17:18:01 2003
;;;; Contains: Tests of DEFSETF

(in-package :cl-test)

;;; Need to add non-error tests

(def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn
sds's avatar
sds committed
11
                                  nonexistent-update-fn))
12 13 14 15 16 17 18 19 20 21

;;; Short form

(defun defsetf.1-accessor (x)
  (cadr x))

(defun defsetf.1-accessor-settor (x val)
  (setf (cadr x) val))

(deftest defsetf.1
22 23
  (progn
    (let ((vals (multiple-value-list
sds's avatar
sds committed
24
                 (defsetf defsetf.1-accessor defsetf.1-accessor-settor))))
25
      (assert (equal vals '(defsetf.1-accessor))
sds's avatar
sds committed
26 27
              ()
              "Return values are ~A~%" vals))
28 29
    (eval
     '(let ((x (list 1 2 3)))
sds's avatar
sds committed
30 31 32
        (values
         (setf (defsetf.1-accessor x) 4)
         x))))
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
  4
  (1 4 3))

;;; Use a macro instead of a function for updatefn

(defun defsetf.2-accessor (x)
  (cadr x))

(defmacro defsetf.2-accessor-settor (x val)
  `(setf (cadr ,x) ,val))

(defparameter *defsetf.2-vals*
  (multiple-value-list
   (defsetf defsetf.2-accessor defsetf.2-accessor-settor)))

(deftest defsetf.2a
  *defsetf.2-vals*
  (defsetf.2-accessor))

(deftest defsetf.2b
  (let ((x (list 1 2 3)))
    (values
     (setf (defsetf.2-accessor x) 4)
     x))
  4
  (1 4 3))

;;; Documentation string

(defun defsetf.3-accessor (x)
  (cadr x))

(defun defsetf.3-accessor-settor (x val)
  (setf (cadr x) val))

(defparameter *defsetf.3-vals*
  (multiple-value-list
   (defsetf defsetf.3-accessor defsetf.3-accessor-settor
     "A doc string")))

(deftest defsetf.3a
  *defsetf.3-vals*
  (defsetf.3-accessor))

(deftest defsetf.3b
  (let ((doc (documentation 'defsetf.3-accessor 'setf)))
    (or (null doc) (equalt doc "A doc string")))
  t)

(deftest defsetf.3c
  (let ((x (list 1 2 3)))
    (values
     (setf (defsetf.3-accessor x) 4)
     x))
  4
  (1 4 3))

;;; Long form of defsetf

(defun defsetf.4-accessor (n seq)
  (elt seq n))

(defparameter *defsetf.4-vals*
  (multiple-value-list
sds's avatar
sds committed
97
   (defsetf defsetf.4-accessor (n seq) (val)
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
     (declare)
     "Doc string for defsetf.4-accessor setf"
     `(setf (elt ,seq ,n) ,val))))

(deftest defsetf.4a
  *defsetf.4-vals*
  (defsetf.4-accessor))

(deftest defsetf.4b
  (let ((doc (documentation 'defsetf.4-accessor 'setf)))
    (or (null doc) (equalt doc "Doc string for defsetf.4-accessor setf")))
  t)

(deftest defsetf.4c
  (let ((x (list 1 2 3 4))
sds's avatar
sds committed
113 114 115
        (i 0)
        (j nil)
        (k nil))
116 117
    (values
     (setf (defsetf.4-accessor
sds's avatar
sds committed
118 119 120 121
             (progn (setf j (incf i))
                    2)
             (progn (setf k (incf i)) x))
           (progn (incf i) 'a))
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
     x
     i j k))
  a
  (1 2 a 4)
  3 1 2)

;;; Test that there's a block around the forms in long form defsetf

(defun defsetf.5-accessor (x) (car x))

(defsetf defsetf.5-accessor (y) (val)
  (return-from defsetf.5-accessor `(setf (car ,y) ,val)))

(deftest defsetf.5a
  (let ((x (cons 'a 'b)))
    (values
     (setf (defsetf.5-accessor x) 'c)
     x))
  c (c . b))
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156

;;; Test that the defsetf expansion function is defined in the same
;;; lexical environment that the defsetf appears in

(defun defsetf.6-accessor (x) (car x))

(let ((z 'car))
  (defsetf defsetf.6-accessor (y) (val)
    `(setf (,z ,y) ,val)))

(deftest defsetf.6a
  (let ((x (cons 'a 'b)))
    (values
     (setf (defsetf.6-accessor x) 'c)
     x))
  c (c . b))