tests/setf.impure.lisp

   1 ;;;; tests related to setf
   2
   3 ;;;; This file is impure because we want to be able to use DEFUN.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; While most of SBCL is derived from the CMU CL system, the test
   9 ;;;; files (like this one) were written from scratch after the fork
  10 ;;;; from CMU CL.
  11 ;;;;
  12 ;;;; This software is in the public domain and is provided with
  13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  14 ;;;; more information.
  15
  16 (in-package :cl-user)
  17
  18 (defvar *foo* nil)
  19 (defun (setf foo) (bar)
  20     (setf *foo* bar))
  21
  22 ;;; Regression test for get-setf-expansion without explicit
  23 ;;; environment object.
  24 (assert (multiple-value-list (get-setf-expansion '(foo))))
  25
  26 ;;; Regression test for SHIFTF of values.
  27 (let ((x (list 1))
  28       (y (list 2)))
  29   (shiftf (values (car x) (car y)) (values (car y) (car x)))
  30   (assert (equal (list x y) '((2) (1)))))
  31
  32 ;;; SETF of values with multiple-value place forms
  33 (let ((a t) (b t) (c t) (d t))
  34   (let ((list (multiple-value-list
  35                (setf (values (values a b) (values c d)) (values 1 2 3 4)))))
  36     (assert (equal list '(1 2)))
  37     (assert (eql a 1))
  38     (assert (eql c 2))
  39     (assert (null b))
  40     (assert (null d))))
  41
  42 ;;; SETF of THE with VALUES.
  43 (let (x y)
  44   (setf (the (values fixnum fixnum) (values x y))
  45         (values 1 2))
  46   (assert (= x 1))
  47   (assert (= y 2)))
  48
  49 ;;; SETF of MACRO-FUNCTION must accept a NIL environment
  50 (let ((fun (constantly 'ok)))
  51   (setf (macro-function 'nothing-at-all nil) fun)
  52   (assert (eq fun (macro-function 'nothing-at-all nil))))
  53
  54
  55 ;;; DEFSETF accepts &ENVIRONMENT but not &AUX
  56 (defsetf test-defsetf-env-1  (&environment env) (new)
  57   ;; Note: we're not trying to ignore NEW, we're trying to ignore
  58   ;; the variable that SETF binds whose name is in NEW.
  59   (if (macro-function 'defsetf-env-trick env)
  60       `(progn ,new :local)
  61       `(progn ,new :global)))
  62
  63 (defsetf test-defsetf-env-2  (local global &environment env) (new)
  64   ;; As above, NEW values are generally not supposed to be ignored.
  65   (if (macro-function 'defsetf-env-trick env)
  66       `(progn ,new ,local)
  67       `(progn ,new ,global)))
  68
  69 (assert (eq :local (macrolet ((defsetf-env-trick ()))
  70                      (setf (test-defsetf-env-1) 13))))
  71
  72 (assert (eq :global (setf (test-defsetf-env-1) 13)))
  73
  74 (assert (eq :local (macrolet ((defsetf-env-trick ()))
  75                      (setf (test-defsetf-env-2 :local :oops) 13))))
  76
  77 (assert (eq :global (setf (test-defsetf-env-2 :oops :global) 13)))
  78
  79 (assert (eq :error
  80             (handler-case
  81                 (eval '(defsetf test-defsetf-aux (&aux aux) (new) nil))
  82               (error ()
  83                 :error))))
  84
  85 (handler-bind ((style-warning #'error))
  86   (compile nil '(lambda ()
  87                  (defsetf test-defsetf-no-env (foo) (new)
  88                    `(set-foo ,foo ,new))))
  89   (compile nil '(lambda ()
  90                  (defsetf test-defsetf-ignore-env (foo &environment env) (new)
  91                    (declare (ignore env))
  92                    `(set-foo ,foo ,new)))))
  93
  94 ;;; Not required by the spec, but allowes compiler-macros for SETF-functiosn
  95 ;;; to see their constant argument forms.
  96 (with-test (:name :constantp-aware-get-setf-expansion)
  97   (multiple-value-bind (temps values stores set get)
  98       (get-setf-expansion '(foo 1 2 3))
  99     (assert (not temps))
 100     (assert (not values))
 101     (assert (equal `(funcall #'(setf foo) ,@stores 1 2 3) set))
 102     (assert (equal '(foo 1 2 3) get))))
 103
 104 (with-test (:name :update-fn-should-be-a-symbol-in-defsetf)
 105   (assert (eq :error
 106             (handler-case
 107                 (eval '(defsetf access-fn 5))
 108               (error ()
 109                 :error)))))
 110
 111 (with-test (:name :getf-unused-default-variable)
 112   (handler-bind ((style-warning #'error))
 113     (compile nil `(lambda (x y)
 114                     (setf (gethash :x x 0) 4)
 115                     (setf (getf y :y 0) 4)
 116                     (setf (get 'z :z 0) 4)))))
 117
 118 (with-test (:name :setf-fun-and-macro-full-warn)
 119   ;; make the compiler assume existence of #'(setf shoe-color)
 120   (handler-bind ((warning #'muffle-warning))
 121       (compile nil '(lambda (x) (setf (shoe-color x) 'cordovan))))
 122   ;; now we get a full warning because the macro was seen too late.
 123   (assert (typep (handler-case (eval '(defsetf shoe-color set-shoe-color))
 124                    (warning (c) c))
 125                  '(and warning (not style-warning)))))
 126
 127 (with-test (:name :setf-fun-and-macro-style-1)
 128   (eval '(defun (setf shoe-size) (new x) x new))
 129   ;; unlike above, this is merely a style-warning
 130   (assert (typep (handler-case (eval '(defsetf shoe-size set-shoe-size))
 131                    (warning (c) c))
 132                  'style-warning)))
 133
 134 ;; This is a test of the compiler, but it belongs with the above.
 135 ;; FIXME: does this need to go through COMPILE-FILE, or will COMPILE work?
 136 (defvar *tmpfile* "setf-tmp.lisp")
 137 (with-test (:name :setf-fun-and-macro-style-2)
 138   (unwind-protect
 139        (progn
 140          ;; verify the test's precondition, for sanity
 141          (assert (not (fboundp '(setf shoe-count))))
 142          (with-open-file (f *tmpfile* :direction :output
 143                                       :if-exists :supersede)
 144            (prin1 '(defun (setf shoe-count) (new x) (print x) new) f)
 145            (prin1 '(defsetf shoe-count set-shoe-count) f))
 146          ;; Expect a warning because the compiler knows about
 147          ;; (SETF SHOE-COUNT), which isn't yet FBOUNDP,
 148          ;; and then we also compile a SETF inverse.
 149          (multiple-value-bind (output warnings-p failure-p)
 150              (compile-file *tmpfile*)
 151            (ignore-errors (delete-file output))
 152            (assert (and output warnings-p (not failure-p)))))
 153       (ignore-errors (delete-file *tmpfile*))))
 154
 155 ;; Make sure that the second values of INFO :SETF :EXPANDER/:INVERSE
 156 ;; are not both T.  Each of :EXPANDER and :INVERSE set the other one
 157 ;; to NIL but the WINP return value from INFO was still T so could not
 158 ;; reliably be used to test existence or non-existence.
 159 (defsetf foo1 set-foo1)
 160 (define-setf-expander foo1 (a b) (declare (ignore a b)))
 161
 162 (define-setf-expander foo2 (a b) (declare (ignore a b)))
 163 (defsetf foo2 set-foo2)
 164
 165 (with-test (:name :setf-inverse-clears-expander-and-vice-versa)
 166   (multiple-value-bind (val winp) (sb-int:info :setf :inverse 'foo1)
 167     (assert (and (not val) (not winp))))
 168   (multiple-value-bind (val winp) (sb-int:info :setf :expander 'foo2)
 169     (assert (and (not val) (not winp)))))
 170
 171 ;; The expander for (CADAR x) should behave as (CAR (CDAR x)) etc.
 172 ;; This mainly affects read/modify/write semantics.
 173 (with-test (:name :car+cdr-compositions-lp1450968)
 174   (flet ((maketree (n &aux (count -1))
 175            (labels ((recurse (n)
 176                       (if (zerop n)
 177                           (incf count)
 178                           (cons (recurse (1- n)) (recurse (1- n))))))
 179              (recurse n))))
 180     (loop
 181      for n-ops from 2 to 4
 182      do (dotimes (bitmask (ash 1 n-ops))
 183           (let* ((ops (coerce (loop for i below n-ops
 184                                     collect (if (logbitp i bitmask) #\D #\A))
 185                               'string))
 186                  (accessor (sb-int:symbolicate "C" ops "R"))
 187                  (tree (maketree n-ops))
 188                  (left (car tree))
 189                  (right (cdr tree)))
 190             (assert (eql (funcall accessor tree) bitmask))
 191             (let ((f (compile nil
 192                               `(lambda (obj)
 193                                  (incf (,accessor obj)
 194                                        (progn (rplaca obj nil)
 195                                               (rplacd obj nil)
 196                                               1000))))))
 197               (funcall f tree)
 198               (let ((tree* (cons left right)))
 199                 (assert (eql (funcall accessor tree*)
 200                              (+ bitmask 1000))))))))))
 201
 202 (define-symbol-macro %foofy1% (values a b c))
 203 (define-symbol-macro %foofy2% (values x y z))
 204 ;; PSETF and PSETQ eliminate vacuous LET* forms.
 205 (with-test (:name :psetf-expansion-maximally-concise)
 206   (dolist (op '(psetq psetf))
 207     (let* ((form `(,op %foofy1% (f) %foofy2% (g)))
 208            (expansion (let ((*gensym-counter* 1)) (macroexpand-1 form)))
 209            (expect '(multiple-value-bind (new1 new2 new3) (f)
 210                      (multiple-value-bind (new4 new5 new6) (g)
 211                        (setq a new1) (setq b new2) (setq c new3)
 212                        (setq x new4) (setq y new5) (setq z new6)
 213                        nil))))
 214       (assert (equal (read-from-string (write-to-string expansion :gensym nil))
 215                      expect)))))
 216
 217 (with-test (:name :defsetf-syntax-errors)
 218   (dolist (test '((defsetf foo set-foo junk other-junk) ; would accept
 219                   (defsetf foo set-foo . junk))) ; would crash
 220     (assert (search "Ill-formed DEFSETF"
 221                     (simple-condition-format-control
 222                      (nth-value 1 (ignore-errors (macroexpand-1 test)))))))
 223   ;; no (SETF (SETF f)) methods
 224   (assert-error (macroexpand-1 '(defsetf (setf foo) set-setf-foo))))
 225
 226 (defmacro mymacro () '*x*)
 227 (define-symbol-macro foox (car *x*))
 228 (with-test (:name :setf-of-symbol-macro)
 229   (assert (equal (macroexpand-1 '(setf foox 3)) '(sb-kernel:%rplaca *x* 3))))
 230 (with-test (:name :setf-of-macro)
 231   (assert (equal (macroexpand-1 '(setf (mymacro) 3)) '(setq *x* 3))))
 232
 233 (defvar *x* (list 1))
 234 (defun set-foox (x)
 235   (declare (type (integer 1 20) foox))
 236   (setq foox x))
 237 (with-test (:name :setf-of-symbol-macro-typecheck)
 238   ;; this was not broken, but since I've deleted the comment
 239   ;;  "FIXME: [Free] type declaration. -- APD, 2002-01-26"
 240   ;; from ir1-translators, it's probably worth a test
 241   ;; since at some point it must not have worked as intended.
 242   (assert-error (set-foox 99)))
 243
 244 (declaim (special *foo-array*))
 245 ;; When dealing with symbol-macros, compiled SETQ would locate the leaf
 246 ;; for the symbol and then covertly stuff in the expansion to a SETF form.
 247 ;; *MACROEXPAND-HOOK* would see the SETF but not the expansion
 248 ;; of the symbol, except those expansions occurring with GET-SETF-EXPANSION.
 249 ;; Now it can see the first-round expansion too.
 250 (with-test (:name :compiled-setq-macroexpand-hook)
 251   (sb-int:collect ((expansions))
 252     (let ((*macroexpand-hook*
 253            (lambda (expander form env)
 254              (let ((new (funcall expander form env)))
 255                (when (or (symbolp form) (eq (car form) 'setf))
 256                  (expansions (list form new)))
 257                new))))
 258       (compile nil '(lambda (x)
 259                      (symbol-macrolet ((ref-it (aref a 0))
 260                                        (a *foo-array*)
 261                                        (thing ref-it))
 262                        (setq thing x)))))
 263     (let ((readback (read-from-string
 264                      (write-to-string (expansions) :gensym nil))))
 265       (assert (equal readback
 266                      '((thing ref-it)
 267                        (ref-it (aref a 0))
 268                        (a *foo-array*)
 269                        ((setf thing x)
 270                         (let* ((a1 a))
 271                           (multiple-value-bind (new0) x
 272                             (funcall #'(setf aref) new0 a1 0))))))))))
 273
 274 (with-test (:name :remf-basic-correctness)
 275   (flet ((try (indicator input expect)
 276            (handler-case (sb-impl::%remf indicator (copy-list input))
 277              (error () (assert (eq expect :error)))
 278              (:no-error (newval flag)
 279                (assert (and (equal newval expect)
 280                             (eq flag (not (equal newval input)))))
 281                (let* ((foo (vector (copy-list input)))
 282                       (removedp (remf (aref foo 0) indicator)))
 283                  (assert (equal (aref foo 0) expect))
 284                  (assert (eq removedp (not (equal input expect)))))))))
 285     (try 'x '() '())
 286     (try 'x 'a :error)
 287     (try 'x '(a) :error)
 288     (try 'x '(a . b) :error)
 289     (try 'x '(a b . c) :error)
 290     ;; indicator not found
 291     (try 'weazel '(a b :foo :goo) '(a b :foo :goo))
 292     (try 'weazel '(a b :foo :goo . 3) :error) ; improper
 293     (try 'weazel '(a b :foo :goo baz) :error) ; odd length
 294     ;; pair deleted from head
 295     (try 'a '(a b :foo :goo a 3) '(:foo :goo a 3))
 296     (try 'a '(a b :foo :goo) '(:foo :goo))
 297     (try 'a '(a b :foo) '(:foo)) ; odd length unnoticed
 298     (try 'a '(a b . :foo) :error) ; but won't return a non-list
 299     ;; pair deleted from interior
 300     (try :foo '(a b :foo :goo) '(a b))
 301     (try :foo '(a b :foo :goo :boo) '(a b :boo)) ; odd length unnoticed
 302     (try :foo '(a b :foo :goo :foo) '(a b :foo)) ; other :FOO is irrelevant
 303     (try :foo '(a b :foo :goo . bad) :error)
 304     ))
 305
 306 (with-test (:name :incf-argument-eval-order)
 307   (let ((testvar 1))
 308     (flet ((double-it () (setq testvar (* 2 testvar))))
 309       (incf testvar (double-it)))
 310     ;; testvar should be 4, not 3, because the read for INCF
 311     ;; occurs after doubling.
 312     (assert (eql testvar 4))))
 313
 314 ;;; success