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