From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 13 Jan 2018 21:29:13 +0000 (-0800)
Subject: Fix test: was depending on tagging strategy to differentiate datum tests.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~368
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=59b7f7cf2b8da4eb49c1e8aa3c0351b5b555e581;p=mit-scheme.git

Fix test: was depending on tagging strategy to differentiate datum tests.
---

diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm
index 542164889..09de85a0d 100644
--- a/tests/runtime/test-parametric-predicate.scm
+++ b/tests/runtime/test-parametric-predicate.scm
@@ -28,13 +28,11 @@ USA.
 
 (declare (usual-integrations))
 
-(define (make-template name pattern)
-  (make-predicate-template name pattern (lambda args args any-object?)))
-
 (define-test 'parametric-predicate-one-parameter
   (lambda ()
     (let ((pattern '((? base))))
-      (let* ((template (make-template 'template pattern))
+      (let* ((template
+	      (make-predicate-template 'template pattern make-flat-test))
              (constructor (predicate-template-constructor template)))
         (test-template-operations template 'template pattern)
 
@@ -50,7 +48,9 @@ USA.
 (define-test 'parametric-predicate-two-parameters
   (lambda ()
     (let ((pattern '((?* domains -) (? base))))
-      (let* ((template (make-template 'template pattern))
+      (let* ((template
+	      (make-predicate-template 'template pattern
+				       make-function-like-test))
              (constructor (predicate-template-constructor template)))
         (test-template-operations template 'template pattern)
 
@@ -65,7 +65,8 @@ USA.
 
 (define-test 'covariant-ordering
   (lambda ()
-    (let* ((template (make-template 'foo '((? a))))
+    (let* ((template
+	    (make-predicate-template 'template '((? a)) make-flat-test))
            (constructor (predicate-template-constructor template)))
       (let ((p1 (constructor (disjoin string? symbol?)))
             (p2 (constructor string?))
@@ -87,7 +88,8 @@ USA.
 
 (define-test 'contravariant-ordering
   (lambda ()
-    (let* ((template (make-template 'foo '((? a -))))
+    (let* ((template
+	    (make-predicate-template 'template '((? a -)) make-flat-test))
            (constructor (predicate-template-constructor template)))
       (let ((p1 (constructor (disjoin string? symbol?)))
             (p2 (constructor string?))
@@ -109,7 +111,8 @@ USA.
 
 (define-test 'mixed-ordering
   (lambda ()
-    (let* ((template (make-template 'foo '((? a -) (? b))))
+    (let* ((template
+	    (make-predicate-template 'template '((? a -) (? b)) make-flat-test))
            (constructor (predicate-template-constructor template)))
       (let ((p1 (constructor (disjoin string? symbol?)
 			     (disjoin string? symbol?)))
@@ -200,11 +203,31 @@ USA.
     (assert-simple-error (lambda () (match-numbers '((?* a) (? b -)) '(1 2))))
     (assert-simple-error (lambda () (match-numbers '((?+ a -) (? b)) '(1 2))))))
 
+(define (make-flat-test . predicates)
+  (lambda (object)
+    (and (list? object)
+	 (= (length predicates) (length object))
+	 (every (lambda (predicate object)
+		  (predicate object))
+		predicates
+		objects))))
+
+(define (make-function-like-test domains codomain)
+  (lambda (object)
+    (and (pair? object)
+	 (codomain (car object))
+	 (list? (cdr object))
+	 (= (length domains) (length (cdr object)))
+	 (every (lambda (domain object)
+		  (domain object))
+		domains
+		objects))))
+
 (define (test-template-operations template name pattern)
   (assert-true (predicate-template? template))
   (assert-false (predicate? template))
   (assert-eqv (predicate-template-name template) name)
-  (assert-equal pattern (predicate-template-pattern template))
+  (assert-equal (predicate-template-pattern template) pattern)
   (assert-lset= eq?
                 (predicate-template-parameter-names template)
                 (map template-pattern-element-name pattern))