Commit 4eddbd96 authored by pfdietz's avatar pfdietz
Browse files

Fixed some broken structure tests (the values of uninitialized fields

are not specified by the standard; they need not be nil.)

Added additional tests to the defstruct-with-tests macros (check that
FUNCALLing various defstruct-defined functions works.)

Started on structures-03.lsp, which will test BOA constructor functions.
parent 64e09bb8
...@@ -263,6 +263,7 @@ do the defstruct." ...@@ -263,6 +263,7 @@ do the defstruct."
(and (fboundp (quote ,p-fn)) (and (fboundp (quote ,p-fn))
(functionp (function ,p-fn)) (functionp (function ,p-fn))
(symbol-function (quote ,p-fn)) (symbol-function (quote ,p-fn))
(notnot (funcall #',p-fn (,make-fn)))
(notnot (,p-fn (,make-fn)))) (notnot (,p-fn (,make-fn))))
t))) t)))
...@@ -291,8 +292,10 @@ do the defstruct." ...@@ -291,8 +292,10 @@ do the defstruct."
(list* (intern (string slot-name) "KEYWORD") (list* (intern (string slot-name) "KEYWORD")
(list 'quote initval) (list 'quote initval)
inits)) inits))
(push `(eqlt (quote ,initval) (push `(and (eqlt (quote ,initval)
(,field-fn ,var)) (,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)))
...@@ -335,7 +338,8 @@ do the defstruct." ...@@ -335,7 +338,8 @@ do the defstruct."
,@(when copy-fn ,@(when copy-fn
`((deftest ,(make-struct-test-name name 9) `((deftest ,(make-struct-test-name name 9)
,(let* ((var 'XTEMP-9) ,(let* ((var 'XTEMP-9)
(var2 'YTEMP-9)) (var2 'YTEMP-9)
(var3 'ZTEMP-9))
`(let ((,var (,make-fn `(let ((,var (,make-fn
,@(loop ,@(loop
for (slot-name . initval) for (slot-name . initval)
...@@ -343,14 +347,18 @@ do the defstruct." ...@@ -343,14 +347,18 @@ do the defstruct."
nconc (list (intern (string slot-name) nconc (list (intern (string slot-name)
"KEYWORD") "KEYWORD")
`(quote ,initval)))))) `(quote ,initval))))))
(let ((,var2 (,copy-fn ,var))) (let ((,var2 (,copy-fn ,var))
(,var3 (funcall #',copy-fn ,var)))
(and (and
(not (eqlt ,var ,var2)) (not (eqlt ,var ,var2))
(not (eqlt ,var ,var3))
(not (eqlt ,var2 ,var3))
,@(loop ,@(loop
for (slot-name . nil) in initial-value-alist for (slot-name . nil) in initial-value-alist
for fn in field-fns for fn in field-fns
collect collect
`(eqlt (,fn ,var) (,fn ,var2))) `(and (eqlt (,fn ,var) (,fn ,var2))
(eqlt (,fn ,var) (,fn ,var3))))
t)))) t))))
t))) t)))
......
...@@ -204,25 +204,22 @@ ...@@ -204,25 +204,22 @@
(defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) (defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37)
(deftest structure-37-1 (deftest structure-37-1
(equalt (make-struct-test-37 :a37 1 :b37 2 :c37 4) (make-struct-test-37 :a37 1 :b37 2 :c37 4)
'(1 2 4)) (1 2 4))
t)
(defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) (defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38)
(deftest structure-38-1 (deftest structure-38-1
(equalt (make-struct-test-38 :a38 11 :b38 12 :c38 4) (make-struct-test-38 :a38 11 :b38 12 :c38 4)
'(struct-test-38 11 12 4)) (struct-test-38 11 12 4))
t)
(defstruct-with-tests (struct-test-39 (:predicate nil) (defstruct-with-tests (struct-test-39 (:predicate nil)
(:type list) :named) (:type list) :named)
a39 b39 c39) a39 b39 c39)
(deftest structure-39-1 (deftest structure-39-1
(equalt (make-struct-test-39 :a39 11 :b39 12 :c39 4) (make-struct-test-39 :a39 11 :b39 12 :c39 4)
'(struct-test-39 11 12 4)) (struct-test-39 11 12 4))
t)
(defstruct-with-tests (struct-test-40 (:type vector)) a40 b40) (defstruct-with-tests (struct-test-40 (:type vector)) a40 b40)
(defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41) (defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41)
...@@ -247,16 +244,16 @@ ...@@ -247,16 +244,16 @@
a45 b45) a45 b45)
(deftest structure-45-1 (deftest structure-45-1
(make-struct-test-45 :a45 1 :b45 2) (cddr (make-struct-test-45 :a45 1 :b45 2))
(nil nil 1 2)) (1 2))
(defstruct-with-tests (struct-test-46 (:type list) (defstruct-with-tests (struct-test-46 (:type list)
(:include struct-test-45)) (:include struct-test-45))
c46 d46) c46 d46)
(deftest structure-46-1 (deftest structure-46-1
(make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4) (cddr (make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4))
(nil nil 1 2 3 4)) (1 2 3 4))
(defstruct-with-tests (struct-test-47 (:type list) (defstruct-with-tests (struct-test-47 (:type list)
(:initial-offset 3) (:initial-offset 3)
...@@ -264,8 +261,9 @@ ...@@ -264,8 +261,9 @@
c47 d47) c47 d47)
(deftest structure-47-1 (deftest structure-47-1
(make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4) (let ((s (make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4)))
(nil nil 1 2 nil nil nil 3 4)) (values (third s) (fourth s) (eighth s) (ninth s)))
1 2 3 4)
(defstruct-with-tests (struct-test-48 (:type list) (defstruct-with-tests (struct-test-48 (:type list)
(:initial-offset 0) (:initial-offset 0)
...@@ -273,8 +271,8 @@ ...@@ -273,8 +271,8 @@
c48 d48) c48 d48)
(deftest structure-48-1 (deftest structure-48-1
(make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4) (cddr (make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4))
(nil nil 1 2 3 4)) (1 2 3 4))
(defstruct-with-tests (struct-test-49 (:type (vector bit))) (defstruct-with-tests (struct-test-49 (:type (vector bit)))
(a49 0 :type bit) (a49 0 :type bit)
...@@ -297,9 +295,9 @@ ...@@ -297,9 +295,9 @@
a53 b53) a53 b53)
(deftest structure-53-1 (deftest structure-53-1
(equal-array (make-struct-test-53 :a53 10 :b53 'a) (let ((s (make-struct-test-53 :a53 10 :b53 'a)))
#(nil nil nil nil nil 10 a)) (values (aref s 5) (aref s 6)))
t) 10 a)
(defstruct-with-tests (struct-test-54 (:type vector) (defstruct-with-tests (struct-test-54 (:type vector)
(:initial-offset 2) (:initial-offset 2)
...@@ -307,9 +305,9 @@ ...@@ -307,9 +305,9 @@
a54 b54) a54 b54)
(deftest structure-54-1 (deftest structure-54-1
(equal-array (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a) (let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a)))
#(nil nil nil nil nil 8 g nil nil 10 a)) (values (aref s 5) (aref s 6) (aref s 9) (aref s 10)))
t) 8 g 10 a)
(defstruct-with-tests (struct-test-55 (:type list) (defstruct-with-tests (struct-test-55 (:type list)
(:initial-offset 2) (:initial-offset 2)
...@@ -317,10 +315,26 @@ ...@@ -317,10 +315,26 @@
a55 b55 c55) a55 b55 c55)
(deftest structure-55-1 (deftest structure-55-1
(make-struct-test-55 :a55 'p :c55 'q) (let ((s (make-struct-test-55 :a55 'p :c55 'q)))
(nil nil struct-test-55 p nil q)) (values (third s) (fourth s) (sixth s)))
struct-test-55 p q)
(defstruct-with-tests (struct-test-56 (:type list)
(:initial-offset 3)
(:include struct-test-55)
:named)
d56 e56)
(deftest structure-56-1
(let ((s (make-struct-test-56 :a55 3 :b55 7 :d56 'x :e56 'y)))
(mapcar #'(lambda (i) (nth i s)) '(2 3 4 9 10 11)))
(struct-test-55 3 7 struct-test-56 x y))
(defstruct-with-tests (struct-test-57 (:include struct-test-22))
c57 d57)
;;;; Tests of error cases
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Dec 20 05:58:06 2002
;;;; Contains: BOA Constructor Tests
(in-package :cl-test)
\ No newline at end of file
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