/[gcl]/gcl/ansi-tests/defsetf.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/defsetf.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Sun Apr 20 22:59:25 2003 UTC revision 1.2 by pfdietz, Wed Jan 19 14:02:45 2005 UTC
# Line 9  Line 9 
9    
10  (def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn  (def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn
11                                    nonexistent-update-fn))                                    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        (let ((x (list 1 2 3)))
29          (values
30           (setf (defsetf.1-accessor x) 4)
31           x)))
32      4
33      (1 4 3))
34    
35    ;;; Use a macro instead of a function for updatefn
36    
37    (defun defsetf.2-accessor (x)
38      (cadr x))
39    
40    (defmacro defsetf.2-accessor-settor (x val)
41      `(setf (cadr ,x) ,val))
42    
43    (defparameter *defsetf.2-vals*
44      (multiple-value-list
45       (defsetf defsetf.2-accessor defsetf.2-accessor-settor)))
46    
47    (deftest defsetf.2a
48      *defsetf.2-vals*
49      (defsetf.2-accessor))
50    
51    (deftest defsetf.2b
52      (let ((x (list 1 2 3)))
53        (values
54         (setf (defsetf.2-accessor x) 4)
55         x))
56      4
57      (1 4 3))
58    
59    ;;; Documentation string
60    
61    (defun defsetf.3-accessor (x)
62      (cadr x))
63    
64    (defun defsetf.3-accessor-settor (x val)
65      (setf (cadr x) val))
66    
67    (defparameter *defsetf.3-vals*
68      (multiple-value-list
69       (defsetf defsetf.3-accessor defsetf.3-accessor-settor
70         "A doc string")))
71    
72    (deftest defsetf.3a
73      *defsetf.3-vals*
74      (defsetf.3-accessor))
75    
76    (deftest defsetf.3b
77      (let ((doc (documentation 'defsetf.3-accessor 'setf)))
78        (or (null doc) (equalt doc "A doc string")))
79      t)
80    
81    (deftest defsetf.3c
82      (let ((x (list 1 2 3)))
83        (values
84         (setf (defsetf.3-accessor x) 4)
85         x))
86      4
87      (1 4 3))
88    
89    ;;; Long form of defsetf
90    
91    (defun defsetf.4-accessor (n seq)
92      (elt seq n))
93    
94    (defparameter *defsetf.4-vals*
95      (multiple-value-list
96       (defsetf defsetf.4-accessor (n seq) (val)
97         (declare)
98         "Doc string for defsetf.4-accessor setf"
99         `(setf (elt ,seq ,n) ,val))))
100    
101    (deftest defsetf.4a
102      *defsetf.4-vals*
103      (defsetf.4-accessor))
104    
105    (deftest defsetf.4b
106      (let ((doc (documentation 'defsetf.4-accessor 'setf)))
107        (or (null doc) (equalt doc "Doc string for defsetf.4-accessor setf")))
108      t)
109    
110    (deftest defsetf.4c
111      (let ((x (list 1 2 3 4))
112            (i 0)
113            (j nil)
114            (k nil))
115        (values
116         (setf (defsetf.4-accessor
117                 (progn (setf j (incf i))
118                        2)
119                 (progn (setf k (incf i)) x))
120               (progn (incf i) 'a))
121         x
122         i j k))
123      a
124      (1 2 a 4)
125      3 1 2)
126    
127    ;;; Test that there's a block around the forms in long form defsetf
128    
129    (defun defsetf.5-accessor (x) (car x))
130    
131    (defsetf defsetf.5-accessor (y) (val)
132      (return-from defsetf.5-accessor `(setf (car ,y) ,val)))
133    
134    (deftest defsetf.5a
135      (let ((x (cons 'a 'b)))
136        (values
137         (setf (defsetf.5-accessor x) 'c)
138         x))
139      c (c . b))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26