diff --git a/ansi-tests/adjust-array.lsp b/ansi-tests/adjust-array.lsp index 2dc849fa110c0953d741829096cbb237a263695b..c9679da902a2e193a908fbef9ce4a9497cd75aef 100644 --- a/ansi-tests/adjust-array.lsp +++ b/ansi-tests/adjust-array.lsp @@ -5,28 +5,47 @@ (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) - (flet ((%listify (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))))))) - `(deftest ,name - (let* ((a1 (make-array ,@args1)) - (a2 (adjust-array a1 ,@args2))) - (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) - (assert (or (adjustable-array-p a1) - (equal (array-dimensions a1) ,(%listify (first args1))))) - (assert (equal (array-dimensions a2) ,(%listify (first args2)))) - ,@(unless (or (member :displaced-to args1) - (member :displaced-to args2)) - (list '(assert (not (array-displacement a2))))) - a2) - ,expected-result))) + `(deftest ,name + (let* ((a1 (make-array ,@args1)) + (a2 (adjust-array a1 ,@args2))) + (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) + (assert (or (adjustable-array-p a1) + (equal (array-dimensions a1) ,(listify-form (first args1))))) + (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))))) + a2) + ,expected-result)) + +(defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results) + `(deftest ,name + (let* ((a1 (make-array ,@args1)) + (a2 (adjust-array a1 ,@args2))) + (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) + (assert (or (adjustable-array-p a1) + (equal (array-dimensions a1) ,(listify-form (first args1))))) + (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 (5 :initial-contents '(a b c d e)) @@ -49,82 +68,36 @@ (8 :initial-contents '(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1)) -(deftest adjust-array.5 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e) :fill-pointer 3)) - (a2 (adjust-array a1 4))) - (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 3))) - (4) 3 #(a b c) d) - -(deftest adjust-array.6 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e) - :fill-pointer 3)) - (a2 (adjust-array a1 4 :fill-pointer nil))) - (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 3))) - (4) 3 #(a b c) d) - -(deftest adjust-array.7 - (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) +(def-adjust-array-fp-test adjust-array.5 + (5 :initial-contents '(a b c d e) :fill-pointer 3) + (4) + (assert (eq (aref a2 3) 'd)) + 3 #(a b c)) + +(def-adjust-array-fp-test adjust-array.6 + (5 :initial-contents '(a b c d e) :fill-pointer 3) + (4 :fill-pointer nil) + (assert (eq (aref a2 3) 'd)) + 3 #(a b c)) + +(def-adjust-array-fp-test adjust-array.7 + (5 :initial-contents '(a b c d e) :fill-pointer 3) + (4 :fill-pointer t) + nil + 4 #(a b c d)) + +(def-adjust-array-fp-test adjust-array.8 + (5 :initial-contents '(a b c d e) :fill-pointer 3) + (4 :fill-pointer 2) + (progn (assert (eq (aref a2 2) 'c)) + (assert (eq (aref a2 3) 'd))) + 2 #(a b)) + +(def-adjust-array-fp-test adjust-array.9 + (5 :initial-contents '(a b c d e) :fill-pointer 3) + (8 :fill-pointer 5 :initial-element 'x) + (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) + 5 #(a b c d e)) (deftest adjust-array.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e))) @@ -280,73 +253,35 @@ (8 :initial-contents '(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1)) -(deftest adjust-array.adjustable.5 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e) - :fill-pointer 3 :adjustable t)) - (a2 (adjust-array a1 4))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - (values - (array-dimensions a2) - (fill-pointer a2) - a2 - (aref a2 3))) - (4) 3 #(a b c) d) - -(deftest adjust-array.adjustable.6 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e) - :fill-pointer 3 :adjustable t)) - (a2 (adjust-array a1 4 :fill-pointer nil))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - (values - (array-dimensions a2) - (fill-pointer a2) - a2 - (aref a2 3))) - (4) 3 #(a b c) d) - -(deftest adjust-array.adjustable.7 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e) - :fill-pointer 3 :adjustable t)) - (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) +(def-adjust-array-fp-test adjust-array.adjustable.5 + (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) + (4) + (assert (eq (aref a2 3) 'd)) + 3 #(a b c)) + +(def-adjust-array-fp-test adjust-array.adjustable.6 + (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) + (4 :fill-pointer nil) + (assert (eq (aref a2 3) 'd)) + 3 #(a b c)) + +(def-adjust-array-fp-test adjust-array.adjustable.7 + (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) + (4 :fill-pointer t) + nil + 4 #(a b c d)) + +(def-adjust-array-fp-test adjust-array.adjustable.8 + (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) + (4 :fill-pointer 2) + (assert (equal (list (aref a2 2) (aref a2 3)) '(c d))) + 2 #(a b)) + +(def-adjust-array-fp-test adjust-array.adjustable.9 + (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) + (8 :fill-pointer 5 :initial-element 'x) + (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) + 5 #(a b c d e)) (deftest adjust-array.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e) @@ -387,6 +322,62 @@ #(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: ;;; strings/character arrays ;;; bit vectors/arrays