1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Sun Apr 20 17:19:35 2003 |
---|
4 | ;;;; Contains: Tests of DEFINE-SETF-EXPANDER |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (def-macro-test define-setf-expander.error.1 |
---|
9 | (define-setf-expander nonexistent-access-fn (x))) |
---|
10 | |
---|
11 | ;;; Non-error tests |
---|
12 | |
---|
13 | (defun my-car (x) (car x)) |
---|
14 | |
---|
15 | (ignore-errors |
---|
16 | (defparameter *define-setf-expander-vals.1* |
---|
17 | (multiple-value-list |
---|
18 | (define-setf-expander my-car (place &environment env) |
---|
19 | (multiple-value-bind (temps vals stores set-form get-form) |
---|
20 | (get-setf-expansion place env) |
---|
21 | (declare (ignore stores set-form)) |
---|
22 | (let ((store (gensym)) |
---|
23 | (temp (gensym))) |
---|
24 | (values |
---|
25 | `(,@temps ,temp) |
---|
26 | `(,@vals ,get-form) |
---|
27 | `(,store) |
---|
28 | `(progn (rplaca ,temp ,store) ,store) |
---|
29 | `(my-car ,temp)))))))) |
---|
30 | |
---|
31 | (deftest define-setf-expander.1 |
---|
32 | *define-setf-expander-vals.1* |
---|
33 | (my-car)) |
---|
34 | |
---|
35 | (deftest define-setf-expander.2 |
---|
36 | (let ((a (list 'x 'y))) |
---|
37 | (values |
---|
38 | (copy-list a) |
---|
39 | (my-car a) |
---|
40 | (setf (my-car a) 'z) |
---|
41 | a)) |
---|
42 | (x y) x z (z y)) |
---|
43 | |
---|
44 | (deftest define-setf-expander.3 |
---|
45 | (multiple-value-bind (temps vals stores set get) |
---|
46 | (get-setf-expansion '(my-car x)) |
---|
47 | (values |
---|
48 | (and (listp temps) |
---|
49 | (notnot (every #'symbolp temps))) |
---|
50 | (notnot (listp vals)) |
---|
51 | (and (listp stores) |
---|
52 | (= (length stores) 1) |
---|
53 | (notnot (every #'symbolp stores))) |
---|
54 | (equalt get `(my-car ,(second (second set)))))) |
---|
55 | t t t t) |
---|
56 | |
---|
57 | (deftest define-setf-expander.4 |
---|
58 | (let ((a (list (list 1)))) |
---|
59 | (values |
---|
60 | (copy-tree a) |
---|
61 | (my-car (my-car a)) |
---|
62 | (setf (my-car (my-car a)) 2) |
---|
63 | a)) |
---|
64 | ((1)) 1 2 ((2))) |
---|
65 | |
---|
66 | (defun my-assoc (key alist) |
---|
67 | (loop for pair in alist |
---|
68 | when (and (consp pair) (eql key (car pair))) |
---|
69 | return pair)) |
---|
70 | |
---|
71 | (ignore-errors |
---|
72 | (define-setf-expander my-assoc (key place &environment env) |
---|
73 | (multiple-value-bind (temps vals stores set-form get-form) |
---|
74 | (get-setf-expansion place env) |
---|
75 | (let ((store (gensym)) |
---|
76 | (key-temp (gensym)) |
---|
77 | (pair-temp (gensym)) |
---|
78 | (place-temp (gensym))) |
---|
79 | (return-from my-assoc |
---|
80 | (values |
---|
81 | `(,@temps ,key-temp ,place-temp ,pair-temp) |
---|
82 | `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) |
---|
83 | `(,store) |
---|
84 | `(if (null ,pair-temp) |
---|
85 | (let ((,(car stores) |
---|
86 | (cons (cons ,key-temp ,store) ,place-temp))) |
---|
87 | ,set-form |
---|
88 | ,store) |
---|
89 | (setf (cdr ,pair-temp) ,store)) |
---|
90 | `(cdr ,pair-temp))))))) |
---|
91 | |
---|
92 | (deftest define-setf-expander.5 |
---|
93 | (let ((x nil)) |
---|
94 | (values |
---|
95 | (copy-tree x) |
---|
96 | (setf (my-assoc 'foo x) 1) |
---|
97 | (copy-tree x) |
---|
98 | (setf (my-assoc 'foo x) 2) |
---|
99 | (copy-tree x) |
---|
100 | (setf (my-assoc 'bar x) 3) |
---|
101 | (copy-tree x))) |
---|
102 | nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2))) |
---|
103 | |
---|
104 | (deftest define-setf-expander.6 |
---|
105 | (let ((n (gensym)) |
---|
106 | (doc "D-S-EX.6")) |
---|
107 | (assert (null (documentation n 'setf))) |
---|
108 | (assert (eql (eval `(define-setf-expander ,n () |
---|
109 | ,doc (values nil nil nil nil nil))) |
---|
110 | n)) |
---|
111 | (or (documentation n 'setf) doc)) |
---|
112 | "D-S-EX.6") |
---|
113 | |
---|
114 | (deftest define-setf-expander.7 |
---|
115 | (let ((n (gensym)) |
---|
116 | (doc "D-S-EX.7")) |
---|
117 | (assert (null (documentation n 'setf))) |
---|
118 | (assert (eql (eval `(define-setf-expander ,n () |
---|
119 | (values nil nil nil nil nil))) |
---|
120 | n)) |
---|
121 | (assert (null (documentation n 'setf))) |
---|
122 | (values |
---|
123 | (setf (documentation n 'setf) doc) |
---|
124 | (or (documentation n 'setf) doc))) |
---|
125 | "D-S-EX.7" |
---|
126 | "D-S-EX.7") |
---|