Really restore clisp cross-compilation.
[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 ;;; 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 ;;; success