source: trunk/source/tests/ansi-tests/defsetf.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 20 17:18:01 2003
4;;;; Contains: Tests of DEFSETF
5
6(in-package :cl-test)
7
8;;; Need to add non-error tests
9
10(def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn
11                                  nonexistent-update-fn))
12
13;;; Short form
14
15(defun defsetf.1-accessor (x)
16  (cadr x))
17
18(defun defsetf.1-accessor-settor (x val)
19  (setf (cadr x) val))
20
21(deftest defsetf.1
22  (progn
23    (let ((vals (multiple-value-list
24                 (defsetf defsetf.1-accessor defsetf.1-accessor-settor))))
25      (assert (equal vals '(defsetf.1-accessor))
26              ()
27              "Return values are ~A~%" vals))
28    (eval
29     '(let ((x (list 1 2 3)))
30        (values
31         (setf (defsetf.1-accessor x) 4)
32         x))))
33  4
34  (1 4 3))
35
36;;; Use a macro instead of a function for updatefn
37
38(defun defsetf.2-accessor (x)
39  (cadr x))
40
41(defmacro defsetf.2-accessor-settor (x val)
42  `(setf (cadr ,x) ,val))
43
44(defparameter *defsetf.2-vals*
45  (multiple-value-list
46   (defsetf defsetf.2-accessor defsetf.2-accessor-settor)))
47
48(deftest defsetf.2a
49  *defsetf.2-vals*
50  (defsetf.2-accessor))
51
52(deftest defsetf.2b
53  (let ((x (list 1 2 3)))
54    (values
55     (setf (defsetf.2-accessor x) 4)
56     x))
57  4
58  (1 4 3))
59
60;;; Documentation string
61
62(defun defsetf.3-accessor (x)
63  (cadr x))
64
65(defun defsetf.3-accessor-settor (x val)
66  (setf (cadr x) val))
67
68(defparameter *defsetf.3-vals*
69  (multiple-value-list
70   (defsetf defsetf.3-accessor defsetf.3-accessor-settor
71     "A doc string")))
72
73(deftest defsetf.3a
74  *defsetf.3-vals*
75  (defsetf.3-accessor))
76
77(deftest defsetf.3b
78  (let ((doc (documentation 'defsetf.3-accessor 'setf)))
79    (or (null doc) (equalt doc "A doc string")))
80  t)
81
82(deftest defsetf.3c
83  (let ((x (list 1 2 3)))
84    (values
85     (setf (defsetf.3-accessor x) 4)
86     x))
87  4
88  (1 4 3))
89
90;;; Long form of defsetf
91
92(defun defsetf.4-accessor (n seq)
93  (elt seq n))
94
95(defparameter *defsetf.4-vals*
96  (multiple-value-list
97   (defsetf defsetf.4-accessor (n seq) (val)
98     (declare)
99     "Doc string for defsetf.4-accessor setf"
100     `(setf (elt ,seq ,n) ,val))))
101
102(deftest defsetf.4a
103  *defsetf.4-vals*
104  (defsetf.4-accessor))
105
106(deftest defsetf.4b
107  (let ((doc (documentation 'defsetf.4-accessor 'setf)))
108    (or (null doc) (equalt doc "Doc string for defsetf.4-accessor setf")))
109  t)
110
111(deftest defsetf.4c
112  (let ((x (list 1 2 3 4))
113        (i 0)
114        (j nil)
115        (k nil))
116    (values
117     (setf (defsetf.4-accessor
118             (progn (setf j (incf i))
119                    2)
120             (progn (setf k (incf i)) x))
121           (progn (incf i) 'a))
122     x
123     i j k))
124  a
125  (1 2 a 4)
126  3 1 2)
127
128;;; Test that there's a block around the forms in long form defsetf
129
130(defun defsetf.5-accessor (x) (car x))
131
132(defsetf defsetf.5-accessor (y) (val)
133  (return-from defsetf.5-accessor `(setf (car ,y) ,val)))
134
135(deftest defsetf.5a
136  (let ((x (cons 'a 'b)))
137    (values
138     (setf (defsetf.5-accessor x) 'c)
139     x))
140  c (c . b))
141
142;;; Test that the defsetf expansion function is defined in the same
143;;; lexical environment that the defsetf appears in
144
145(defun defsetf.6-accessor (x) (car x))
146
147(let ((z 'car))
148  (defsetf defsetf.6-accessor (y) (val)
149    `(setf (,z ,y) ,val)))
150
151(deftest defsetf.6a
152  (let ((x (cons 'a 'b)))
153    (values
154     (setf (defsetf.6-accessor x) 'c)
155     x))
156  c (c . b))
Note: See TracBrowser for help on using the repository browser.