From dd51d82507ab195daf850f1ae1e825f8782c27b7 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 12 Feb 2017 14:12:59 -0800
Subject: [PATCH] Change is-X-of from compound to parametric predicates.

---
 src/runtime/compound-predicate.scm          | 41 -----------------
 src/runtime/parametric-predicate.scm        | 49 ++++++++++++++++++---
 src/runtime/runtime.pkg                     |  6 +--
 tests/runtime/test-parametric-predicate.scm |  2 +-
 4 files changed, 48 insertions(+), 50 deletions(-)

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index aad7bd579..cf5169343 100644
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -111,28 +111,6 @@ USA.
 		  'conjoin
 		  predicates))
 
-(define (is-list-of predicate)
-  (make-predicate (lambda (object)
-		    (and (list? object)
-			 (every predicate object)))
-		  'is-list-of
-		  (list predicate)))
-
-(define (is-non-empty-list-of predicate)
-  (make-predicate (lambda (object)
-		    (and (non-empty-list? object)
-			 (every predicate object)))
-		  'is-non-empty-list-of
-		  (list predicate)))
-
-(define (is-pair-of car-predicate cdr-predicate)
-  (make-predicate (lambda (object)
-		    (and (pair? object)
-			 (car-predicate (car object))
-			 (cdr-predicate (cdr object))))
-		  'is-pair-of
-		  (list car-predicate cdr-predicate)))
-
 (define (make-predicate datum-test operator operands)
   (if (every predicate? operands)
       (tag->predicate
@@ -154,25 +132,6 @@ USA.
      unspecific)
    (register-predicate! compound-operator? 'compound-predicate '<= symbol?)))
 
-(add-boot-init!
- (lambda ()
-
-   (define (make-listish-memoizer)
-     (simple-list-memoizer eq?
-       (lambda (datum-test operator tags)
-	 (declare (ignore datum-test operator))
-	 tags)
-       make-compound-tag))
-
-   (define-compound-operator 'is-list-of
-     (make-listish-memoizer))
-
-   (define-compound-operator 'is-non-empty-list-of
-     (make-listish-memoizer))
-
-   (define-compound-operator 'is-pair-of
-     (make-listish-memoizer))))
-
 (add-boot-init!
  (lambda ()
 
diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm
index e2e28d61c..8721e23cc 100644
--- a/src/runtime/parametric-predicate.scm
+++ b/src/runtime/parametric-predicate.scm
@@ -104,7 +104,11 @@ USA.
 					   patterned-tags
 					   tag-name
 					   caller))
-	       (make-data-test (lambda () tag))
+	       (apply make-data-test
+		      (map-template-pattern pattern
+					    patterned-tags
+					    tag->predicate
+					    caller))
 	       tagging-strategy
 	       (get-template)
 	       (match-template-pattern pattern
@@ -191,7 +195,7 @@ USA.
 
 (define (template-pattern->names pattern)
   (map template-pattern-element-name pattern))
-
+
 (define (match-template-pattern pattern values value-predicate caller)
   (guarantee list? values caller)
   (if (not (= (length values) (length pattern)))
@@ -223,7 +227,7 @@ USA.
            (else (error:not-a template-pattern? pattern caller))))
        pattern
        object))
-
+
 (define-record-type <parameter-binding>
     (make-parameter-binding element value)
     parameter-binding?
@@ -243,7 +247,7 @@ USA.
        (parameter-binding-element binding))
       (list (parameter-binding-value binding))
       (parameter-binding-value binding)))
-
+
 (add-boot-init!
  (lambda ()
    (register-predicate! parametric-predicate? 'parametric-predicate
@@ -269,4 +273,39 @@ USA.
 				   tags1
 				   tags2))))
 		   (parametric-tag-bindings tag1)
-		   (parametric-tag-bindings tag2)))))))
\ No newline at end of file
+		   (parametric-tag-bindings tag2)))))))
+
+(define is-list-of)
+(define is-non-empty-list-of)
+(define is-pair-of)
+(add-boot-init!
+ (lambda ()
+   (set! is-list-of
+	 (predicate-template-constructor
+	  (make-predicate-template 'is-list-of
+				   '((? elt-predicate))
+				   predicate-tagging-strategy:optional
+				   (lambda (elt-predicate)
+				     (lambda (object)
+				       (list-of-type? object elt-predicate))))))
+   (set! is-non-empty-list-of
+	 (predicate-template-constructor
+	  (make-predicate-template 'is-non-empty-list-of
+				   '((? elt-predicate))
+				   predicate-tagging-strategy:optional
+				   (lambda (elt-predicate)
+				     (lambda (object)
+				       (and (pair? object)
+					    (list-of-type? object
+							   elt-predicate)))))))
+   (set! is-pair-of
+	 (predicate-template-constructor
+	  (make-predicate-template 'is-non-empty-list-of
+				   '((? car-predicate) (? cdr-predicate))
+				   predicate-tagging-strategy:optional
+				   (lambda (car-predicate cdr-predicate)
+				     (lambda (object)
+				       (and (pair? object)
+					    (car-predicate (car object))
+					    (cdr-predicate (cdr object))))))))
+   unspecific))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 143e9bd5e..fe85b4219 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1986,9 +1986,6 @@ USA.
 	  conjoin*
 	  disjoin
 	  disjoin*
-	  is-list-of
-	  is-non-empty-list-of
-	  is-pair-of
 	  no-object?)
   (export (runtime)
 	  compound-tag-operands
@@ -1999,6 +1996,9 @@ USA.
   (files "parametric-predicate")
   (parent (runtime))
   (export ()
+	  is-list-of
+	  is-non-empty-list-of
+	  is-pair-of
 	  make-predicate-template
           parameter-binding-name
           parameter-binding-polarity
diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm
index 5284d7a59..20f368535 100644
--- a/tests/runtime/test-parametric-predicate.scm
+++ b/tests/runtime/test-parametric-predicate.scm
@@ -31,7 +31,7 @@ USA.
 (define (make-template name pattern)
   (make-predicate-template name pattern
 			   predicate-tagging-strategy:always
-			   (lambda (tag) tag any-object?)))
+			   (lambda args args any-object?)))
 
 (define-test 'parametric-predicate-one-parameter
   (lambda ()
-- 
2.25.1