Commit 3ccb26a9 authored by pfdietz's avatar pfdietz

Refactor fold tests using a convenient macro.

parent 5463b7bf
......@@ -1155,3 +1155,13 @@ the condition to go uncaught if it cannot be classified."
(string x))
t)
(type-error () nil))))
(defmacro def-fold-test (name form)
"Create a test that FORM, which should produce a fresh value,
does not improperly introduce sharing during constant folding."
`(deftest ,name
(flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0)
(compilation-speed 0) (debug 0)))
,form))
(eq (%f) (%f)))
nil))
......@@ -228,11 +228,7 @@
x y z))
#*0 2 1 2)
(deftest bit-and.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-and #*01101 #*01011)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 1) bv) (%f)))
#*01001 #*11001 #*01001)
(def-fold-test bit-and.fold.1 (bit-and #*01101 #*01011))
;;; Error tests
......
......@@ -228,11 +228,7 @@
x y z))
#*0 2 1 2)
(deftest bit-andc1.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-andc1 #*10010 #*01011)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 1) bv) (%f)))
#*01001 #*11001 #*01001)
(def-fold-test bit-andc1.fold.1 (bit-andc1 #*10010 #*01011))
;;; Error tests
......
......@@ -228,11 +228,7 @@
x y z))
#*0 2 1 2)
(deftest bit-andc2.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-andc2 #*01101 #*10100)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 1) bv) (%f)))
#*01001 #*11001 #*01001)
(def-fold-test bit-andc2.fold.1 (bit-andc2 #*01101 #*10100))
;;; Error tests
......
......@@ -229,11 +229,7 @@
x y z))
#*1 2 1 2)
(deftest bit-eqv.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-eqv #*01101 #*10100)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 1) bv) (%f)))
#*00110 #*10110 #*00110)
(def-fold-test bit-eqv.fold.1 (bit-eqv #*01101 #*10100))
;;; Error tests
......
......@@ -228,11 +228,7 @@
x y z))
#*0 2 1 2)
(deftest bit-ior.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-ior #*00101 #*10100)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f)))
#*10101 #*00101 #*10101)
(def-fold-test bit-ior.fold.1 (bit-ior #*00101 #*10100))
;;; Error tests
......
......@@ -228,11 +228,7 @@
x y z))
#*1 2 1 2)
(deftest bit-nand.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-nand #*00101 #*10100)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f)))
#*11011 #*01011 #*11011)
(def-fold-test bit-nand.fold.1 (bit-nand #*00101 #*10100))
;;; Error tests
......
......@@ -228,11 +228,7 @@
x y z))
#*1 2 1 2)
(deftest bit-nor.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-nor #*00101 #*10100)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 1) bv) (%f)))
#*01010 #*11010 #*01010)
(def-fold-test bit-nor.fold.1 (bit-nor #*00101 #*10100))
;;; Error tests
......
......@@ -127,11 +127,7 @@
i x))
#*110010 1 1)
(deftest bit-not.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-not #*00101)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f)))
#*11010 #*01010 #*11010)
(def-fold-test bit-not.fold.1 (bit-not #*00101))
;;; Error tests
......
......@@ -228,11 +228,7 @@
x y z))
#*0 2 1 2)
(deftest bit-xor.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(bit-xor #*00101 #*10100)))
(values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f)))
#*10001 #*00001 #*10001)
(def-fold-test bit-xor.fold.1 (bit-xor #*00101 #*10100))
;;; Error tests
......
......@@ -143,19 +143,9 @@
;;; If the coerce call is folded to a constant, this will fail
;;; when that constant is modified.
(deftest coerce.fold.1
(flet ((%f () (declare (optimize speed (safety 0)))
(coerce '(1 2 3) 'vector)))
(values
(%f)
(let ((v (%f)))
(setf (aref v 0) 0)
v)
(%f)))
#(1 2 3)
#(0 2 3)
#(1 2 3))
(def-fold-test coerce.fold.1 (coerce '(1 2 3) 'vector))
(def-fold-test coerce.fold.2 (coerce '(1 0 1) 'bit-vector))
(def-fold-test coerce.fold.3 (coerce '(#\a #\b #\c) 'string))
;;; Error tests
......
......@@ -289,35 +289,14 @@
;;; Constant folding tests
(deftest concatenate.fold.1
(flet ((%f () (declaim (optimize speed (safety 0) (space 0)))
(concatenate 'list '(a b) '(c d))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
(a b c d) (z b c d) (a b c d))
(deftest concatenate.fold.2
(flet ((%f () (declaim (optimize speed (safety 0) (space 0)))
(concatenate 'vector '(a b) '(c d))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
#(a b c d) #(z b c d) #(a b c d))
(deftest concatenate.fold.3
(flet ((%f () (declaim (optimize speed (safety 0) (space 0)))
(concatenate 'bit-vector '(0 0) '(1 0 1))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*00101 #*10101 #*00101)
(deftest concatenate.fold.4
(flet ((%f () (declaim (optimize speed (safety 0) (space 0)))
(concatenate 'string "ab" "cd")))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) #\z) seq) (%f)))
"abcd" "zbcd" "abcd")
(deftest concatenate.fold.5
(flet ((%f () (declaim (optimize speed (safety 0) (space 0)))
(concatenate 'list '(a b c d))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
(a b c d) (z b c d) (a b c d))
(def-fold-test concatenate.fold.1 (concatenate 'list '(a b) '(c d)))
(def-fold-test concatenate.fold.2 (concatenate 'vector '(a b) '(c d)))
(def-fold-test concatenate.fold.3 (concatenate 'bit-vector '(0 0) '(1 0 1)))
(def-fold-test concatenate.fold.4 (concatenate 'string "ab" "cd"))
(def-fold-test concatenate.fold.5 (concatenate 'list '(a b c d)))
(def-fold-test concatenate.fold.6 (concatenate 'vector #(a b c d)))
(def-fold-test concatenate.fold.7 (concatenate 'bit-vector #*110101101))
(def-fold-test concatenate.fold.8 (concatenate 'string "abcdef"))
;;; Error tests
......
......@@ -227,6 +227,11 @@
(values (copy-seq (progn (incf i) "abc")) i))
"abc" 1)
(def-fold-test copy-seq.fold.1 (copy-seq '(a b c)))
(def-fold-test copy-seq.fold.2 (copy-seq #(a b c)))
(def-fold-test copy-seq.fold.3 (copy-seq #*01101100))
(def-fold-test copy-seq.fold.4 (copy-seq "abcdef"))
;;; Error tests
(deftest copy-seq.error.1
......
......@@ -502,4 +502,15 @@
i a b c d e))
(a a a a a) 5 1 2 3 4 5)
;;; Const fold tests
(def-fold-test make-sequence.fold.1
(make-sequence 'list 5 :initial-element 'a))
(def-fold-test make-sequence.fold.2
(make-sequence 'vector 5 :initial-element 'a))
(def-fold-test make-sequence.fold.3
(make-sequence 'bit-vector 5 :initial-element 0))
(def-fold-test make-sequence.fold.4
(make-sequence 'string 5 :initial-element #\a))
;;; FIXME: Add tests for upgrading of character subtypes
......@@ -428,11 +428,4 @@
;;; Constant folding test
(deftest map.fold.1
(let ((f (compile nil '(lambda () (declare (optimize speed (safety 0)))
(map 'vector #'identity '(a b c))))))
(let ((v (funcall f)))
(setf (aref v 0) nil)
(values v (funcall f))))
#(nil b c)
#(a b c))
(def-fold-test map.fold.1 (map 'vector #'identity '(a b c)))
......@@ -56,25 +56,10 @@
;;; Const fold tests
(deftest remove-duplicates.fold.1
(flet ((%f () (remove-duplicates '(1 2 3 3))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 0) seq) (%f)))
(1 2 3) (0 2 3) (1 2 3))
(deftest remove-duplicates.fold.2
(flet ((%f () (remove-duplicates #(1 2 3 3))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 0) seq) (%f)))
#(1 2 3) #(0 2 3) #(1 2 3))
(deftest remove-duplicates.fold.3
(flet ((%f () (remove-duplicates #*0011)))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*01 #*11 #*01)
(deftest remove-duplicates.fold.4
(flet ((%f () (remove-duplicates "1233")))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) #\0) seq) (%f)))
"123" "023" "123")
(def-fold-test remove-duplicates.fold.1 (remove-duplicates '(1 2 3 3)))
(def-fold-test remove-duplicates.fold.2 (remove-duplicates #(1 2 3 3)))
(def-fold-test remove-duplicates.fold.3 (remove-duplicates #*0011))
(def-fold-test remove-duplicates.fold.4 (remove-duplicates "1233"))
;;; Order of evaluation tests
......
......@@ -463,101 +463,20 @@
;;; Const fold tests
(deftest remove.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove 'c '(a b c d e))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
(a b d e)
(z b d e)
(a b d e))
(deftest remove.fold.2
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove 'c #(a b c d e))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
#(a b d e)
#(z b d e)
#(a b d e))
(deftest remove.fold.3
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove 1 #*0011011001)))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*00000
#*10000
#*00000)
(deftest remove.fold.4
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove #\c "abcde")))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) #\z) seq) (%f)))
"abde"
"zbde"
"abde")
(deftest remove-if.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if 'null '(a b nil d e))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
(a b d e)
(z b d e)
(a b d e))
(deftest remove-if.fold.2
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if #'null #(a b nil d e))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
#(a b d e)
#(z b d e)
#(a b d e))
(deftest remove-if.fold.3
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if 'plusp #*0011011001)))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*00000
#*10000
#*00000)
(deftest remove-if.fold.4
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if 'digit-char-p "ab0de")))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) #\z) seq) (%f)))
"abde"
"zbde"
"abde")
(deftest remove-if-not.fold.1
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if-not #'identity '(a b nil d e))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
(a b d e)
(z b d e)
(a b d e))
(deftest remove-if-not.fold.2
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if-not 'identity #(a b nil d e))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'z) seq) (%f)))
#(a b d e)
#(z b d e)
#(a b d e))
(deftest remove-if-not.fold.3
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if-not #'zerop #*0011011001)))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*00000
#*10000
#*00000)
(deftest remove-if-not.fold.4
(flet ((%f () (declare (optimize speed (safety 0) (space 0)))
(remove-if-not #'alpha-char-p "ab-de")))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) #\z) seq) (%f)))
"abde"
"zbde"
"abde")
(def-fold-test remove.fold.1 (remove 'c '(a b c d e)))
(def-fold-test remove.fold.2 (remove 'c #(a b c d e)))
(def-fold-test remove.fold.3 (remove 1 #*0011011001))
(def-fold-test remove.fold.4 (remove #\c "abcde"))
(def-fold-test remove-if.fold.1 (remove-if 'null '(a b nil d e)))
(def-fold-test remove-if.fold.2 (remove-if #'null #(a b nil d e)))
(def-fold-test remove-if.fold.3 (remove-if 'plusp #*0011011001))
(def-fold-test remove-if.fold.4 (remove-if 'digit-char-p "ab0de"))
(def-fold-test remove-if-not.fold.1 (remove-if-not #'identity '(a b nil d e)))
(def-fold-test remove-if-not.fold.2 (remove-if-not 'identity #(a b nil d e)))
(def-fold-test remove-if-not.fold.3 (remove-if-not #'zerop #*0011011001))
(def-fold-test remove-if-not.fold.4 (remove-if-not #'alpha-char-p "ab-de"))
;;; Order of evaluation tests
......
......@@ -168,25 +168,10 @@
;;; Constant folding tests
(deftest reverse.fold.1
(flet ((%f () (reverse '(a b c))))
(values
(%f)
(let ((seq (%f))) (setf (elt seq 0) 'z) seq)
(%f)))
(c b a)
(z b a)
(c b a))
(deftest reverse.fold.2
(flet ((%f () (reverse #(a b c))))
(values
(%f)
(let ((seq (%f))) (setf (elt seq 0) 'z) seq)
(%f)))
#(c b a)
#(z b a)
#(c b a))
(def-fold-test reverse.fold.1 (reverse '(a b c)))
(def-fold-test reverse.fold.2 (reverse #(a b c)))
(def-fold-test reverse.fold.3 (reverse #*00111101011011))
(def-fold-test reverse.fold.4 (reverse "abcdefgh"))
;;; Error cases
......
......@@ -283,15 +283,10 @@
;;; Constant folding
(deftest subseq.fold.1
(flet ((%f () (subseq '(1 2 3) 0)))
(values
(%f)
(let ((seq (%f))) (setf (elt seq 0) 0) seq)
(%f)))
(1 2 3)
(0 2 3)
(1 2 3))
(def-fold-test subseq.fold.1 (subseq '(1 2 3) 0))
(def-fold-test subseq.fold.2 (subseq #(1 2 3) 0))
(def-fold-test subseq.fold.3 (subseq #*011101 0))
(def-fold-test subseq.fold.4 (subseq "abcdef" 0))
;;; Error cases
......
......@@ -818,20 +818,14 @@
;;; Constant folding tests
(deftest substitute-if-not.fold.1
(flet ((%f () (substitute-if-not 'z 'identity '(a nil b))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'd) seq) (%f)))
(a z b) (d z b) (a z b))
(deftest substitute-if-not.fold.2
(flet ((%f () (substitute-if-not 'z 'identity #(a nil b))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'd) seq) (%f)))
#(a z b) #(d z b) #(a z b))
(deftest substitute-if-not.fold.3
(flet ((%f () (substitute-if-not 0 'zerop #*100110)))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*000000 #*100000 #*000000)
(def-fold-test substitute-if-not.fold.1
(substitute-if-not 'z 'identity '(a nil b)))
(def-fold-test substitute-if-not.fold.2
(substitute-if-not 'z 'identity #(a nil b)))
(def-fold-test substitute-if-not.fold.3
(substitute-if-not 0 'zerop #*100110))
(def-fold-test substitute-if-not.fold.4
(substitute-if-not #\0 #'digit-char-p "asdaw82213nn1239123dd"))
;;; Error cases
......
......@@ -842,20 +842,11 @@
;;; Constant folding tests
(deftest substitute-if.fold.1
(flet ((%f () (substitute-if 'z 'null '(a nil b))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'd) seq) (%f)))
(a z b) (d z b) (a z b))
(deftest substitute-if.fold.2
(flet ((%f () (substitute-if 'z 'null #(a nil b))))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 'd) seq) (%f)))
#(a z b) #(d z b) #(a z b))
(deftest substitute-if.fold.3
(flet ((%f () (substitute-if 0 'plusp #*100110)))
(values (%f) (let ((seq (%f))) (setf (elt seq 0) 1) seq) (%f)))
#*000000 #*100000 #*000000)
(def-fold-test substitute-if.fold.1 (substitute-if 'z 'null '(a nil b)))
(def-fold-test substitute-if.fold.2 (substitute-if 'z 'null #(a nil b)))
(def-fold-test substitute-if.fold.3 (substitute-if 0 'plusp #*100110))
(def-fold-test substitute-if.fold.4 (substitute-if #\x 'digit-char-p
"asdf8234n123f"))
;;; Error cases
......
......@@ -1094,35 +1094,10 @@
;;; Constant folding tests
(deftest substitute.fold.1
(flet ((%f () (substitute 'z 'b '(a b c))))
(values
(%f)
(let ((seq (%f))) (setf (elt seq 0) 'd) seq)
(%f)))
(a z c)
(d z c)
(a z c))
(deftest substitute.fold.2
(flet ((%f () (substitute 'z 'b #(a b c))))
(values
(%f)
(let ((seq (%f))) (setf (elt seq 0) 'd) seq)
(%f)))
#(a z c)
#(d z c)
#(a z c))
(deftest substitute.fold.3
(flet ((%f () (substitute 0 1 #*001101)))
(values
(%f)
(let ((seq (%f))) (setf (elt seq 0) 1) seq)
(%f)))
#*000000
#*100000
#*000000)
(def-fold-test substitute.fold.1 (substitute 'z 'b '(a b c)))
(def-fold-test substitute.fold.2 (substitute 'z 'b #(a b c)))
(def-fold-test substitute.fold.3 (substitute 0 1 #*001101))
(def-fold-test substitute.fold.4 (substitute #\a #\b "abcebadfke"))
;;; Error cases
......
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