Change is-X-of from compound to parametric predicates.

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index aad7bd579009a18e39582f4adf4f74d7ad2dd34f..cf5169343a7669ac27472a6186606483dcb07b6f 100644 (file)
--- 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 e2e28d61cf489d800362be671c28c207fb39cd8f..8721e23ccf1e376754588f55a64ab9ae790f587a 100644 (file)
--- 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))
-
+\f
 (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))
-\f
+
 (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)))
-
+\f
 (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 143e9bd5eabd3cebc83687adcb13c8619f234d37..fe85b42190c8a4504b9918e43a807e59c87cdbb2 100644 (file)
--- 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 5284d7a59df3ae3fd8d6466c050774f99eb83917..20f368535c6d768adc42be1347fa4fa6587c454f 100644 (file)
--- 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 ()