source: trunk/source/tests/ansi-tests/define-setf-expander.lsp @ 8991

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

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

File size: 3.2 KB
Line 
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")
Note: See TracBrowser for help on using the repository browser.