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   (declare (ignore new))
  58   (if (macro-function 'defsetf-env-trick env)
  59       :local
  60       :global))
  61
  62 (defsetf test-defsetf-env-2  (local global &environment env) (new)
  63   (declare (ignore new))
  64   (if (macro-function 'defsetf-env-trick env)
  65       local
  66       global))
  67
  68 (assert (eq :local (macrolet ((defsetf-env-trick ()))
  69                      (setf (test-defsetf-env-1) 13))))
  70
  71 (assert (eq :global (setf (test-defsetf-env-1) 13)))
  72
  73 (assert (eq :local (macrolet ((defsetf-env-trick ()))
  74                      (setf (test-defsetf-env-2 :local :oops) 13))))
  75
  76 (assert (eq :global (setf (test-defsetf-env-2 :oops :global) 13)))
  77
  78 (assert (eq :error
  79             (handler-case
  80                 (eval '(defsetf test-defsetf-aux (&aux aux) (new) nil))
  81               (error ()
  82                 :error))))
  83
  84 (handler-bind ((style-warning #'error))
  85   (compile nil '(lambda ()
  86                  (defsetf test-defsetf-no-env (foo) (new)
  87                    `(set-foo ,foo ,new))))
  88   (compile nil '(lambda ()
  89                  (defsetf test-defsetf-ignore-env (foo &environment env) (new)
  90                    (declare (ignore env))
  91                    `(set-foo ,foo ,new)))))
  92
  93 ;;; Not required by the spec, but allowes compiler-macros for SETF-functiosn
  94 ;;; to see their constant argument forms.
  95 (with-test (:name :constantp-aware-get-setf-expansion)
  96   (multiple-value-bind (temps values stores set get)
  97       (get-setf-expansion '(foo 1 2 3))
  98     (assert (not temps))
  99     (assert (not values))
 100     (assert (equal `(funcall #'(setf foo) ,@stores 1 2 3) set))
 101     (assert (equal '(foo 1 2 3) get))))
 102
 103 (with-test (:name :update-fn-should-be-a-symbol-in-defsetf)
 104   (assert (eq :error
 105             (handler-case
 106                 (eval '(defsetf access-fn 5))
 107               (error ()
 108                 :error)))))
 109
 110 (with-test (:name :getf-unused-default-variable)
 111   (handler-bind ((style-warning #'error))
 112     (compile nil `(lambda (x y)
 113                     (setf (gethash :x x 0) 4)
 114                     (setf (getf y :y 0) 4)
 115                     (setf (get 'z :z 0) 4)))))
 116
 117 (with-test (:name :setf-fun-and-macro-full-warn)
 118   (multiple-value-bind (fun warnings-p failure-p)
 119       (compile nil '(lambda (x) (setf (shoe-color x) 'cordovan)))
 120     (assert (and fun warnings-p (not failure-p))))
 121   (assert (typep (handler-case (eval '(defsetf shoe-color set-shoe-color))
 122                    (warning (c) c))
 123                  '(and warning (not style-warning)))))
 124
 125 (with-test (:name :setf-fun-and-macro-style-1)
 126   (eval '(defun (setf shoe-size) (new x) x new))
 127   (assert (typep (handler-case (eval '(defsetf shoe-size set-shoe-size))
 128                    (warning (c) c))
 129                  'style-warning)))
 130
 131 ;; This is a test of the compiler, but it belongs with the above.
 132 (defvar *tmpfile* "setf-tmp.lisp")
 133 (with-test (:name :setf-fun-and-macro-style-2)
 134   (unwind-protect
 135        (progn
 136          ;; verify the test's precondition, for sanity
 137          (assert (not (fboundp '(setf shoe-count))))
 138          (with-open-file (f *tmpfile* :direction :output
 139                                       :if-exists :supersede)
 140            (prin1 '(defun (setf shoe-count) (new x) (print x) new) f)
 141            (prin1 '(defsetf shoe-count set-shoe-count) f))
 142          ;; Expect a warning because the compiler knows about
 143          ;; (SETF SHOE-COUNT), which isn't yet FBOUNDP,
 144          ;; and then we also compile a SETF inverse.
 145          (multiple-value-bind (output warnings-p failure-p)
 146              (compile-file *tmpfile*)
 147            (ignore-errors (delete-file output))
 148            (assert (and output warnings-p (not failure-p)))))
 149       (ignore-errors (delete-file *tmpfile*))))
 150
 151 ;; Make sure that the second values of INFO :SETF :EXPANDER/:INVERSE
 152 ;; are not both T.  Each of :EXPANDER and :INVERSE set the other one
 153 ;; to NIL but the WINP return value from INFO was still T so could not
 154 ;; reliably be used to test existence or non-existence.
 155 (defsetf foo1 set-foo1)
 156 (define-setf-expander foo1 (a b) (declare (ignore a b)))
 157
 158 (define-setf-expander foo2 (a b) (declare (ignore a b)))
 159 (defsetf foo2 set-foo2)
 160
 161 (with-test (:name :setf-inverse-clears-expander-and-vice-versa)
 162   (multiple-value-bind (val winp) (sb-int:info :setf :inverse 'foo1)
 163     (assert (and (not val) (not winp))))
 164   (multiple-value-bind (val winp) (sb-int:info :setf :expander 'foo2)
 165     (assert (and (not val) (not winp)))))
 166
 167 ;;; success