Commit 3d42f668 authored by pfdietz's avatar pfdietz

Added check that PI is a constant. Added test for loop as across for...

Added check that PI is a constant.  Added test for loop as across for displaced bit vectors (gcl is failing on this).  Added error case checks for defstruct-defined functions (still must add checks for constructors.)  Error tests for copy-structure.
parent 54ccbb07
......@@ -61,4 +61,8 @@
(notnot (constantp ''(((foo)))))
t)
(deftest constantp.10
(notnot (constantp 'pi))
t)
......@@ -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)
......@@ -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
......
......@@ -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)
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