0.8.12.15:
[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 ;;; success
43 (quit :unix-status 104)