diff --git a/ansi-tests/rotatef.lsp b/ansi-tests/rotatef.lsp index f4fafece29e24fbc255e50897128f943c34e5c81..d943439dd16971a375c6dcaad9504b955e1c02f5 100644 --- a/ansi-tests/rotatef.lsp +++ b/ansi-tests/rotatef.lsp @@ -68,4 +68,285 @@ a b nil b a) -;;; Need to add more tests for ROTATEF here +;;; ROTATEF is a good testbed for finding conflicts in setf expansions +;;; These tests apply rotatef to various accessors + +(deftest rotatef.6 + (let* ((x (list 'a 'b)) + (y (list 'c 'd)) + (z 'e)) + (rotatef (car x) (car y) z) + (values x y z)) + (c b) (e d) a) + +(deftest rotatef.7 + (let* ((x (list 'a 'b)) + (y (list 'c 'd)) + (z 'e)) + (rotatef (first x) (first y) z) + (values x y z)) + (c b) (e d) a) + +(deftest rotatef.8 + (let* ((x (list 'a 'b)) + (y (list 'c 'd)) + (z '(e))) + (rotatef (cdr x) (cdr y) z) + (values x y z)) + (a d) (c e) (b)) + +(deftest rotatef.9 + (let* ((x (list 'a 'b)) + (y (list 'c 'd)) + (z '(e))) + (rotatef (rest x) (rest y) z) + (values x y z)) + (a d) (c e) (b)) + +(deftest rotatef.10 + (let* ((x (list 'a 'b)) + (y (list 'c 'd)) + (z 'e)) + (rotatef (cadr x) (cadr y) z) + (values x y z)) + (a d) (c e) b) + +(deftest rotatef.11 + (let* ((x (list 'a 'b)) + (y (list 'c 'd)) + (z 'e)) + (rotatef (second x) (second y) z) + (values x y z)) + (a d) (c e) b) + +(deftest rotatef.12 + (let* ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f)) + (z (list 'g))) + (rotatef (cddr x) (cddr y) z) + (values x y z)) + (a b f) (d e g) (c)) + +(deftest rotatef.13 + (let* ((x (list (list 'a))) + (y (list (list 'c))) + (z 'e)) + (rotatef (caar x) (caar y) z) + (values x y z)) + ((c)) ((e)) a) + +(deftest rotatef.14 + (let* ((x (list (list 'a 'b))) + (y (list (list 'c 'd))) + (z (list 'e))) + (rotatef (cdar x) (cdar y) z) + (values x y z)) + ((a d)) ((c e)) (b)) + +;;; TODO: c*r accessors with > 2 a/d +;;; TODO: third,...,tenth + +(deftest rotatef.15 + (let* ((x (vector 'a 'b)) + (y (vector 'c 'd)) + (z 'e)) + (rotatef (aref x 0) (aref y 0) z) + (values x y z)) + #(c b) #(e d) a) + +(deftest rotatef.16 + (let* ((x (vector 'a 'b)) + (y (vector 'c 'd)) + (z 'e)) + (rotatef (svref x 0) (svref y 0) z) + (values x y z)) + #(c b) #(e d) a) + +(deftest rotatef.17 + (let* ((x (copy-seq #*11000)) + (y (copy-seq #*11100)) + (z 1)) + (rotatef (bit x 1) (bit y 3) z) + (values x y z)) + #*10000 #*11110 1) + +(deftest rotatef.18 + (let* ((x (copy-seq "abcde")) + (y (copy-seq "fghij")) + (z #\X)) + (rotatef (char x 1) (char y 2) z) + (values x y z)) + "ahcde" "fgXij" #\b) + +(deftest rotatef.21 + (let* ((x (copy-seq #*11000)) + (y (copy-seq #*11100)) + (z 1)) + (rotatef (bit x 1) (bit y 3) z) + (values x y z)) + #*10000 #*11110 1) + +(deftest rotatef.22 + (let* ((x (copy-seq "abcde")) + (y (copy-seq "fghij")) + (z #\X)) + (rotatef (char x 1) (char y 2) z) + (values x y z)) + "ahcde" "fgXij" #\b) + +(deftest rotatef.23 + (let* ((x (copy-seq '(a b c d e))) + (y (copy-seq '(f g h i j))) + (z 'k)) + (rotatef (elt x 1) (elt y 2) z) + (values x y z)) + (a h c d e) (f g k i j) b) + +(deftest rotatef.24 + (let ((x #b01010101) + (y #b1111) + (z 0)) + (rotatef (ldb (byte 4 2) x) + (ldb (byte 4 1) y) + z) + (values x y z)) + #b01011101 + 1 + #b0101) + +(deftest rotatef.25 + (let* ((f1 (gensym)) + (f2 (gensym)) + (fn1 (constantly :foo)) + (fn2 (constantly :bar)) + (fn3 (constantly :zzz))) + (setf (fdefinition f1) fn1 + (fdefinition f2) fn2) + (rotatef (fdefinition f1) + (fdefinition f2) + fn3) + (values (funcall f1) (funcall f2) (funcall fn3))) + :bar :zzz :foo) + +(deftest rotatef.26 + (let* ((a1 (make-array '(10) :fill-pointer 5)) + (a2 (make-array '(20) :fill-pointer 7)) + (z 3)) + (rotatef (fill-pointer a1) (fill-pointer a2) z) + (values (fill-pointer a1) (fill-pointer a2) z)) + 7 3 5) + +(deftest rotatef.27 + (let* ((x (list 'a 'b 'c 'd)) + (y (list 'd 'e 'f 'g)) + (n1 1) (n2 2) + (z 'h)) + (rotatef (nth n1 x) (nth n2 y) z) + (values x y z)) + (a f c d) + (d e h g) + b) + +(deftest rotatef.28 + (let* ((f1 (gensym)) + (f2 (gensym)) + (fn1 (constantly :foo)) + (fn2 (constantly :bar)) + (fn3 (constantly :zzz))) + (setf (symbol-function f1) fn1 + (symbol-function f2) fn2) + (rotatef (symbol-function f1) (symbol-function f2) fn3) + (values (funcall f1) (funcall f2) (funcall fn3))) + :bar :zzz :foo) + +(deftest rotatef.29 + (let* ((s1 (gensym)) + (s2 (gensym)) + (z 1)) + (setf (symbol-value s1) :foo + (symbol-value s2) :bar) + (rotatef (symbol-value s1) + (symbol-value s2) + z) + (values (symbol-value s1) (symbol-value s2) z)) + :bar 1 :foo) + +(deftest rotatef.30 + (let* ((s1 (gensym)) + (s2 (gensym)) + (v1 (list :foo 1)) + (v2 (list :bar 2)) + (z nil)) + (setf (symbol-plist s1) v1 + (symbol-plist s2) v2) + (rotatef (symbol-plist s1) (symbol-plist s2) z) + (values (symbol-plist s1) (symbol-plist s2) z)) + (:bar 2) nil (:foo 1)) + +(deftest rotatef.31 + (let* ((x (list 'a 'b 'c 'd 'e)) + (y (list 'f 'g 'h 'i 'j)) + (p1 1) (p2 2) (len 3) + (z '(10 11 12))) + (rotatef (subseq x p1 (+ p1 len)) + (subseq y p2 (+ p2 len)) + z) + (values x y z)) + (a h i j e) + (f g 10 11 12) + (b c d)) + +(deftest rotatef.32 + (let* ((x (gensym)) + (y (gensym)) + (k1 :foo) + (k2 :bar) + (v1 1) + (v2 2) + (z 17)) + (setf (get x k1) v1 (get y k2) v2) + (rotatef (get x k1) (get y k2) z) + (values (symbol-plist x) (symbol-plist y) z)) + (:foo 2) (:bar 17) 1) + +(deftest rotatef.33 + (let* ((x nil) + (y nil) + (k1 :foo) + (k2 :bar) + (v1 1) + (v2 2) + (z 21)) + (setf (getf x k1) v1 (getf y k2) v2) + (rotatef (getf x k1) (getf y k2) z) + (values x y z)) + (:foo 2) (:bar 21) 1) + +(deftest rotatef.34 + (let* ((ht1 (make-hash-table)) + (ht2 (make-hash-table)) + (k1 :foo) (v1 1) + (k2 :bar) (v2 2) + (z 3)) + (setf (gethash k1 ht1) v1 + (gethash k2 ht2) v2) + (rotatef z (gethash k1 ht1) (gethash k2 ht2)) + (values z (gethash k1 ht1) (gethash k2 ht2))) + 1 2 3) + +(deftest rotatef.35 + (let ((n1 (gensym)) + (n2 (gensym)) + (n3 (gensym)) + (n4 (gensym))) + (eval `(defclass ,n1 () ())) + (eval `(defclass ,n2 () ())) + (setf (find-class n3) (find-class n1) + (find-class n4) (find-class n2)) + (rotatef (find-class n3) (find-class n4)) + (values (eqlt (find-class n1) (find-class n4)) + (eqlt (find-class n2) (find-class n3)))) + t t) + +;;; TODO: macro-function, mask-field, row-major-aref, +;;; logical-pathname-translations, readtable-case