Skip to content
Snippets Groups Projects
Commit 0215170e authored by pfdietz's avatar pfdietz
Browse files

More refactoring (of fill-pointer tests), and added string tests.

parent 560a875e
No related branches found
No related tags found
No related merge requests found
...@@ -5,28 +5,47 @@ ...@@ -5,28 +5,47 @@
(in-package :cl-test) (in-package :cl-test)
(defun listify-form (form)
(cond
((integerp form) `'(,form))
((null form) nil)
((and (consp form)
(eq (car form) 'quote)
(consp (cadr form)))
form)
(t `(let ((x ,form)) (if (listp x) x (list x))))))
(defmacro def-adjust-array-test (name args1 args2 expected-result) (defmacro def-adjust-array-test (name args1 args2 expected-result)
(flet ((%listify (form) `(deftest ,name
(cond (let* ((a1 (make-array ,@args1))
((integerp form) `'(,form)) (a2 (adjust-array a1 ,@args2)))
((null form) nil) (assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
((and (consp form) (assert (or (adjustable-array-p a1)
(eq (car form) 'quote) (equal (array-dimensions a1) ,(listify-form (first args1)))))
(consp (cadr form))) (assert (equal (array-dimensions a2) ,(listify-form (first args2))))
form) ,@(unless (or (member :displaced-to args1)
(t `(let ((x ,form)) (if (listp x) x (list x))))))) (member :displaced-to args2))
`(deftest ,name (list '(assert (not (array-displacement a2)))))
(let* ((a1 (make-array ,@args1)) a2)
(a2 (adjust-array a1 ,@args2))) ,expected-result))
(assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
(assert (or (adjustable-array-p a1) (defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results)
(equal (array-dimensions a1) ,(%listify (first args1))))) `(deftest ,name
(assert (equal (array-dimensions a2) ,(%listify (first args2)))) (let* ((a1 (make-array ,@args1))
,@(unless (or (member :displaced-to args1) (a2 (adjust-array a1 ,@args2)))
(member :displaced-to args2)) (assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
(list '(assert (not (array-displacement a2))))) (assert (or (adjustable-array-p a1)
a2) (equal (array-dimensions a1) ,(listify-form (first args1)))))
,expected-result))) (assert (equal (array-dimensions a2) ,(listify-form (first args2))))
,@(unless (or (member :displaced-to args1)
(member :displaced-to args2))
(list '(assert (not (array-displacement a2)))))
,@(when misc (list misc))
(values
(fill-pointer a2)
a2))
,@expected-results))
(def-adjust-array-test adjust-array.1 (def-adjust-array-test adjust-array.1
(5 :initial-contents '(a b c d e)) (5 :initial-contents '(a b c d e))
...@@ -49,82 +68,36 @@ ...@@ -49,82 +68,36 @@
(8 :initial-contents '(8 7 6 5 4 3 2 1)) (8 :initial-contents '(8 7 6 5 4 3 2 1))
#(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1))
(deftest adjust-array.5 (def-adjust-array-fp-test adjust-array.5
(let* ((a1 (make-array 5 :initial-contents '(a b c d e) :fill-pointer 3)) (5 :initial-contents '(a b c d e) :fill-pointer 3)
(a2 (adjust-array a1 4))) (4)
(assert (if (adjustable-array-p a1) (assert (eq (aref a2 3) 'd))
(eq a1 a2) 3 #(a b c))
(equal (array-dimensions a1) '(5))))
(assert (not (array-displacement a2))) (def-adjust-array-fp-test adjust-array.6
(values (5 :initial-contents '(a b c d e) :fill-pointer 3)
(array-dimensions a2) (4 :fill-pointer nil)
(fill-pointer a2) (assert (eq (aref a2 3) 'd))
a2 3 #(a b c))
(aref a2 3)))
(4) 3 #(a b c) d) (def-adjust-array-fp-test adjust-array.7
(5 :initial-contents '(a b c d e) :fill-pointer 3)
(deftest adjust-array.6 (4 :fill-pointer t)
(let* ((a1 (make-array 5 :initial-contents '(a b c d e) nil
:fill-pointer 3)) 4 #(a b c d))
(a2 (adjust-array a1 4 :fill-pointer nil)))
(assert (if (adjustable-array-p a1) (def-adjust-array-fp-test adjust-array.8
(eq a1 a2) (5 :initial-contents '(a b c d e) :fill-pointer 3)
(equal (array-dimensions a1) '(5)))) (4 :fill-pointer 2)
(assert (not (array-displacement a2))) (progn (assert (eq (aref a2 2) 'c))
(values (assert (eq (aref a2 3) 'd)))
(array-dimensions a2) 2 #(a b))
(fill-pointer a2)
a2 (def-adjust-array-fp-test adjust-array.9
(aref a2 3))) (5 :initial-contents '(a b c d e) :fill-pointer 3)
(4) 3 #(a b c) d) (8 :fill-pointer 5 :initial-element 'x)
(assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x)))
(deftest adjust-array.7 5 #(a b c d e))
(let* ((a1 (make-array 5 :initial-contents '(a b c d e)
:fill-pointer 3))
(a2 (adjust-array a1 4 :fill-pointer t)))
(assert (if (adjustable-array-p a1)
(eq a1 a2)
(equal (array-dimensions a1) '(5))))
(assert (not (array-displacement a2)))
(values
(array-dimensions a2)
(fill-pointer a2)
a2))
(4) 4 #(a b c d))
(deftest adjust-array.8
(let* ((a1 (make-array 5 :initial-contents '(a b c d e)
:fill-pointer 3))
(a2 (adjust-array a1 4 :fill-pointer 2)))
(assert (if (adjustable-array-p a1)
(eq a1 a2)
(equal (array-dimensions a1) '(5))))
(assert (not (array-displacement a2)))
(values
(array-dimensions a2)
(fill-pointer a2)
a2
(aref a2 2)
(aref a2 3)))
(4) 2 #(a b) c d)
(deftest adjust-array.9
(let* ((a1 (make-array 5 :initial-contents '(a b c d e)
:fill-pointer 3))
(a2 (adjust-array a1 8 :fill-pointer 5
:initial-element 'x)))
(assert (if (adjustable-array-p a1)
(eq a1 a2)
(equal (array-dimensions a1) '(5))))
(assert (not (array-displacement a2)))
(values
(array-dimensions a2)
(fill-pointer a2)
a2
(aref a2 5)
(aref a2 6)
(aref a2 7)))
(8) 5 #(a b c d e) x x x)
(deftest adjust-array.10 (deftest adjust-array.10
(let* ((a1 (make-array 5 :initial-contents '(a b c d e))) (let* ((a1 (make-array 5 :initial-contents '(a b c d e)))
...@@ -280,73 +253,35 @@ ...@@ -280,73 +253,35 @@
(8 :initial-contents '(8 7 6 5 4 3 2 1)) (8 :initial-contents '(8 7 6 5 4 3 2 1))
#(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1))
(deftest adjust-array.adjustable.5 (def-adjust-array-fp-test adjust-array.adjustable.5
(let* ((a1 (make-array 5 :initial-contents '(a b c d e) (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
:fill-pointer 3 :adjustable t)) (4)
(a2 (adjust-array a1 4))) (assert (eq (aref a2 3) 'd))
(assert (eq a1 a2)) 3 #(a b c))
(assert (not (array-displacement a2)))
(values (def-adjust-array-fp-test adjust-array.adjustable.6
(array-dimensions a2) (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
(fill-pointer a2) (4 :fill-pointer nil)
a2 (assert (eq (aref a2 3) 'd))
(aref a2 3))) 3 #(a b c))
(4) 3 #(a b c) d)
(def-adjust-array-fp-test adjust-array.adjustable.7
(deftest adjust-array.adjustable.6 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
(let* ((a1 (make-array 5 :initial-contents '(a b c d e) (4 :fill-pointer t)
:fill-pointer 3 :adjustable t)) nil
(a2 (adjust-array a1 4 :fill-pointer nil))) 4 #(a b c d))
(assert (eq a1 a2))
(assert (not (array-displacement a2))) (def-adjust-array-fp-test adjust-array.adjustable.8
(values (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
(array-dimensions a2) (4 :fill-pointer 2)
(fill-pointer a2) (assert (equal (list (aref a2 2) (aref a2 3)) '(c d)))
a2 2 #(a b))
(aref a2 3)))
(4) 3 #(a b c) d) (def-adjust-array-fp-test adjust-array.adjustable.9
(5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
(deftest adjust-array.adjustable.7 (8 :fill-pointer 5 :initial-element 'x)
(let* ((a1 (make-array 5 :initial-contents '(a b c d e) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x)))
:fill-pointer 3 :adjustable t)) 5 #(a b c d e))
(a2 (adjust-array a1 4 :fill-pointer t)))
(assert (eq a1 a2))
(assert (not (array-displacement a2)))
(values
(array-dimensions a2)
(fill-pointer a2)
a2))
(4) 4 #(a b c d))
(deftest adjust-array.adjustable.8
(let* ((a1 (make-array 5 :initial-contents '(a b c d e)
:fill-pointer 3 :adjustable t))
(a2 (adjust-array a1 4 :fill-pointer 2)))
(assert (eq a1 a2))
(assert (not (array-displacement a2)))
(values
(array-dimensions a2)
(fill-pointer a2)
a2
(aref a2 2)
(aref a2 3)))
(4) 2 #(a b) c d)
(deftest adjust-array.adjustable.9
(let* ((a1 (make-array 5 :initial-contents '(a b c d e)
:fill-pointer 3 :adjustable t))
(a2 (adjust-array a1 8 :fill-pointer 5
:initial-element 'x)))
(assert (eq a1 a2))
(assert (not (array-displacement a2)))
(values
(array-dimensions a2)
(fill-pointer a2)
a2
(aref a2 5)
(aref a2 6)
(aref a2 7)))
(8) 5 #(a b c d e) x x x)
(deftest adjust-array.adjustable.10 (deftest adjust-array.adjustable.10
(let* ((a1 (make-array 5 :initial-contents '(a b c d e) (let* ((a1 (make-array 5 :initial-contents '(a b c d e)
...@@ -387,6 +322,62 @@ ...@@ -387,6 +322,62 @@
#(c d e y)) #(c d e y))
;;;; Strings
(def-adjust-array-test adjust-array.string.1
(5 :element-type 'character :initial-contents "abcde")
(4 :element-type 'character)
"abcd")
(def-adjust-array-test adjust-array.string.2
(5 :element-type 'character :initial-contents "abcde")
(8 :element-type 'character :initial-element #\x)
"abcdexxx")
(def-adjust-array-test adjust-array.string.3
(5 :element-type 'character :initial-contents "abcde")
(4 :element-type 'character :initial-contents "wxyz")
"wxyz")
(def-adjust-array-test adjust-array..string.4
(5 :element-type 'character :initial-contents "abcde")
(8 :element-type 'character :initial-contents "87654321")
"87654321")
(def-adjust-array-fp-test adjust-array.string.5
(5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
(4 :element-type 'character)
(assert (eql (aref a2 3) #\d))
3 "abc")
(def-adjust-array-fp-test adjust-array.string.6
(5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
(4 :element-type 'character :fill-pointer nil)
(assert (eql (aref a2 3) #\d))
3 "abc")
(def-adjust-array-fp-test adjust-array.string.7
(5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
(4 :element-type 'character :fill-pointer t)
nil
4 "abcd")
(def-adjust-array-fp-test adjust-array.string.8
(5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
(4 :element-type 'character :fill-pointer 2)
(progn (assert (eql (aref a2 2) #\c))
(assert (eql (aref a2 3) #\d)))
2 "ab")
(def-adjust-array-fp-test adjust-array.string.9
(5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
(8 :element-type 'character :fill-pointer 5 :initial-element #\x)
(assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7))
'(#\x #\x #\x)))
5 "abcde")
;;; Add displaced string tests, adjustable string tests
;;; FIXME. Tests for: ;;; FIXME. Tests for:
;;; strings/character arrays ;;; strings/character arrays
;;; bit vectors/arrays ;;; bit vectors/arrays
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment