with-accessors.lsp 3.11 KB
Newer Older
pfdietz's avatar
pfdietz committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 17 17:07:29 2003
;;;; Contains: Tests of WITH-ACCESSORS

(in-package :cl-test)

(deftest with-accessors.1
  (with-accessors () nil)
  nil)

(deftest with-accessors.2
  (with-accessors () nil (values)))

(deftest with-accessors.3
  (with-accessors () nil (values 'a 'b 'c 'd 'e 'f))
  a b c d e f)

(deftest with-accessors.4
  (let (x y z)
    (with-accessors () (setf x 1) (setf y 5) (setf z 12) (values x y z)))
  1 5 12)

;; with-accessors defines an implicit progn, not a tagbody
(deftest with-accessors.5
  (block done
    (tagbody
     (with-accessors
      nil nil
      (go 10)
      10
      (return-from done :bad))
     10
     (return-from done :good)))
  :good)		     

(defclass with-accessors-class-01 ()
  ((a :initarg :a :accessor wa-a)
   (b :initarg :b :accessor wa-b)
   (c :initarg :c :accessor wa-c)))

(deftest with-accessors.6
  (let ((obj (make-instance 'with-accessors-class-01 :a 'x :b 'y :c 'z)))
    (with-accessors
     ((a wa-a) (b wa-b) (c wa-c))
     obj
     (values a b c)))
  x y z)

(deftest with-accessors.7
  (let ((obj (make-instance 'with-accessors-class-01)))
    (with-accessors
     ((a wa-a) (b wa-b) (c wa-c))
     obj
     (values (setf a 'x) (setf b 'y) (setf c 'z)
	     (map-slot-value obj '(a b c)))))
  x y z (x y z))

(deftest with-accessors.8
  (let ((obj (make-instance 'with-accessors-class-01)))
    (with-accessors
     ((a wa-a) (b wa-b) (c wa-c))
     obj
     (values (setq a 'x) (setq b 'y) (setq c 'z)
	     (map-slot-value obj '(a b c)))))
  x y z (x y z))

(deftest with-accessors.9
  (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312)))
    (with-accessors
     ((a wa-a) (b wa-b) (c wa-c))
     obj
     (values (incf a 4) (incf b 412) (incf c 75)
	     (map-slot-value obj '(a b c)))))
  9 431 387 (9 431 387))

(deftest with-accessors.10
  (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312)))
    (with-accessors
     ((a wa-a) (b wa-b) (c wa-c))
     obj
     (declare (optimize (speed 3) (safety 3)))
     (values a b c)))
  5 19 312)

(deftest with-accessors.11
  (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312)))
    (with-accessors
     ((a wa-a) (b wa-b) (c wa-c))
     obj
     (declare (optimize (speed 3) (safety 3)))
     (declare (special *x*)) ;; not used
     (values a b c)))
  5 19 312)

;;; with-accessors on structure accessors

(defstruct (with-accessors-struct-02 (:conc-name "WA-2-")) a b c)

(deftest with-accessors.12
  (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z)))
    (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c))
		    obj
		    (values a b c)))
  x y z)

(deftest with-accessors.13
  (let ((obj (make-with-accessors-struct-02)))
    (with-accessors
     ((a wa-2-a) (b wa-2-b) (c wa-2-c))
     obj
     (values (setf a 'x) (setf b 'y) (setf c 'z)
	     (wa-2-a obj) (wa-2-b obj) (wa-2-c obj))))
  x y z x y z)
115
116
117
118
119
120
121
122
123
124
125
126

;;; Free declaration scope test

(deftest with-accessors.14
  (block done
    (let ((x :bad))
      (declare (special x))
      (let ((x :good))
	(with-accessors nil (return-from done x)
			(declare (special x))))))
  :good)