1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / 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 ;;; success