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 ;;; success