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 (load "compiler-test-util.lisp")
  19
  20 (defvar *foo* nil)
  21 (defun (setf foo) (bar)
  22     (setf *foo* bar))
  23
  24 ;;; Regression test for get-setf-expansion without explicit
  25 ;;; environment object.
  26 (assert (multiple-value-list (get-setf-expansion '(foo))))
  27
  28 ;;; Regression test for SHIFTF of values.
  29 (let ((x (list 1))
  30       (y (list 2)))
  31   (shiftf (values (car x) (car y)) (values (car y) (car x)))
  32   (assert (equal (list x y) '((2) (1)))))
  33
  34 ;;; SETF of values with multiple-value place forms
  35 (let ((a t) (b t) (c t) (d t))
  36   (let ((list (multiple-value-list
  37                (setf (values (values a b) (values c d)) (values 1 2 3 4)))))
  38     (assert (equal list '(1 2)))
  39     (assert (eql a 1))
  40     (assert (eql c 2))
  41     (assert (null b))
  42     (assert (null d))))
  43
  44 ;;; SETF of THE with VALUES.
  45 (let (x y)
  46   (setf (the (values fixnum fixnum) (values x y))
  47         (values 1 2))
  48   (assert (= x 1))
  49   (assert (= y 2)))
  50
  51 ;;; SETF of MACRO-FUNCTION must accept a NIL environment
  52 (let ((fun (constantly 'ok)))
  53   (setf (macro-function 'nothing-at-all nil) fun)
  54   (assert (eq fun (macro-function 'nothing-at-all nil))))
  55
  56
  57 ;;; DEFSETF accepts &ENVIRONMENT but not &AUX
  58 (defsetf test-defsetf-env-1  (&environment env) (new)
  59   ;; Note: we're not trying to ignore NEW, we're trying to ignore
  60   ;; the variable that SETF binds whose name is in NEW.
  61   (if (macro-function 'defsetf-env-trick env)
  62       `(progn ,new :local)
  63       `(progn ,new :global)))
  64
  65 (defsetf test-defsetf-env-2  (local global &environment env) (new)
  66   ;; As above, NEW values are generally not supposed to be ignored.
  67   (if (macro-function 'defsetf-env-trick env)
  68       `(progn ,new ,local)
  69       `(progn ,new ,global)))
  70
  71 ;; Returning an atom is not illegal, though is strange.
  72 (defsetf test-defsetf-trick-3 () (new) new 'bork)
  73 (with-test (:name :setf-expander-returns-atom)
  74   ;; Simply don't crash in SETF and we're good.
  75   (macroexpand-1 '(setf (test-defsetf-trick-3) 'a)))
  76
  77 (assert (eq :local (macrolet ((defsetf-env-trick ()))
  78                      (setf (test-defsetf-env-1) 13))))
  79
  80 (assert (eq :global (setf (test-defsetf-env-1) 13)))
  81
  82 (assert (eq :local (macrolet ((defsetf-env-trick ()))
  83                      (setf (test-defsetf-env-2 :local :oops) 13))))
  84
  85 (assert (eq :global (setf (test-defsetf-env-2 :oops :global) 13)))
  86
  87 (assert (eq :error
  88             (handler-case
  89                 (eval '(defsetf test-defsetf-aux (&aux aux) (new) nil))
  90               (error ()
  91                 :error))))
  92
  93 (handler-bind ((style-warning #'error))
  94   (compile nil '(lambda ()
  95                  (defsetf test-defsetf-no-env (foo) (new)
  96                    `(set-foo ,foo ,new))))
  97   (compile nil '(lambda ()
  98                  (defsetf test-defsetf-ignore-env (foo &environment env) (new)
  99                    (declare (ignore env))
 100                    `(set-foo ,foo ,new)))))
 101
 102 ;;; Not required by the spec, but allowes compiler-macros for SETF-functiosn
 103 ;;; to see their constant argument forms.
 104 (with-test (:name :constantp-aware-get-setf-expansion)
 105   (multiple-value-bind (temps values stores set get)
 106       (get-setf-expansion '(foo 1 2 3))
 107     (assert (not temps))
 108     (assert (not values))
 109     (assert (equal `(funcall #'(setf foo) ,@stores 1 2 3) set))
 110     (assert (equal '(foo 1 2 3) get))))
 111
 112 (with-test (:name :update-fn-should-be-a-symbol-in-defsetf)
 113   (assert (eq :error
 114             (handler-case
 115                 (eval '(defsetf access-fn 5))
 116               (error ()
 117                 :error)))))
 118
 119 (with-test (:name :getf-unused-default-variable)
 120   (handler-bind ((style-warning #'error))
 121     (compile nil `(lambda (x y)
 122                     (setf (gethash :x x 0) 4)
 123                     (setf (getf y :y 0) 4)
 124                     (setf (get 'z :z 0) 4)))))
 125
 126 (with-test (:name :setf-fun-and-macro-full-warn)
 127   ;; make the compiler assume existence of #'(setf shoe-color)
 128   (handler-bind ((warning #'muffle-warning))
 129       (compile nil '(lambda (x) (setf (shoe-color x) 'cordovan))))
 130   ;; now we get a full warning because the macro was seen too late.
 131   (assert (typep (handler-case (eval '(defsetf shoe-color set-shoe-color))
 132                    (warning (c) c))
 133                  '(and warning (not style-warning)))))
 134
 135 (with-test (:name :setf-fun-and-macro-style-1)
 136   (eval '(defun (setf shoe-size) (new x) x new))
 137   ;; unlike above, this is merely a style-warning
 138   (assert (typep (handler-case (eval '(defsetf shoe-size set-shoe-size))
 139                    (warning (c) c))
 140                  'style-warning)))
 141
 142 ;; This is a test of the compiler, but it belongs with the above.
 143 ;; FIXME: does this need to go through COMPILE-FILE, or will COMPILE work?
 144 (defvar *tmpfile* "setf-tmp.lisp")
 145 (with-test (:name :setf-fun-and-macro-style-2)
 146   (unwind-protect
 147        (progn
 148          ;; verify the test's precondition, for sanity
 149          (assert (not (fboundp '(setf shoe-count))))
 150          (with-open-file (f *tmpfile* :direction :output
 151                                       :if-exists :supersede)
 152            (prin1 '(defun (setf shoe-count) (new x) (print x) new) f)
 153            (prin1 '(defsetf shoe-count set-shoe-count) f))
 154          ;; Expect a warning because the compiler knows about
 155          ;; (SETF SHOE-COUNT), which isn't yet FBOUNDP,
 156          ;; and then we also compile a SETF inverse.
 157          (multiple-value-bind (output warnings-p failure-p)
 158              (compile-file *tmpfile*)
 159            (ignore-errors (delete-file output))
 160            (assert (and output warnings-p (not failure-p)))))
 161       (ignore-errors (delete-file *tmpfile*))))
 162
 163 ;; The expander for (CADAR x) should behave as (CAR (CDAR x)) etc.
 164 ;; This mainly affects read/modify/write semantics.
 165 (with-test (:name :car+cdr-compositions-lp1450968)
 166   (flet ((maketree (n &aux (count -1))
 167            (labels ((recurse (n)
 168                       (if (zerop n)
 169                           (incf count)
 170                           (cons (recurse (1- n)) (recurse (1- n))))))
 171              (recurse n))))
 172     (loop
 173      for n-ops from 2 to 4
 174      do (dotimes (bitmask (ash 1 n-ops))
 175           (let* ((ops (coerce (loop for i below n-ops
 176                                     collect (if (logbitp i bitmask) #\D #\A))
 177                               'string))
 178                  (accessor (sb-int:symbolicate "C" ops "R"))
 179                  (tree (maketree n-ops))
 180                  (left (car tree))
 181                  (right (cdr tree)))
 182             (assert (eql (funcall accessor tree) bitmask))
 183             (let ((f (compile nil
 184                               `(lambda (obj)
 185                                  (incf (,accessor obj)
 186                                        (progn (rplaca obj nil)
 187                                               (rplacd obj nil)
 188                                               1000))))))
 189               (funcall f tree)
 190               (let ((tree* (cons left right)))
 191                 (assert (eql (funcall accessor tree*)
 192                              (+ bitmask 1000))))))))))
 193
 194 (define-symbol-macro %foofy1% (values a b c))
 195 (define-symbol-macro %foofy2% (values x y z))
 196 ;; PSETF and PSETQ eliminate vacuous LET* forms.
 197 (with-test (:name :psetf-expansion-maximally-concise)
 198   (dolist (op '(psetq psetf))
 199     (let* ((form `(,op %foofy1% (f) %foofy2% (g)))
 200            (expansion (let ((*gensym-counter* 1)) (macroexpand-1 form)))
 201            (expect '(multiple-value-bind (new1 new2 new3) (f)
 202                      (multiple-value-bind (new4 new5 new6) (g)
 203                        (setq a new1) (setq b new2) (setq c new3)
 204                        (setq x new4) (setq y new5) (setq z new6)
 205                        nil))))
 206       (assert (equal-mod-gensyms expansion expect)))))
 207
 208 (with-test (:name :defsetf-syntax-errors)
 209   (dolist (test '((defsetf foo set-foo junk other-junk) ; would accept
 210                   (defsetf foo set-foo . junk))) ; would crash
 211     (assert (search "Ill-formed DEFSETF"
 212                     (simple-condition-format-control
 213                      (nth-value 1 (ignore-errors (macroexpand-1 test)))))))
 214   ;; no (SETF (SETF f)) methods
 215   (assert-error (macroexpand-1 '(defsetf (setf foo) set-setf-foo))))
 216
 217 (defmacro mymacro () '*x*)
 218 (define-symbol-macro foox (car *x*))
 219 (with-test (:name :setf-of-symbol-macro)
 220   (assert (equal (macroexpand-1 '(setf foox 3)) '(sb-kernel:%rplaca *x* 3))))
 221 (with-test (:name :setf-of-macro)
 222   (assert (equal (macroexpand-1 '(setf (mymacro) 3)) '(setq *x* 3))))
 223
 224 (defvar *x* (list 1))
 225 (defun set-foox (x)
 226   (declare (type (integer 1 20) foox))
 227   (setq foox x))
 228 (with-test (:name :setf-of-symbol-macro-typecheck)
 229   ;; this was not broken, but since I've deleted the comment
 230   ;;  "FIXME: [Free] type declaration. -- APD, 2002-01-26"
 231   ;; from ir1-translators, it's probably worth a test
 232   ;; since at some point it must not have worked as intended.
 233   (assert-error (set-foox 99)))
 234
 235 (declaim (special *foo-array*))
 236 ;; When dealing with symbol-macros, compiled SETQ would locate the leaf
 237 ;; for the symbol and then covertly stuff in the expansion to a SETF form.
 238 ;; *MACROEXPAND-HOOK* would see the SETF but not the expansion
 239 ;; of the symbol, except those expansions occurring with GET-SETF-EXPANSION.
 240 ;; Now it can see the first-round expansion too.
 241 ;; The macroexpand hook for this test needs to be compiled, but you can't
 242 ;; pass a quoted lambda (as a sexpr) to COMPILE because it needs to
 243 ;; capture EXPANSIONS, but you can't pass an function-quoted lambda
 244 ;; because WITH-TEST creates a too-complex environment for conversion
 245 ;; from an interpreted lambda.
 246 (with-test (:name :compiled-setq-macroexpand-hook :skipped-on :interpreter)
 247   (sb-int:collect ((expansions))
 248     (let ((*macroexpand-hook*
 249            (lambda (expander form env)
 250              (let ((new (funcall expander form env)))
 251                (when (or (symbolp form) (eq (car form) 'setf))
 252                  (expansions (list form new)))
 253                new))))
 254       (compile nil '(lambda (x)
 255                      (symbol-macrolet ((ref-it (aref a 0))
 256                                        (a *foo-array*)
 257                                        (thing ref-it))
 258                        (setq thing x)))))
 259     (assert (equal-mod-gensyms
 260              (expansions)
 261              '((thing ref-it)
 262                (ref-it (aref a 0))
 263                (a *foo-array*)
 264                ((setf thing x)
 265                 (let* ((a0 a) (new1 x))
 266                   (funcall #'(setf aref) new1 a0 0))))))))
 267
 268 (with-test (:name :remf-basic-correctness)
 269   (flet ((try (indicator input expect)
 270            (handler-case (sb-impl::%remf indicator (copy-list input))
 271              (error () (assert (eq expect :error)))
 272              (:no-error (newval flag)
 273                (assert (and (equal newval expect)
 274                             (eq flag (not (equal newval input)))))
 275                (let* ((foo (vector (copy-list input)))
 276                       (removedp (remf (aref foo 0) indicator)))
 277                  (assert (equal (aref foo 0) expect))
 278                  (assert (eq removedp (not (equal input expect)))))))))
 279     (try 'x '() '())
 280     (try 'x 'a :error)
 281     (try 'x '(a) :error)
 282     (try 'x '(a . b) :error)
 283     (try 'x '(a b . c) :error)
 284     ;; indicator not found
 285     (try 'weazel '(a b :foo :goo) '(a b :foo :goo))
 286     (try 'weazel '(a b :foo :goo . 3) :error) ; improper
 287     (try 'weazel '(a b :foo :goo baz) :error) ; odd length
 288     ;; pair deleted from head
 289     (try 'a '(a b :foo :goo a 3) '(:foo :goo a 3))
 290     (try 'a '(a b :foo :goo) '(:foo :goo))
 291     (try 'a '(a b :foo) '(:foo)) ; odd length unnoticed
 292     (try 'a '(a b . :foo) :error) ; but won't return a non-list
 293     ;; pair deleted from interior
 294     (try :foo '(a b :foo :goo) '(a b))
 295     (try :foo '(a b :foo :goo :boo) '(a b :boo)) ; odd length unnoticed
 296     (try :foo '(a b :foo :goo :foo) '(a b :foo)) ; other :FOO is irrelevant
 297     (try :foo '(a b :foo :goo . bad) :error)
 298     ))
 299
 300 (with-test (:name :incf-argument-eval-order)
 301   (let ((testvar 1))
 302     (flet ((double-it () (setq testvar (* 2 testvar))))
 303       (incf testvar (double-it)))
 304     ;; testvar should be 4, not 3, because the read for INCF
 305     ;; occurs after doubling.
 306     (assert (eql testvar 4))))
 307
 308 ;; Simple DEFSETF test
 309 (with-test (:name :defsetf-subseq-constant-indices)
 310   (assert (equal-mod-gensyms
 311            (macroexpand-1 '(setf (subseq (foo) 4 6) "Hi"))
 312            '(let* ((subform (foo)) (newval "Hi"))
 313               (replace subform newval :start1 4 :end1 6)
 314               newval))))
 315
 316 (with-test (:name :defsetf-gethash)
 317   (assert (equal-mod-gensyms
 318            (macroexpand-1 '(push 1 (gethash :k tbl '(none))))
 319            ;; the only temp var should be for TBL
 320            '(let* ((#1=#:hashtable tbl))
 321              (sb-kernel:%puthash :k #1# (cons 1 (gethash :k #1# '(none))))))))
 322
 323 ;; Setup for CLHS hairy example (not working)
 324 (defvar *xy* (make-array '(10 10)))
 325 (defun xy (&key ((x x) 0) ((y y) 0)) (aref *xy* x y))
 326 (defun set-xy (new-value &key ((x x) 0) ((y y) 0))
 327   (setf (aref *xy* x y) new-value))
 328 (defsetf xy (&key ((x x) 0) ((y y) 0)) (store)
 329    `(set-xy ,store 'x ,x 'y ,y))
 330 ;; FIXME: add tests
 331
 332 (with-test (:name :setf-of-apply-aref)
 333   (let ((n 0)
 334         (array (make-array '(3 2 7)))
 335         (indices (list 0 0 0)))
 336     (flet ((bump-index ()
 337              (let ((i (1- (length indices))))
 338                (loop (cond ((< (nth i indices) (1- (array-dimension array i)))
 339                             (return (incf (nth i indices))))
 340                            ((= i 0) (return nil))
 341                            (t (setf (nth i indices) 0) (decf i)))))))
 342       (loop (setf (apply #'aref array indices) (incf n))
 343             (unless (bump-index) (return)))
 344       (assert (equalp
 345                #3A(((1 2 3 4 5 6 7) (8 9 10 11 12 13 14))
 346                    ((15 16 17 18 19 20 21) (22 23 24 25 26 27 28))
 347                    ((29 30 31 32 33 34 35) (36 37 38 39 40 41 42)))
 348                array)))))
 349
 350 (define-modify-macro append2+ (a b &optional c &rest more) append
 351                      "append at least two more lists onto the place")
 352 (define-modify-macro other-incf (&optional (delta 1)) +)
 353
 354 (with-test (:name :define-modify-macro-arg-eval-order)
 355   ;; Uses a bunch of temps
 356   (assert (equal-mod-gensyms
 357            (macroexpand-1 '(append2+ (car x) (f) (g) (h) (i) (j)))
 358            '(let* ((x1 x) (a (f)) (b (g)) (c (h)) (g3 (i)) (g4 (j)))
 359              (sb-kernel:%rplaca x1 (append (car x1) a b c g3 g4)))))
 360
 361   ;; Calling OTHER-INCF with the default delta of 1 uses no temps.
 362   (assert (equal (macroexpand '(other-incf *foo-base*))
 363                  '(setq *foo-base* (+ *foo-base* 1))))
 364   ;; Otherwise, it uses a temp because it "doesn't know" that + commutes.
 365   (assert (equal-mod-gensyms (macroexpand '(other-incf b (ff)))
 366                              '(let* ((delta (ff))) (setq b (+ b delta)))))
 367   ;; And the following result should be identical to that of ordinary INCF.
 368   (let ((testvar 1))
 369     (flet ((double-it () (setq testvar (* 2 testvar))))
 370       (other-incf testvar (double-it)))
 371     (assert (eql testvar 4))))
 372
 373 (with-test (:name :incf-avoid-temp-vars)
 374   (assert (equal (macrolet ((x () 'y)
 375                             (try (&environment env)
 376                               (list 'quote (macroexpand-1 '(incf (x)) env))))
 377                    (try))
 378                  '(setq y (+ 1 y)))))
 379
 380 (with-test (:name :push-getf-avoid-temp-vars)
 381   ;; Not only should subforms of PLACE avoid binding temp vars for constants,
 382   ;; so should the arguments to GETF and %PUTF.
 383   ;; This reads (AREF A) twice but I think that's unavoidable
 384   (assert (equal-mod-gensyms
 385            (macroexpand-1 '(push 'foo (getf (aref a (x) 1) :my-indicator '(t))))
 386            '(let* ((a642 a)
 387                    (g643 (x))
 388                    (new645
 389                     (cons 'foo (getf (aref a642 g643 1) :my-indicator '(t)))))
 390              (let ((new644
 391                     (sb-impl::%putf (aref a642 g643 1) :my-indicator new645)))
 392                (funcall #'(setf aref) new644 a642 g643 1)
 393                new645)))))
 394
 395 (defparameter *foobar-list* (list 1 2 3))
 396 (defun my-foobar-list () *foobar-list*)
 397 (defun (setf my-foobar-list) (newval)
 398   (incf (car *foobar-list*))
 399   (setq *foobar-list* newval))
 400 (with-test (:name :pop-eval-order-bug-1454021)
 401   ;; Assert that POP reads CAR of the list before invoking the setter
 402   (assert (eq (pop (my-foobar-list)) 1)))
 403
 404 ;; lp#1460360
 405 (with-test (:name :pushnew-evals-keyword-args)
 406   ;; Though not directly supported by an example in CLHS,
 407   ;; convention seems to dictate that :KEY, :TEST, :TEST-NOT are not
 408   ;; parsed by DS-BIND, but instead are blindly forwarded to ADJOIN.
 409   (let ((k :test) (v #'equal) (list nil))
 410     (pushnew '(hi) list k v)
 411     (assert (equal list '((hi))))))
 412
 413 (with-test (:name :setf-ldb-syntax)
 414   ;; this gets both a warning and an error.
 415   (assert-error (let ((x 0)) (setf (ldb (byte 4 2 3) x) 1))))
 416
 417 (with-test (:name :setf-ldb-recognize-local-macros)
 418   ;; This lambda should call neither %LDB nor %DPB
 419   (assert (not (ctu:find-named-callees
 420                 (compile nil
 421                          '(lambda (x)
 422                            (declare (type (cons) x))
 423                            (symbol-macrolet ((b (byte 4 3)))
 424                              (incf (ldb b (truly-the fixnum (car x)))))))))))
 425
 426 ;; There's aren't a lot of reasonable uses of the setf "getter" for LOGBITP.
 427 ;; It might come in handy for SHIFTF or ROTATEF, or this:
 428 (define-modify-macro negatef () not)
 429 (with-test (:name :modify-macro-logbitp)
 430   (dotimes (i 11)
 431     (let ((foo (list 0)))
 432       ;; To be extra tricky, flip the Ith bit in a 9-bit subfield
 433       ;; starting at 2. This should have no effect for I >= 9.
 434       (negatef (logbitp i (ldb (byte 9 2) (car foo))))
 435       (if (< i 9)
 436           (assert (= (car foo) (ash 1 (+ i 2))))
 437           (assert (= (car foo) 0))))))
 438
 439 ;; a DEFSETF lambda list is not a macro lambda-list
 440 (with-test (:name :defsetf-lambda-list-strictness)
 441   (assert-error
 442    ;; All implementations agree that this is malformed.
 443    (macroexpand-1 '(defsetf baz (a . other-stuff) (v) ''who-cares))))
 444
 445
 446 (with-test (:name :shiftf-let*)
 447   (define-setf-expander shiftf-let* ()
 448     (let ((a (gensym "A"))
 449           (b (gensym "B"))
 450           (store (gensym "STORE")))
 451       (values
 452        (list a b)
 453        `(10 (1+ ,a))
 454        (list store)
 455        (list 'list a b store)
 456        b)))
 457   (assert (eql (funcall (compile nil `(lambda () (shiftf (shiftf-let*) 21)))) 11)))