diff --git a/ansi-tests/constantp.lsp b/ansi-tests/constantp.lsp index d5b363d4025e0064a6fceff293830624d6cf6cf8..77405b09df71513797a3cc066711a5d8f17de219 100644 --- a/ansi-tests/constantp.lsp +++ b/ansi-tests/constantp.lsp @@ -61,4 +61,8 @@ (notnot (constantp ''(((foo))))) t) +(deftest constantp.10 + (notnot (constantp 'pi)) + t) + diff --git a/ansi-tests/loop5.lsp b/ansi-tests/loop5.lsp index e613502c971fc5829d8c07372d1832a8bb3f6d01..d5f2a8ccdab3720ae6cfcd7e1db6d553a028da7e 100644 --- a/ansi-tests/loop5.lsp +++ b/ansi-tests/loop5.lsp @@ -116,6 +116,34 @@ sum e) 6) +;;; Loop across displaced vectors + +(deftest loop.5.36 + (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) + (da (make-array '(5) :displaced-to a + :displaced-index-offset 2))) + (loop for e across da collect e)) + (c d e f g)) + +(deftest loop.5.37 + (let* ((a (make-array '(10) :element-type 'base-char + :initial-contents "abcdefghij")) + (da (make-array '(5) :element-type 'base-char + :displaced-to a + :displaced-index-offset 2))) + (loop for e across da collect e)) + (#\c #\d #\e #\f #\g)) + +(deftest loop.5.38 + (let* ((a (make-array '(10) :element-type 'bit + :initial-contents '(0 1 1 0 0 1 0 1 1 1))) + (da (make-array '(5) :element-type 'bit + :displaced-to a + :displaced-index-offset 2))) + (loop for e across da collect e)) + (1 0 0 1 0)) + + ;;; Error cases (deftest loop.5.error.1 @@ -142,8 +170,3 @@ for e from 1 to 5 collect e))) program-error) - - - - - diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index 02119df46ddcf5fc9531b814074981fd3513658f..e67914fbd45bf4edcdada0324e73a30b317cb2d2 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -10,7 +10,7 @@ ;; (declare (type (or string symbol character) structure-name) ;; (type fixnum n)) (assert (typep structure-name '(or string symbol character))) - (assert (typep n 'fixnum)) + ;; (assert (typep n 'fixnum)) (setf structure-name (string structure-name)) (intern (concatenate 'string structure-name @@ -285,12 +285,21 @@ do the defstruct." ;; Test that the predicate exists ,@(when p-fn `((deftest ,(make-struct-test-name name 2) - (and (fboundp (quote ,p-fn)) - (functionp (function ,p-fn)) - (symbol-function (quote ,p-fn)) - (notnot (funcall #',p-fn (,make-fn))) - (notnot (,p-fn (,make-fn)))) - t))) + (let ((s (,make-fn))) + (and (fboundp (quote ,p-fn)) + (functionp (function ,p-fn)) + (symbol-function (quote ,p-fn)) + (notnot (funcall #',p-fn s)) + (notnot (,p-fn s)) + )) + t) + (deftest ,(make-struct-test-name name "ERROR.1") + (classify-error (,p-fn)) + program-error) + (deftest ,(make-struct-test-name name "ERROR.2") + (classify-error (,p-fn (,make-fn) nil)) + program-error) + )) ;; Test that the elements of *universe* are not ;; of this type @@ -317,15 +326,40 @@ do the defstruct." (list* (intern (string slot-name) "KEYWORD") (list 'quote initval) inits)) - (push `(and (eqlt (quote ,initval) - (,field-fn ,var)) - (eqlt (quote ,initval) - (funcall #',field-fn ,var))) + (push `(and + (eqlt (quote ,initval) + (,field-fn ,var)) + (eqlt (quote ,initval) + (funcall #',field-fn ,var))) tests)) `(let ((,var (,make-fn . ,inits))) (and ,@tests t))) t) + (deftest ,(make-struct-test-name name "ERROR.3") + (remove nil + (list + ,@(loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + collect + `(let ((x (classify-error (,field-fn)))) + (unless (eqt x 'program-error) + (list ',slot-name ',field-fn x)))))) + nil) + + (deftest ,(make-struct-test-name name "ERROR.4") + (remove nil + (list + ,@(loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + collect + `(let ((x (classify-error (,field-fn (,make-fn) nil)))) + (unless (eqt x 'program-error) + (list ',slot-name ',field-fn x)))))) + nil) + ;; Check that two invocations return different structures (deftest ,(make-struct-test-name name 6) (eqt (,make-fn) (,make-fn)) @@ -357,7 +391,14 @@ do the defstruct." (functionp (function ,copy-fn)) (symbol-function (quote ,copy-fn)) t) - t))) + t) + (deftest ,(make-struct-test-name name "ERROR.5") + (classify-error (,copy-fn)) + program-error) + (deftest ,(make-struct-test-name name "ERROR.6") + (classify-error (,copy-fn (,make-fn) nil)) + program-error) + )) ;; Check that the copy function properly copies fields ,@(when copy-fn diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp index f1a1a4c221badcb9e0ee54cdb46ac9506e1b61a7..5d5089c4c99e7adb3739224739fd4e897f447fab 100644 --- a/ansi-tests/structures-02.lsp +++ b/ansi-tests/structures-02.lsp @@ -403,3 +403,14 @@ (funcall g nil) (funcall f))) nil a nil nil) + +;;; Error tests + +(deftest copy-structure.error.1 + (classify-error (copy-structure)) + program-error) + +(deftest copy-structure.error.2 + (classify-error (copy-structure (make-s-2) nil)) + program-error) +