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 ;; Make sure that the second values of INFO :SETF :EXPANDER/:INVERSE
 164 ;; are not both T.  Each of :EXPANDER and :INVERSE set the other one
 165 ;; to NIL but the WINP return value from INFO was still T so could not
 166 ;; reliably be used to test existence or non-existence.
 167 (defsetf foo1 set-foo1)
 168 (define-setf-expander foo1 (a b) (declare (ignore a b)))
 169
 170 (define-setf-expander foo2 (a b) (declare (ignore a b)))
 171 (defsetf foo2 set-foo2)
 172
 173 (with-test (:name :setf-inverse-clears-expander-and-vice-versa)
 174   (multiple-value-bind (val winp) (sb-int:info :setf :inverse 'foo1)
 175     (assert (and (not val) (not winp))))
 176   (multiple-value-bind (val winp) (sb-int:info :setf :expander 'foo2)
 177     (assert (and (not val) (not winp)))))
 178
 179 ;; The expander for (CADAR x) should behave as (CAR (CDAR x)) etc.
 180 ;; This mainly affects read/modify/write semantics.
 181 (with-test (:name :car+cdr-compositions-lp1450968)
 182   (flet ((maketree (n &aux (count -1))
 183            (labels ((recurse (n)
 184                       (if (zerop n)
 185                           (incf count)
 186                           (cons (recurse (1- n)) (recurse (1- n))))))
 187              (recurse n))))
 188     (loop
 189      for n-ops from 2 to 4
 190      do (dotimes (bitmask (ash 1 n-ops))
 191           (let* ((ops (coerce (loop for i below n-ops
 192                                     collect (if (logbitp i bitmask) #\D #\A))
 193                               'string))
 194                  (accessor (sb-int:symbolicate "C" ops "R"))
 195                  (tree (maketree n-ops))
 196                  (left (car tree))
 197                  (right (cdr tree)))
 198             (assert (eql (funcall accessor tree) bitmask))
 199             (let ((f (compile nil
 200                               `(lambda (obj)
 201                                  (incf (,accessor obj)
 202                                        (progn (rplaca obj nil)
 203                                               (rplacd obj nil)
 204                                               1000))))))
 205               (funcall f tree)
 206               (let ((tree* (cons left right)))
 207                 (assert (eql (funcall accessor tree*)
 208                              (+ bitmask 1000))))))))))
 209
 210 (define-symbol-macro %foofy1% (values a b c))
 211 (define-symbol-macro %foofy2% (values x y z))
 212 ;; PSETF and PSETQ eliminate vacuous LET* forms.
 213 (with-test (:name :psetf-expansion-maximally-concise)
 214   (dolist (op '(psetq psetf))
 215     (let* ((form `(,op %foofy1% (f) %foofy2% (g)))
 216            (expansion (let ((*gensym-counter* 1)) (macroexpand-1 form)))
 217            (expect '(multiple-value-bind (new1 new2 new3) (f)
 218                      (multiple-value-bind (new4 new5 new6) (g)
 219                        (setq a new1) (setq b new2) (setq c new3)
 220                        (setq x new4) (setq y new5) (setq z new6)
 221                        nil))))
 222       (assert (equal-mod-gensyms expansion expect)))))
 223
 224 (with-test (:name :defsetf-syntax-errors)
 225   (dolist (test '((defsetf foo set-foo junk other-junk) ; would accept
 226                   (defsetf foo set-foo . junk))) ; would crash
 227     (assert (search "Ill-formed DEFSETF"
 228                     (simple-condition-format-control
 229                      (nth-value 1 (ignore-errors (macroexpand-1 test)))))))
 230   ;; no (SETF (SETF f)) methods
 231   (assert-error (macroexpand-1 '(defsetf (setf foo) set-setf-foo))))
 232
 233 (defmacro mymacro () '*x*)
 234 (define-symbol-macro foox (car *x*))
 235 (with-test (:name :setf-of-symbol-macro)
 236   (assert (equal (macroexpand-1 '(setf foox 3)) '(sb-kernel:%rplaca *x* 3))))
 237 (with-test (:name :setf-of-macro)
 238   (assert (equal (macroexpand-1 '(setf (mymacro) 3)) '(setq *x* 3))))
 239
 240 (defvar *x* (list 1))
 241 (defun set-foox (x)
 242   (declare (type (integer 1 20) foox))
 243   (setq foox x))
 244 (with-test (:name :setf-of-symbol-macro-typecheck)
 245   ;; this was not broken, but since I've deleted the comment
 246   ;;  "FIXME: [Free] type declaration. -- APD, 2002-01-26"
 247   ;; from ir1-translators, it's probably worth a test
 248   ;; since at some point it must not have worked as intended.
 249   (assert-error (set-foox 99)))
 250
 251 (declaim (special *foo-array*))
 252 ;; When dealing with symbol-macros, compiled SETQ would locate the leaf
 253 ;; for the symbol and then covertly stuff in the expansion to a SETF form.
 254 ;; *MACROEXPAND-HOOK* would see the SETF but not the expansion
 255 ;; of the symbol, except those expansions occurring with GET-SETF-EXPANSION.
 256 ;; Now it can see the first-round expansion too.
 257 ;; The macroexpand hook for this test needs to be compiled, but you can't
 258 ;; pass a quoted lambda (as a sexpr) to COMPILE because it needs to
 259 ;; capture EXPANSIONS, but you can't pass an function-quoted lambda
 260 ;; because WITH-TEST creates a too-complex environment for conversion
 261 ;; from an interpreted lambda.
 262 (with-test (:name :compiled-setq-macroexpand-hook :skipped-on :interpreter)
 263   (sb-int:collect ((expansions))
 264     (let ((*macroexpand-hook*
 265            (lambda (expander form env)
 266              (let ((new (funcall expander form env)))
 267                (when (or (symbolp form) (eq (car form) 'setf))
 268                  (expansions (list form new)))
 269                new))))
 270       (compile nil '(lambda (x)
 271                      (symbol-macrolet ((ref-it (aref a 0))
 272                                        (a *foo-array*)
 273                                        (thing ref-it))
 274                        (setq thing x)))))
 275     (assert (equal-mod-gensyms
 276              (expansions)
 277              '((thing ref-it)
 278                (ref-it (aref a 0))
 279                (a *foo-array*)
 280                ((setf thing x)
 281                 (let* ((a0 a) (new1 x))
 282                   (funcall #'(setf aref) new1 a0 0))))))))
 283
 284 (with-test (:name :remf-basic-correctness)
 285   (flet ((try (indicator input expect)
 286            (handler-case (sb-impl::%remf indicator (copy-list input))
 287              (error () (assert (eq expect :error)))
 288              (:no-error (newval flag)
 289                (assert (and (equal newval expect)
 290                             (eq flag (not (equal newval input)))))
 291                (let* ((foo (vector (copy-list input)))
 292                       (removedp (remf (aref foo 0) indicator)))
 293                  (assert (equal (aref foo 0) expect))
 294                  (assert (eq removedp (not (equal input expect)))))))))
 295     (try 'x '() '())
 296     (try 'x 'a :error)
 297     (try 'x '(a) :error)
 298     (try 'x '(a . b) :error)
 299     (try 'x '(a b . c) :error)
 300     ;; indicator not found
 301     (try 'weazel '(a b :foo :goo) '(a b :foo :goo))
 302     (try 'weazel '(a b :foo :goo . 3) :error) ; improper
 303     (try 'weazel '(a b :foo :goo baz) :error) ; odd length
 304     ;; pair deleted from head
 305     (try 'a '(a b :foo :goo a 3) '(:foo :goo a 3))
 306     (try 'a '(a b :foo :goo) '(:foo :goo))
 307     (try 'a '(a b :foo) '(:foo)) ; odd length unnoticed
 308     (try 'a '(a b . :foo) :error) ; but won't return a non-list
 309     ;; pair deleted from interior
 310     (try :foo '(a b :foo :goo) '(a b))
 311     (try :foo '(a b :foo :goo :boo) '(a b :boo)) ; odd length unnoticed
 312     (try :foo '(a b :foo :goo :foo) '(a b :foo)) ; other :FOO is irrelevant
 313     (try :foo '(a b :foo :goo . bad) :error)
 314     ))
 315
 316 (with-test (:name :incf-argument-eval-order)
 317   (let ((testvar 1))
 318     (flet ((double-it () (setq testvar (* 2 testvar))))
 319       (incf testvar (double-it)))
 320     ;; testvar should be 4, not 3, because the read for INCF
 321     ;; occurs after doubling.
 322     (assert (eql testvar 4))))
 323
 324 ;; Simple DEFSETF test
 325 (with-test (:name :defsetf-subseq-constant-indices)
 326   (assert (equal-mod-gensyms
 327            (macroexpand-1 '(setf (subseq (foo) 4 6) "Hi"))
 328            '(let* ((subform (foo)) (newval "Hi"))
 329               (replace subform newval :start1 4 :end1 6)
 330               newval))))
 331
 332 (with-test (:name :defsetf-gethash)
 333   (assert (equal-mod-gensyms
 334            (macroexpand-1 '(push 1 (gethash :k tbl '(none))))
 335            ;; the only temp var should be for TBL
 336            '(let* ((#1=#:hashtable tbl))
 337              (sb-kernel:%puthash :k #1# (cons 1 (gethash :k #1# '(none))))))))
 338
 339 ;; Setup for CLHS hairy example (not working)
 340 (defvar *xy* (make-array '(10 10)))
 341 (defun xy (&key ((x x) 0) ((y y) 0)) (aref *xy* x y))
 342 (defun set-xy (new-value &key ((x x) 0) ((y y) 0))
 343   (setf (aref *xy* x y) new-value))
 344 (defsetf xy (&key ((x x) 0) ((y y) 0)) (store)
 345    `(set-xy ,store 'x ,x 'y ,y))
 346 ;; FIXME: add tests
 347
 348 (with-test (:name :setf-of-apply-aref)
 349   (let ((n 0)
 350         (array (make-array '(3 2 7)))
 351         (indices (list 0 0 0)))
 352     (flet ((bump-index ()
 353              (let ((i (1- (length indices))))
 354                (loop (cond ((< (nth i indices) (1- (array-dimension array i)))
 355                             (return (incf (nth i indices))))
 356                            ((= i 0) (return nil))
 357                            (t (setf (nth i indices) 0) (decf i)))))))
 358       (loop (setf (apply #'aref array indices) (incf n))
 359             (unless (bump-index) (return)))
 360       (assert (equalp
 361                #3A(((1 2 3 4 5 6 7) (8 9 10 11 12 13 14))
 362                    ((15 16 17 18 19 20 21) (22 23 24 25 26 27 28))
 363                    ((29 30 31 32 33 34 35) (36 37 38 39 40 41 42)))
 364                array)))))
 365
 366 (define-modify-macro append2+ (a b &optional c &rest more) append
 367                      "append at least two more lists onto the place")
 368 (define-modify-macro other-incf (&optional (delta 1)) +)
 369
 370 (with-test (:name :define-modify-macro-arg-eval-order)
 371   ;; Uses a bunch of temps
 372   (assert (equal-mod-gensyms
 373            (macroexpand-1 '(append2+ (car x) (f) (g) (h) (i) (j)))
 374            '(let* ((x1 x) (a (f)) (b (g)) (c (h)) (g3 (i)) (g4 (j)))
 375              (sb-kernel:%rplaca x1 (append (car x1) a b c g3 g4)))))
 376
 377   ;; Calling OTHER-INCF with the default delta of 1 uses no temps.
 378   (assert (equal (macroexpand '(other-incf *foo-base*))
 379                  '(setq *foo-base* (+ *foo-base* 1))))
 380   ;; Otherwise, it uses a temp because it "doesn't know" that + commutes.
 381   (assert (equal-mod-gensyms (macroexpand '(other-incf b (ff)))
 382                              '(let* ((delta (ff))) (setq b (+ b delta)))))
 383   ;; And the following result should be identical to that of ordinary INCF.
 384   (let ((testvar 1))
 385     (flet ((double-it () (setq testvar (* 2 testvar))))
 386       (other-incf testvar (double-it)))
 387     (assert (eql testvar 4))))
 388
 389 (with-test (:name :incf-avoid-temp-vars)
 390   (assert (equal (macrolet ((x () 'y)
 391                             (try (&environment env)
 392                               (list 'quote (macroexpand-1 '(incf (x)) env))))
 393                    (try))
 394                  '(setq y (+ 1 y)))))
 395
 396 (with-test (:name :push-getf-avoid-temp-vars)
 397   ;; Not only should subforms of PLACE avoid binding temp vars for constants,
 398   ;; so should the arguments to GETF and %PUTF.
 399   ;; This reads (AREF A) twice but I think that's unavoidable
 400   (assert (equal-mod-gensyms
 401            (macroexpand-1 '(push 'foo (getf (aref a (x) 1) :my-indicator '(t))))
 402            '(let* ((a642 a)
 403                    (g643 (x))
 404                    (new645
 405                     (cons 'foo (getf (aref a642 g643 1) :my-indicator '(t)))))
 406              (let ((new644
 407                     (sb-impl::%putf (aref a642 g643 1) :my-indicator new645)))
 408                (funcall #'(setf aref) new644 a642 g643 1)
 409                new645)))))
 410
 411 (defparameter *foobar-list* (list 1 2 3))
 412 (defun my-foobar-list () *foobar-list*)
 413 (defun (setf my-foobar-list) (newval)
 414   (incf (car *foobar-list*))
 415   (setq *foobar-list* newval))
 416 (with-test (:name :pop-eval-order-bug-1454021)
 417   ;; Assert that POP reads CAR of the list before invoking the setter
 418   (assert (eq (pop (my-foobar-list)) 1)))
 419
 420 ;; lp#1460360
 421 (with-test (:name :pushnew-evals-keyword-args)
 422   ;; Though not directly supported by an example in CLHS,
 423   ;; convention seems to dictate that :KEY, :TEST, :TEST-NOT are not
 424   ;; parsed by DS-BIND, but instead are blindly forwarded to ADJOIN.
 425   (let ((k :test) (v #'equal) (list nil))
 426     (pushnew '(hi) list k v)
 427     (assert (equal list '((hi))))))
 428
 429 (with-test (:name :setf-ldb-syntax)
 430   ;; this gets both a warning and an error.
 431   (assert-error (let ((x 0)) (setf (ldb (byte 4 2 3) x) 1))))
 432
 433 (with-test (:name :setf-ldb-recognize-local-macros)
 434   ;; This lambda should call neither %LDB nor %DPB
 435   (assert (not (ctu:find-named-callees
 436                 (compile nil
 437                          '(lambda (x)
 438                            (declare (type (cons) x))
 439                            (symbol-macrolet ((b (byte 4 3)))
 440                              (incf (ldb b (truly-the fixnum (car x)))))))))))
 441
 442 ;; There's aren't a lot of reasonable uses of the setf "getter" for LOGBITP.
 443 ;; It might come in handy for SHIFTF or ROTATEF, or this:
 444 (define-modify-macro negatef () not)
 445 (with-test (:name :modify-macro-logbitp)
 446   (dotimes (i 11)
 447     (let ((foo (list 0)))
 448       ;; To be extra tricky, flip the Ith bit in a 9-bit subfield
 449       ;; starting at 2. This should have no effect for I >= 9.
 450       (negatef (logbitp i (ldb (byte 9 2) (car foo))))
 451       (if (< i 9)
 452           (assert (= (car foo) (ash 1 (+ i 2))))
 453           (assert (= (car foo) 0))))))
 454
 455 ;; a DEFSETF lambda list is not a macro lambda-list
 456 (with-test (:name :defsetf-lambda-list-strictness)
 457   (assert-error
 458    ;; All implementations agree that this is malformed.
 459    (macroexpand-1 '(defsetf baz (a . other-stuff) (v) ''who-cares))))
 460
 461
 462 (with-test (:name :shiftf-let*)
 463   (define-setf-expander shiftf-let* ()
 464     (let ((a (gensym "A"))
 465           (b (gensym "B"))
 466           (store (gensym "STORE")))
 467       (values
 468        (list a b)
 469        `(10 (1+ ,a))
 470        (list store)
 471        (list 'list a b store)
 472        b)))
 473   (assert (eql (funcall (compile nil `(lambda () (shiftf (shiftf-let*) 21)))) 11)))