/[gcl]/gcl/ansi-tests/define-setf-expander.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/define-setf-expander.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Sun Apr 20 22:59:25 2003 UTC revision 1.2 by pfdietz, Sat Jun 25 17:53:46 2005 UTC
# Line 5  Line 5 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26