5 |
|
|
6 |
(in-package :cl-test) |
(in-package :cl-test) |
7 |
|
|
|
;;; Need to add non-error tests |
|
|
|
|
8 |
(def-macro-test define-setf-expander.error.1 |
(def-macro-test define-setf-expander.error.1 |
9 |
(define-setf-expander nonexistent-access-fn (x))) |
(define-setf-expander nonexistent-access-fn (x))) |
10 |
|
|
11 |
|
;;; Non-error tests |
12 |
|
|
13 |
|
(defun my-car (x) (car x)) |
14 |
|
|
15 |
|
(defparameter *define-setf-expander-vals.1* |
16 |
|
(multiple-value-list |
17 |
|
(define-setf-expander my-car (place &environment env) |
18 |
|
(multiple-value-bind (temps vals stores set-form get-form) |
19 |
|
(get-setf-expansion place env) |
20 |
|
(declare (ignore stores set-form)) |
21 |
|
(let ((store (gensym)) |
22 |
|
(temp (gensym))) |
23 |
|
(values |
24 |
|
`(,@temps ,temp) |
25 |
|
`(,@vals ,get-form) |
26 |
|
`(,store) |
27 |
|
`(progn (rplaca ,temp ,store) ,store) |
28 |
|
`(my-car ,temp))))))) |
29 |
|
|
30 |
|
(deftest define-setf-expander.1 |
31 |
|
*define-setf-expander-vals.1* |
32 |
|
(my-car)) |
33 |
|
|
34 |
|
(deftest define-setf-expander.2 |
35 |
|
(let ((a (list 'x 'y))) |
36 |
|
(values |
37 |
|
(copy-list a) |
38 |
|
(my-car a) |
39 |
|
(setf (my-car a) 'z) |
40 |
|
a)) |
41 |
|
(x y) x z (z y)) |
42 |
|
|
43 |
|
(deftest define-setf-expander.3 |
44 |
|
(multiple-value-bind (temps vals stores set get) |
45 |
|
(get-setf-expansion '(my-car x)) |
46 |
|
(values |
47 |
|
(and (listp temps) |
48 |
|
(notnot (every #'symbolp temps))) |
49 |
|
(notnot (listp vals)) |
50 |
|
(and (listp stores) |
51 |
|
(= (length stores) 1) |
52 |
|
(notnot (every #'symbolp stores))) |
53 |
|
(equalt get `(my-car ,(second (second set)))))) |
54 |
|
t t t t) |
55 |
|
|
56 |
|
(deftest define-setf-expander.4 |
57 |
|
(let ((a (list (list 1)))) |
58 |
|
(values |
59 |
|
(copy-tree a) |
60 |
|
(my-car (my-car a)) |
61 |
|
(setf (my-car (my-car a)) 2) |
62 |
|
a)) |
63 |
|
((1)) 1 2 ((2))) |
64 |
|
|
65 |
|
(defun my-assoc (key alist) |
66 |
|
(loop for pair in alist |
67 |
|
when (and (consp pair) (eql key (car pair))) |
68 |
|
return pair)) |
69 |
|
|
70 |
|
(ignore-errors |
71 |
|
(define-setf-expander my-assoc (key place &environment env) |
72 |
|
(multiple-value-bind (temps vals stores set-form get-form) |
73 |
|
(get-setf-expansion place env) |
74 |
|
(let ((store (gensym)) |
75 |
|
(key-temp (gensym)) |
76 |
|
(pair-temp (gensym)) |
77 |
|
(place-temp (gensym))) |
78 |
|
(return-from my-assoc |
79 |
|
(values |
80 |
|
`(,@temps ,key-temp ,place-temp ,pair-temp) |
81 |
|
`(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) |
82 |
|
`(,store) |
83 |
|
`(if (null ,pair-temp) |
84 |
|
(let ((,(car stores) |
85 |
|
(cons (cons ,key-temp ,store) ,place-temp))) |
86 |
|
,set-form |
87 |
|
,store) |
88 |
|
(setf (cdr ,pair-temp) ,store)) |
89 |
|
`(cdr ,pair-temp))))))) |
90 |
|
|
91 |
|
(deftest define-setf-expander.5 |
92 |
|
(let ((x nil)) |
93 |
|
(values |
94 |
|
(copy-tree x) |
95 |
|
(setf (my-assoc 'foo x) 1) |
96 |
|
(copy-tree x) |
97 |
|
(setf (my-assoc 'foo x) 2) |
98 |
|
(copy-tree x) |
99 |
|
(setf (my-assoc 'bar x) 3) |
100 |
|
(copy-tree x))) |
101 |
|
nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2))) |
102 |
|
|