Commit 289f5914 authored by pfdietz's avatar pfdietz

Add tests for define-setf-expander, get-setf-expansion, and tests involving...

Add tests for define-setf-expander, get-setf-expansion, and tests involving PSETF to check that setf expansions of builtin accessors don't have bugs related to reused temporary variable names
parent 8a6bbabf
......@@ -5,7 +5,98 @@
(in-package :cl-test)
;;; Need to add non-error tests
(def-macro-test define-setf-expander.error.1
(define-setf-expander nonexistent-access-fn (x)))
;;; Non-error tests
(defun my-car (x) (car x))
(defparameter *define-setf-expander-vals.1*
(multiple-value-list
(define-setf-expander my-car (place &environment env)
(multiple-value-bind (temps vals stores set-form get-form)
(get-setf-expansion place env)
(declare (ignore stores set-form))
(let ((store (gensym))
(temp (gensym)))
(values
`(,@temps ,temp)
`(,@vals ,get-form)
`(,store)
`(progn (rplaca ,temp ,store) ,store)
`(my-car ,temp)))))))
(deftest define-setf-expander.1
*define-setf-expander-vals.1*
(my-car))
(deftest define-setf-expander.2
(let ((a (list 'x 'y)))
(values
(copy-list a)
(my-car a)
(setf (my-car a) 'z)
a))
(x y) x z (z y))
(deftest define-setf-expander.3
(multiple-value-bind (temps vals stores set get)
(get-setf-expansion '(my-car x))
(values
(and (listp temps)
(notnot (every #'symbolp temps)))
(notnot (listp vals))
(and (listp stores)
(= (length stores) 1)
(notnot (every #'symbolp stores)))
(equalt get `(my-car ,(second (second set))))))
t t t t)
(deftest define-setf-expander.4
(let ((a (list (list 1))))
(values
(copy-tree a)
(my-car (my-car a))
(setf (my-car (my-car a)) 2)
a))
((1)) 1 2 ((2)))
(defun my-assoc (key alist)
(loop for pair in alist
when (and (consp pair) (eql key (car pair)))
return pair))
(ignore-errors
(define-setf-expander my-assoc (key place &environment env)
(multiple-value-bind (temps vals stores set-form get-form)
(get-setf-expansion place env)
(let ((store (gensym))
(key-temp (gensym))
(pair-temp (gensym))
(place-temp (gensym)))
(return-from my-assoc
(values
`(,@temps ,key-temp ,place-temp ,pair-temp)
`(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp))
`(,store)
`(if (null ,pair-temp)
(let ((,(car stores)
(cons (cons ,key-temp ,store) ,place-temp)))
,set-form
,store)
(setf (cdr ,pair-temp) ,store))
`(cdr ,pair-temp)))))))
(deftest define-setf-expander.5
(let ((x nil))
(values
(copy-tree x)
(setf (my-assoc 'foo x) 1)
(copy-tree x)
(setf (my-assoc 'foo x) 2)
(copy-tree x)
(setf (my-assoc 'bar x) 3)
(copy-tree x)))
nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2)))
......@@ -15,3 +15,40 @@
;;; FIXME
;;; Tests for proper behavior will go here
;;; There are tests in DEFINE-SETF-EXPANDER too
;;; For a function on which the setf expansion is otherwise
;;; undefined, produce a call to #'(setf <fn>). Note: this
;;; form has to be present, since portable code walkers may
;;; grovel over the setf expansion (sorry, clisp).
(deftest get-setf-expansion.1
(let* ((fn (gensym))
(vals (multiple-value-list (get-setf-expansion (list fn)))))
(values
(length vals)
(first vals)
(second vals)
(length (third vals))
(block done
(subst-if nil
#'(lambda (term)
(when (equal term `(function (setf ,fn)))
(return-from done :good)))
(fourth vals)))
(if (equal (fifth vals) (list fn))
:good
(fifth vals))))
5 nil nil 1 :good :good)
(deftest get-setf-expansion.2
(let* ((fn (gensym))
(vals (multiple-value-list (get-setf-expansion (list fn) nil))))
(length vals))
5)
(deftest get-setf-expansion.3
(let* ((var (gensym))
(vals (multiple-value-list (get-setf-expansion var))))
(length vals))
5)
......@@ -113,3 +113,278 @@
0 10 nil 10 0)
(def-macro-test psetf.error.1 (psetf))
;;; PSETF is a good testbed for finding conflicts in setf expansions
;;; These tests apply psetf to various accessors
(deftest psetf.12
(let* ((x (list 'a 'b))
(y (list 'c 'd)))
(psetf (car x) 1 (car y) 2)
(values x y))
(1 b) (2 d))
(deftest psetf.12a
(let* ((x (list 'a 'b))
(y (list 'c 'd)))
(psetf (first x) 1 (first y) 2)
(values x y))
(1 b) (2 d))
(deftest psetf.13
(let* ((x (list 'a 'b))
(y (list 'c 'd)))
(psetf (cdr x) 1 (cdr y) 2)
(values x y))
(a . 1) (c . 2))
(deftest psetf.13a
(let* ((x (list 'a 'b))
(y (list 'c 'd)))
(psetf (rest x) 1 (rest y) 2)
(values x y))
(a . 1) (c . 2))
(deftest psetf.14
(let* ((x (list 'a 'b))
(y (list 'c 'd)))
(psetf (cadr x) 1 (cadr y) 2)
(values x y))
(a 1) (c 2))
(deftest psetf.15
(let* ((x (list 'a 'b))
(y (list 'c 'd)))
(psetf (cddr x) 1 (cddr y) 2)
(values x y))
(a b . 1) (c d . 2))
(deftest psetf.16
(let* ((x (list (list 'a)))
(y (list (list 'c))))
(psetf (caar x) 1 (caar y) 2)
(values x y))
((1)) ((2)))
(deftest psetf.17
(let* ((x (list (list 'a)))
(y (list (list 'c))))
(psetf (cdar x) 1 (cdar y) 2)
(values x y))
((a . 1)) ((c . 2)))
;;; TODO: c*r accessors with > 2 a/d
;;; TODO: first,...,tenth
(deftest psetf.18
(let* ((x (vector 'a 'b))
(y (vector 'c 'd)))
(psetf (aref x 0) 1 (aref y 0) 2)
(values x y))
#(1 b) #(2 d))
(deftest psetf.18a
(let* ((x (vector 'a 'b))
(y (vector 'c 'd)))
(psetf (svref x 0) 1 (svref y 0) 2)
(values x y))
#(1 b) #(2 d))
(deftest psetf.19
(let* ((x (copy-seq #*11000))
(y (copy-seq #*11100)))
(psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0)
(values x y))
#*10100 #*01101)
(deftest psetf.20
(let* ((x (copy-seq "abcde"))
(y (copy-seq "fghij")))
(psetf (char x 1) #\X (char y 2) #\Y)
(values x y))
"aXcde" "fgYij")
(deftest psetf.21
(let* ((x (copy-seq #*11000))
(y (copy-seq #*11100)))
(psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0)
(values x y))
#*10100 #*01101)
(deftest psetf.22
(let* ((x (copy-seq "abcde"))
(y (copy-seq "fghij")))
(psetf (schar x 1) #\X (schar y 2) #\Y)
(values x y))
"aXcde" "fgYij")
(deftest psetf.23
(let* ((x (copy-seq '(a b c d e)))
(y (copy-seq '(f g h i j))))
(psetf (elt x 1) 'u (elt y 2) 'v)
(values x y))
(a u c d e) (f g v i j))
(deftest psetf.24
(let ((x #b110110001)
(y #b101001100))
(psetf (ldb (byte 5 1) x) #b10110
(ldb (byte 3 6) y) #b10)
(values x y))
#b110101101
#b010001100)
(deftest psetf.25
(let* ((f1 (gensym))
(f2 (gensym))
(fn1 (constantly :foo))
(fn2 (constantly :bar)))
(psetf (fdefinition f1) fn1
(fdefinition f2) fn2)
(values (funcall f1) (funcall f2)))
:foo :bar)
(deftest psetf.26
(let* ((a1 (make-array '(10) :fill-pointer 5))
(a2 (make-array '(20) :fill-pointer 7)))
(psetf (fill-pointer a1) (1+ (fill-pointer a2))
(fill-pointer a2) (1- (fill-pointer a1)))
(values (fill-pointer a1) (fill-pointer a2)))
8 4)
(deftest psetf.27
(let* ((x (list 'a 'b 'c 'd))
(y (list 'd 'e 'f 'g))
(n1 1) (n2 2)
(v1 :foo) (v2 :bar))
(psetf (nth n1 x) v1
(nth n2 y) v2)
(values x y))
(a :foo c d)
(d e :bar g))
(deftest psetf.28
(let* ((f1 (gensym))
(f2 (gensym))
(fn1 (constantly :foo))
(fn2 (constantly :bar)))
(psetf (symbol-function f1) fn1
(symbol-function f2) fn2)
(values (funcall f1) (funcall f2)))
:foo :bar)
(deftest psetf.29
(let* ((s1 (gensym))
(s2 (gensym))
(v1 :foo)
(v2 :bar))
(psetf (symbol-value s1) v1
(symbol-value s2) v2)
(values (symbol-value s1) (symbol-value s2)))
:foo :bar)
(deftest psetf.30
(let* ((s1 (gensym))
(s2 (gensym))
(v1 (list :foo 1))
(v2 (list :bar 2)))
(psetf (symbol-plist s1) v1
(symbol-plist s2) v2)
(values (symbol-plist s1) (symbol-plist s2)))
(:foo 1) (:bar 2))
(deftest psetf.31
(let* ((x (list 'a 'b 'c 'd 'e))
(y (list 'f 'g 'h 'i 'j))
(v1 (list 1 2))
(v2 (list 3 4 5))
(p1 1) (p2 2)
(l1 (length v1))
(l2 (length v2)))
(psetf (subseq x p1 (+ p1 l1)) v1
(subseq y p2 (+ p2 l2)) v2)
(values x y))
(a 1 2 d e)
(f g 3 4 5))
(deftest psetf.32
(let* ((x (gensym))
(y (gensym))
(k1 :foo)
(k2 :bar)
(v1 1)
(v2 2))
(psetf (get x k1) v1 (get y k2) v2)
(values (symbol-plist x) (symbol-plist y)))
(:foo 1) (:bar 2))
(deftest psetf.33
(let* ((x nil)
(y nil)
(k1 :foo)
(k2 :bar)
(v1 1)
(v2 2))
(psetf (getf x k1) v1 (getf y k2) v2)
(values x y))
(:foo 1) (:bar 2))
(deftest psetf.34
(let* ((ht1 (make-hash-table))
(ht2 (make-hash-table))
(k1 :foo) (v1 1)
(k2 :bar) (v2 2))
(psetf (gethash k1 ht1) v1
(gethash k2 ht2) v2)
(values (gethash k1 ht1) (gethash k2 ht2)))
1 2)
(deftest psetf.35
(let ((n1 (gensym))
(n2 (gensym))
(n3 (gensym))
(n4 (gensym)))
(eval `(defclass ,n1 () ()))
(eval `(defclass ,n2 () ()))
(psetf (find-class n3) (find-class n1)
(find-class n4) (find-class n2))
(values (eqlt (find-class n1) (find-class n3))
(eqlt (find-class n2) (find-class n4))))
t t)
(deftest psetf.36
(let ((fn1 (constantly :foo))
(fn2 (constantly :bar))
(n1 (gensym))
(n2 (gensym)))
(psetf (macro-function n1) fn1
(macro-function n2) fn2)
(values (eval `(,n1)) (eval `(,n2))))
:foo :bar)
(deftest psetf.37
(let ((b1 (byte 3 1))
(b2 (byte 4 2))
(x #b1100101011010101)
(y #b11010101000110)
(m1 #b101010101101101)
(m2 #b11110010110101))
(psetf (mask-field b1 x) m1
(mask-field b2 y) m2)
(values x y))
#b1100101011011101
#b11010101110110)
(deftest psetf.38
(let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f))))
(a2 (make-array '(3 4) :initial-contents
'((1 2 3 4) (5 6 7 8) (9 10 11 12))))
(i1 2) (i2 5)
(v1 'u) (v2 'v))
(psetf (row-major-aref a1 i1) v1
(row-major-aref a2 i2) v2)
(values a1 a2))
#2a((a b u)(d e f))
#2a((1 2 3 4)(5 v 7 8)(9 10 11 12)))
;;; TODO: logical-pathname-translations, readtable-case
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment