Commit 3d42f668 authored by pfdietz's avatar pfdietz
Browse files

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 @@ ...@@ -61,4 +61,8 @@
(notnot (constantp ''(((foo))))) (notnot (constantp ''(((foo)))))
t) t)
(deftest constantp.10
(notnot (constantp 'pi))
t)
...@@ -116,6 +116,34 @@ ...@@ -116,6 +116,34 @@
sum e) sum e)
6) 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 ;;; Error cases
(deftest loop.5.error.1 (deftest loop.5.error.1
...@@ -142,8 +170,3 @@ ...@@ -142,8 +170,3 @@
for e from 1 to 5 collect e))) for e from 1 to 5 collect e)))
program-error) program-error)
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
;; (declare (type (or string symbol character) structure-name) ;; (declare (type (or string symbol character) structure-name)
;; (type fixnum n)) ;; (type fixnum n))
(assert (typep structure-name '(or string symbol character))) (assert (typep structure-name '(or string symbol character)))
(assert (typep n 'fixnum)) ;; (assert (typep n 'fixnum))
(setf structure-name (string structure-name)) (setf structure-name (string structure-name))
(intern (concatenate 'string (intern (concatenate 'string
structure-name structure-name
...@@ -285,12 +285,21 @@ do the defstruct." ...@@ -285,12 +285,21 @@ do the defstruct."
;; Test that the predicate exists ;; Test that the predicate exists
,@(when p-fn ,@(when p-fn
`((deftest ,(make-struct-test-name name 2) `((deftest ,(make-struct-test-name name 2)
(and (fboundp (quote ,p-fn)) (let ((s (,make-fn)))
(functionp (function ,p-fn)) (and (fboundp (quote ,p-fn))
(symbol-function (quote ,p-fn)) (functionp (function ,p-fn))
(notnot (funcall #',p-fn (,make-fn))) (symbol-function (quote ,p-fn))
(notnot (,p-fn (,make-fn)))) (notnot (funcall #',p-fn s))
t))) (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 ;; Test that the elements of *universe* are not
;; of this type ;; of this type
...@@ -317,15 +326,40 @@ do the defstruct." ...@@ -317,15 +326,40 @@ do the defstruct."
(list* (intern (string slot-name) "KEYWORD") (list* (intern (string slot-name) "KEYWORD")
(list 'quote initval) (list 'quote initval)
inits)) inits))
(push `(and (eqlt (quote ,initval) (push `(and
(,field-fn ,var)) (eqlt (quote ,initval)
(eqlt (quote ,initval) (,field-fn ,var))
(funcall #',field-fn ,var))) (eqlt (quote ,initval)
(funcall #',field-fn ,var)))
tests)) tests))
`(let ((,var (,make-fn . ,inits))) `(let ((,var (,make-fn . ,inits)))
(and ,@tests t))) (and ,@tests t)))
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 ;; Check that two invocations return different structures
(deftest ,(make-struct-test-name name 6) (deftest ,(make-struct-test-name name 6)
(eqt (,make-fn) (,make-fn)) (eqt (,make-fn) (,make-fn))
...@@ -357,7 +391,14 @@ do the defstruct." ...@@ -357,7 +391,14 @@ do the defstruct."
(functionp (function ,copy-fn)) (functionp (function ,copy-fn))
(symbol-function (quote ,copy-fn)) (symbol-function (quote ,copy-fn))
t) 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 ;; Check that the copy function properly copies fields
,@(when copy-fn ,@(when copy-fn
......
...@@ -403,3 +403,14 @@ ...@@ -403,3 +403,14 @@
(funcall g nil) (funcall g nil)
(funcall f))) (funcall f)))
nil a nil nil) 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