source: trunk/source/tests/ansi-tests/with-accessors.lsp @ 8991

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

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

File size: 3.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 17 17:07:29 2003
4;;;; Contains: Tests of WITH-ACCESSORS
5
6(in-package :cl-test)
7
8(deftest with-accessors.1
9  (with-accessors () nil)
10  nil)
11
12(deftest with-accessors.2
13  (with-accessors () nil (values)))
14
15(deftest with-accessors.3
16  (with-accessors () nil (values 'a 'b 'c 'd 'e 'f))
17  a b c d e f)
18
19(deftest with-accessors.4
20  (let (x y z)
21    (with-accessors () (setf x 1) (setf y 5) (setf z 12) (values x y z)))
22  1 5 12)
23
24;; with-accessors defines an implicit progn, not a tagbody
25(deftest with-accessors.5
26  (block done
27    (tagbody
28     (with-accessors
29      nil nil
30      (go 10)
31      10
32      (return-from done :bad))
33     10
34     (return-from done :good)))
35  :good)                     
36
37(defclass with-accessors-class-01 ()
38  ((a :initarg :a :accessor wa-a)
39   (b :initarg :b :accessor wa-b)
40   (c :initarg :c :accessor wa-c)))
41
42(deftest with-accessors.6
43  (let ((obj (make-instance 'with-accessors-class-01 :a 'x :b 'y :c 'z)))
44    (with-accessors
45     ((a wa-a) (b wa-b) (c wa-c))
46     obj
47     (values a b c)))
48  x y z)
49
50(deftest with-accessors.7
51  (let ((obj (make-instance 'with-accessors-class-01)))
52    (with-accessors
53     ((a wa-a) (b wa-b) (c wa-c))
54     obj
55     (values (setf a 'x) (setf b 'y) (setf c 'z)
56             (map-slot-value obj '(a b c)))))
57  x y z (x y z))
58
59(deftest with-accessors.8
60  (let ((obj (make-instance 'with-accessors-class-01)))
61    (with-accessors
62     ((a wa-a) (b wa-b) (c wa-c))
63     obj
64     (values (setq a 'x) (setq b 'y) (setq c 'z)
65             (map-slot-value obj '(a b c)))))
66  x y z (x y z))
67
68(deftest with-accessors.9
69  (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312)))
70    (with-accessors
71     ((a wa-a) (b wa-b) (c wa-c))
72     obj
73     (values (incf a 4) (incf b 412) (incf c 75)
74             (map-slot-value obj '(a b c)))))
75  9 431 387 (9 431 387))
76
77(deftest with-accessors.10
78  (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312)))
79    (with-accessors
80     ((a wa-a) (b wa-b) (c wa-c))
81     obj
82     (declare (optimize (speed 3) (safety 3)))
83     (values a b c)))
84  5 19 312)
85
86(deftest with-accessors.11
87  (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312)))
88    (with-accessors
89     ((a wa-a) (b wa-b) (c wa-c))
90     obj
91     (declare (optimize (speed 3) (safety 3)))
92     (declare (special *x*)) ;; not used
93     (values a b c)))
94  5 19 312)
95
96;;; with-accessors on structure accessors
97
98(defstruct (with-accessors-struct-02 (:conc-name "WA-2-")) a b c)
99
100(deftest with-accessors.12
101  (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z)))
102    (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c))
103                    obj
104                    (values a b c)))
105  x y z)
106
107(deftest with-accessors.13
108  (let ((obj (make-with-accessors-struct-02)))
109    (with-accessors
110     ((a wa-2-a) (b wa-2-b) (c wa-2-c))
111     obj
112     (values (setf a 'x) (setf b 'y) (setf c 'z)
113             (wa-2-a obj) (wa-2-b obj) (wa-2-c obj))))
114  x y z x y z)
115
116;;; Free declaration scope test
117
118(deftest with-accessors.14
119  (block done
120    (let ((x :bad))
121      (declare (special x))
122      (let ((x :good))
123        (with-accessors nil (return-from done x)
124                        (declare (special x))))))
125  :good)
126
127;;; Test that explicit calls to macroexpand in subforms
128;;; are done in the correct environment
129
130(deftest with-accessors.15
131  (macrolet
132   ((%m (z) z))
133   (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z)))
134     (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c))
135                     (expand-in-current-env (%m obj))
136                     (values a b c))))
137  x y z)
138
Note: See TracBrowser for help on using the repository browser.