← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/with-slots.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/with-slots.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Sat May 17 18:04:10 2003
 
4
;;;; Contains: Tests of WITH-SLOTS
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
(deftest with-slots.1
 
9
  (with-slots () nil)
 
10
  nil)
 
11
 
 
12
(deftest with-slots.2
 
13
  (with-slots () nil (values)))
 
14
 
 
15
(deftest with-slots.3
 
16
  (with-slots () nil (values 'a 'b 'c 'd 'e 'f))
 
17
  a b c d e f)
 
18
 
 
19
(deftest with-slots.4
 
20
  (let ((x 0) (y 10) (z 20))
 
21
    (values
 
22
     x y z
 
23
     (with-slots () (incf x) (incf y 3) (incf z 100))
 
24
     x y z))
 
25
  0 10 20
 
26
  120
 
27
  1 13 120)
 
28
 
 
29
;;; with-slots is an implicit progn, not a tagbody
 
30
 
 
31
(deftest with-slots.5
 
32
  (block done
 
33
    (tagbody
 
34
     (with-slots () nil
 
35
                 (go 10)
 
36
                 10
 
37
                 (return-from done :bad))
 
38
     10
 
39
     (return-from done :good)))
 
40
  :good)
 
41
 
 
42
;;; with-slots has no implicit block
 
43
(deftest with-slots.6
 
44
  (block nil
 
45
    (with-slots () nil (return :good))
 
46
    (return :bad))
 
47
  :good)
 
48
 
 
49
 
 
50
;;; Tests on standard objects
 
51
 
 
52
(defclass with-slots-class-01 () ((a :initarg :a)
 
53
                                  (b :initarg :b)
 
54
                                  (c :initarg :c)))
 
55
 
 
56
(deftest with-slots.7
 
57
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
58
    (with-slots (a b c) obj (values a b c)))
 
59
  x y z)
 
60
 
 
61
(deftest with-slots.8
 
62
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
63
    (with-slots
 
64
     (a b c) obj
 
65
     (values (setf a 'p) (setf b 'q) (setf c 'r)
 
66
             (map-slot-value obj '(a b c)))))
 
67
  p q r (p q r))
 
68
 
 
69
(deftest with-slots.9
 
70
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
71
    (with-slots
 
72
     (a b c) obj
 
73
     (values (setq a 'p) (setq b 'q) (setq c 'r)
 
74
             (map-slot-value obj '(a b c)))))
 
75
  p q r (p q r))
 
76
 
 
77
(deftest with-slots.10
 
78
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
79
    (with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2)))
 
80
  x y z)
 
81
 
 
82
(deftest with-slots.11
 
83
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
84
    (with-slots
 
85
     ((a2 a) (b2 b) (c2 c)) obj
 
86
     (values (setf a2 'p) (setf b2 'q) (setf c2 'r)
 
87
             (map-slot-value obj '(a b c)))))
 
88
  p q r (p q r))
 
89
 
 
90
(deftest with-slots.12
 
91
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
92
    (with-slots
 
93
     ((a2 a) (b2 b) (c2 c)) obj
 
94
     (values (setq a2 'p) (setq b2 'q) (setq c2 'r)
 
95
             (map-slot-value obj '(a b c)))))
 
96
  p q r (p q r))
 
97
 
 
98
(deftest with-slots.13
 
99
  (let ((obj (make-instance 'with-slots-class-01)))
 
100
    (with-slots
 
101
     (a b c) obj
 
102
     (values (setf a 'p) (setf b 'q) (setf c 'r)
 
103
             (map-slot-value obj '(a b c)))))
 
104
  p q r (p q r))
 
105
 
 
106
(deftest with-slots.14
 
107
  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
 
108
    (with-slots (a b c) obj
 
109
                (let ((obj (make-instance 'with-slots-class-01
 
110
                                          :a 'bad :b 'bad :c 'bad)))
 
111
                  (values a b c))))
 
112
  1 2 3)
 
113
 
 
114
 
 
115
(deftest with-slots.15
 
116
  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
 
117
    (with-slots (a b c) obj
 
118
                (with-slots
 
119
                 ((a2 a) (b2 b) (c2 c))
 
120
                 (make-instance 'with-slots-class-01
 
121
                                :a 'bad :b 'bad :c 'bad)
 
122
                 (values a b c))))
 
123
  1 2 3)
 
124
 
 
125
(deftest with-slots.16
 
126
  (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad)))
 
127
    (with-slots (a b c) obj
 
128
                (with-slots
 
129
                 (a b c)
 
130
                 (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)
 
131
                 (values a b c))))
 
132
  1 2 3)
 
133
 
 
134
 
 
135
(deftest with-slots.17
 
136
  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad)))
 
137
    (with-slots (a b) obj
 
138
                (with-slots
 
139
                 (c)
 
140
                 (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3)
 
141
                 (values a b c))))
 
142
  1 2 3)
 
143
 
 
144
;;; If slot is unbound, act as if slot-value had been called
 
145
 
 
146
(defmethod slot-unbound ((class t)
 
147
                         (instance with-slots-class-01)
 
148
                         slot-name)
 
149
  'missing)
 
150
 
 
151
(deftest with-slots.18
 
152
  (let ((obj (make-instance 'with-slots-class-01)))
 
153
    (with-slots (a b c) obj (values a b c)))
 
154
  missing missing missing)
 
155
 
 
156
(deftest with-slots.19
 
157
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
158
    (with-slots (a b c) obj
 
159
                (declare (optimize (speed 3) (safety 3)))
 
160
                (values a b c)))
 
161
  x y z)
 
162
 
 
163
(deftest with-slots.20
 
164
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
 
165
    (with-slots (a b c) obj
 
166
                (declare (optimize (speed 3) (safety 3)))
 
167
                (declare (special *x*))
 
168
                (values a b c)))
 
169
  x y z)