Refactor predicate machinery to use tagging strategies.

Also:
* Rename predicate-template-{instantiator,constructor}.
* Add optional caller args to predicate-template-constructor and
  predicate-template-accessor.

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index d104b6626ec62469426152143f63442ee81ab8d3..a5edc25bb64215eaa712634e28908006d325358c 100644 (file)
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -29,9 +29,11 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-compound-tag predicate operator operands)
-  (make-tag predicate
-            (cons operator (map tag-name operands))
+(define (make-compound-tag datum-test operator operands)
+  (make-tag (cons operator (map tag-name operands))
+            datum-test
+           predicate-tagging-strategy:optional
+           operator
             (make-compound-tag-extra operator operands)))
 
 (define (compound-tag? object)

diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm
index 3cb939f2f2f7ed4dc603eec1131f366252dda51a..e2e28d61cf489d800362be671c28c207fb39cd8f 100644 (file)
--- a/src/runtime/parametric-predicate.scm
+++ b/src/runtime/parametric-predicate.scm
@@ -29,9 +29,21 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-parametric-tag predicate name template bindings)
-  (make-tag predicate
-            name
+(define (parametric-predicate? object)
+  (and (predicate? object)
+       (tag-is-parametric? (predicate->tag object))))
+
+(define (parametric-predicate-template predicate)
+  (parametric-tag-template (predicate->tag predicate)))
+
+(define (parametric-predicate-bindings predicate)
+  (parametric-tag-bindings (predicate->tag predicate)))
+
+(define (make-parametric-tag name datum-test tagging-strategy template bindings)
+  (make-tag name
+            datum-test
+           tagging-strategy
+           'make-predicate-template
             (make-parametric-tag-extra template bindings)))
 
 (define (tag-is-parametric? tag)
@@ -49,100 +61,91 @@ USA.
   (template parametric-tag-extra-template)
   (bindings parametric-tag-extra-bindings))
 \f
-(define (parametric-predicate? object)
-  (and (predicate? object)
-       (tag-is-parametric? (predicate->tag object))))
-
-(define (parametric-predicate-template predicate)
-  (parametric-tag-template (predicate->tag predicate)))
+;;;; Templates
 
-(define (parametric-predicate-bindings predicate)
-  (parametric-tag-bindings (predicate->tag predicate)))
+(define (make-predicate-template name pattern tagging-strategy make-data-test)
+  (guarantee template-pattern? pattern 'make-predicate-template)
+  (letrec*
+      ((instantiator
+        (make-instantiator name pattern make-data-test tagging-strategy
+                          (lambda () template)))
+       (template
+        (%make-predicate-template name
+                                 pattern
+                                 (all-args-memoizer equal?
+                                                    (lambda patterned-tags
+                                                      patterned-tags)
+                                                    instantiator)
+                                 (lambda (object)
+                                   (and (parametric-predicate? object)
+                                        (eqv? template
+                                              (parametric-predicate-template
+                                                 object)))))))
+    (register-predicate! (predicate-template-predicate template)
+                        (symbol name '-predicate)
+                         '<= parametric-predicate?)
+    template))
 
 (define-record-type <predicate-template>
     (%make-predicate-template name pattern instantiator predicate)
     predicate-template?
   (name predicate-template-name)
   (pattern predicate-template-pattern)
-  (instantiator predicate-template-instantiator)
+  (instantiator template-instantiator)
   (predicate predicate-template-predicate))
 
-(define (make-predicate-template name pattern)
-  (guarantee template-pattern? pattern 'make-predicate-template)
-  (letrec*
-      ((instantiator
-        (make-predicate-template-instantiator
-         (lambda () template)))
-       (predicate
-        (lambda (object)
-          (and (parametric-predicate? object)
-               (eqv? (parametric-predicate-template object)
-                     template))))
-       (template
-        (%make-predicate-template
-         name
-         pattern
-         (all-args-memoizer equal?
-                            (lambda parameters parameters)
-                            instantiator)
-         predicate)))
-    (register-predicate! predicate (symbol name '-predicate)
-                         '<= parametric-predicate?)
-    template))
+(define (make-instantiator name pattern make-data-test tagging-strategy
+                          get-template)
+  (lambda (patterned-tags caller)
+    (letrec ((tag
+             (make-parametric-tag
+              (cons name
+                    (map-template-pattern pattern
+                                          patterned-tags
+                                          tag-name
+                                          caller))
+              (make-data-test (lambda () tag))
+              tagging-strategy
+              (get-template)
+              (match-template-pattern pattern
+                                      patterned-tags
+                                      tag?
+                                      caller))))
+      tag)))
 \f
-(define (make-predicate-template-instantiator get-template)
-  (lambda parameters
-    (let ((template (get-template)))
-      (let ((name (predicate-template-name template))
-            (pattern (predicate-template-pattern template)))
-        (let ((parameters
-               (map-template-pattern pattern
-                                     parameters
-                                     predicate->tag)))
-          (letrec* ((predicate
-                     (lambda (object)
-                       (and (predicate? object)
-                            (tag<= (predicate->tag object) tag))))
-                    (tag
-                     (make-parametric-tag
-                      predicate
-                      (cons name
-                            (map-template-pattern pattern
-                                                  parameters
-                                                  tag-name))
-                      template
-                      (match-template-pattern pattern
-                                              parameters
-                                              tag?))))
-            predicate))))))
+(define (predicate-template-constructor template #!optional caller)
+  (let ((instantiator (template-instantiator template))
+        (pattern (predicate-template-pattern template)))
+    (lambda patterned-predicates
+      (tag->predicate
+       (instantiator (map-template-pattern pattern
+                                          patterned-predicates
+                                          predicate->tag
+                                          caller)
+                    caller)))))
 
 (define (predicate-template-parameter-names template)
   (template-pattern->names (predicate-template-pattern template)))
 
-(define (predicate-template-accessor name template)
+(define (predicate-template-accessor name template #!optional caller)
   (let ((elt
          (find (lambda (elt)
-                 (eq? (template-pattern-element-name elt) name))
+                 (eq? name (template-pattern-element-name elt)))
                (predicate-template-pattern template))))
     (if (not elt)
-        (error "Unknown parameter name:" name template))
+        (error:bad-range-argument name 'predicate-template-accessor))
     (let ((valid? (predicate-template-predicate template))
           (convert
            (if (template-pattern-element-single-valued? elt)
                tag->predicate
-               tags->predicates)))
+              (lambda (tags) (map tag->predicate tags)))))
       (lambda (predicate)
-        (if (not (valid? predicate))
-            (error "Not a valid predicate:" predicate))
+       (guarantee valid? predicate caller)
         (convert
          (parameter-binding-value
           (find (lambda (binding)
                   (eqv? name (parameter-binding-name binding)))
-                (parametric-tag-bindings
-                 (predicate->tag predicate)))))))))
-
-(define (tags->predicates tags)
-  (map tag->predicate tags))
+                (parametric-tag-bindings (predicate->tag predicate)))))))))
 \f
 ;;;; Template patterns
 
@@ -188,11 +191,11 @@ USA.
 
 (define (template-pattern->names pattern)
   (map template-pattern-element-name pattern))
-\f
-(define (match-template-pattern pattern values value-predicate)
-  (guarantee list? values 'match-template-pattern)
+
+(define (match-template-pattern pattern values value-predicate caller)
+  (guarantee list? values caller)
   (if (not (= (length values) (length pattern)))
-      (error "Wrong number of values:" values pattern))
+      (error:bad-range-argument values caller))
   (map (lambda (element value)
          (case (template-pattern-element-operator element)
            ((?)
@@ -207,12 +210,20 @@ USA.
                           (list? (cdr value))
                           (every value-predicate value)))
                 (error "Mismatch:" element value)))
-           (else
-            (error:not-a template-pattern? pattern 'match-template-pattern)))
+           (else (error:not-a template-pattern? pattern caller)))
          (make-parameter-binding element value))
        pattern
        values))
 
+(define (map-template-pattern pattern object value-procedure caller)
+  (map (lambda (element o)
+         (case (template-pattern-element-operator element)
+           ((?) (value-procedure o))
+           ((?* ?+) (map value-procedure o))
+           (else (error:not-a template-pattern? pattern caller))))
+       pattern
+       object))
+\f
 (define-record-type <parameter-binding>
     (make-parameter-binding element value)
     parameter-binding?
@@ -233,16 +244,6 @@ USA.
       (list (parameter-binding-value binding))
       (parameter-binding-value binding)))
 
-(define (map-template-pattern pattern object value-procedure)
-  (map (lambda (element o)
-         (case (template-pattern-element-operator element)
-           ((?) (value-procedure o))
-           ((?* ?+) (map value-procedure o))
-           (else
-            (error:not-a template-pattern? pattern 'map-template-pattern))))
-       pattern
-       object))
-
 (add-boot-init!
  (lambda ()
    (register-predicate! parametric-predicate? 'parametric-predicate

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index e338fc4a103ca9a9dae23da696eec8ade57face1..5ee5fad1188bdfd7aed3b41c5eba2a0bd6e43040 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -45,8 +45,9 @@ USA.
 (define (register-predicate! predicate name . keylist)
   (guarantee keyword-list? keylist 'register-predicate!)
   (let ((tag
-         (make-tag predicate
-                   name
+         (make-tag name
+                   predicate
+                  predicate-tagging-strategy:never
                    (get-keyword-value keylist 'extra)
                    (get-keyword-value keylist 'description))))
     (for-each (lambda (superset)
@@ -100,22 +101,25 @@ USA.
     (and tag
          (not (tag-extra tag)))))
 \f
-(define (make-tag predicate name #!optional extra description)
-  (guarantee unary-procedure? predicate 'make-tag)
-  (guarantee tag-name? name 'make-tag)
-  (if (predicate? predicate)
-      (error "Predicate is already registered:" predicate))
-  (let ((tag
-         (%make-tag predicate
-                    name
-                    (if (default-object? description)
-                        #f
-                        (guarantee string? description 'make-tag))
-                    (if (default-object? extra) #f extra)
-                   (make-strong-eq-hash-table)
-                   (make-strong-eq-hash-table))))
-    (set-predicate-tag! predicate tag)
-    tag))
+(define (make-tag name datum-test tagging-strategy caller
+                 #!optional extra description)
+  (guarantee tag-name? name caller)
+  (guarantee unary-procedure? datum-test caller)
+  (if (not (default-object? description))
+      (guarantee string? description caller))
+  (tagging-strategy name datum-test
+    (lambda (predicate constructor accessor)
+      (let ((tag
+            (%make-tag name
+                       predicate
+                       constructor
+                       accessor
+                       (if (default-object? extra) #f extra)
+                       (if (default-object? description) #f description)
+                       (make-strong-eq-hash-table)
+                       (make-strong-eq-hash-table))))
+       (set-predicate-tag! predicate tag)
+       tag))))
 
 (define (tag-name? object)
   (or (symbol? object)
@@ -123,12 +127,15 @@ USA.
            (every tag-name? object))))
 
 (define-record-type <tag>
-    (%make-tag predicate name description extra subsets supersets)
+    (%make-tag name predicate constructor accessor extra description
+              subsets supersets)
     tag?
-  (predicate tag->predicate)
   (name tag-name)
-  (description %tag-description)
+  (predicate tag->predicate)
+  (constructor tag-constructor)
+  (accessor tag-accessor)
   (extra tag-extra)
+  (description %tag-description)
   (subsets tag-subsets)
   (supersets tag-supersets))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9f5c1f71220401172c859af1c7e02bffc285f1dc..8d12e9476b3bf0b174fd5318b653e78d23f277c9 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1848,7 +1848,7 @@ USA.
           parametric-predicate-template
           parametric-predicate?
           predicate-template-accessor
-          predicate-template-instantiator
+          predicate-template-constructor
           predicate-template-name
           predicate-template-parameter-names
           predicate-template-pattern
@@ -1859,12 +1859,12 @@ USA.
   (files "predicate-tagging")
   (parent (runtime))
   (export ()
-         object->datum
-         object->predicate
-         object-tagger
          predicate-tagging-strategy:always
          predicate-tagging-strategy:never
          predicate-tagging-strategy:optional
+         object->datum
+         object->predicate
+         object-tagger
          set-tagged-object-unparser-method!
          tag-object
          tagged-object-datum

diff --git a/tests/check.scm b/tests/check.scm
index 6bd1d5d4aa764d9beec6d65e4607d959096a2644..3b6d795c42325c4b214762da95f27633229920e0 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -49,7 +49,7 @@ USA.
     "runtime/test-arith"
     "runtime/test-bytevector"
     ("runtime/test-char-set" (runtime character-set))
-    ("runtime/test-compound-predicate" (runtime compound-predicate))
+    ("runtime/test-compound-predicate" (runtime))
     "runtime/test-dragon4"
     "runtime/test-dynamic-env"
     "runtime/test-division"
@@ -61,8 +61,8 @@ USA.
     "runtime/test-integer-bits"
     "runtime/test-mime-codec"
     ("runtime/test-parametric-predicate" (runtime parametric-predicate))
-    ("runtime/test-predicate-lattice" (runtime predicate-lattice))
-    ("runtime/test-predicate-metadata" (runtime predicate-metadata))
+    ("runtime/test-predicate-lattice" (runtime))
+    ("runtime/test-predicate-metadata" (runtime))
     "runtime/test-thread-queue"
     "runtime/test-process"
     "runtime/test-readwrite"

diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm
index 4357b3706417301186ab8819aaedfe9e06ab9c4f..aa002bc9c071e3246601c55ddaec2302b96f462f 100644 (file)
--- a/tests/runtime/test-parametric-predicate.scm
+++ b/tests/runtime/test-parametric-predicate.scm
@@ -28,17 +28,22 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define (make-template name pattern)
+  (make-predicate-template name pattern
+                          predicate-tagging-strategy:always
+                          (lambda (tag) tag any-object?)))
+
 (define-test 'parametric-predicate-one-parameter
   (lambda ()
     (let ((pattern '((? base))))
-      (let* ((template (make-predicate-template 'template pattern))
-             (instantiator (predicate-template-instantiator template)))
+      (let* ((template (make-template 'template pattern))
+             (constructor (predicate-template-constructor template)))
         (test-template-operations template 'template pattern)
 
         (let ((params1 (list number?))
               (params2 (list boolean?)))
-          (let ((tn (apply instantiator params1))
-                (tb (apply instantiator params2)))
+          (let ((tn (apply constructor params1))
+                (tb (apply constructor params2)))
             (test-predicate-operations tn '(template number))
             (test-predicate-operations tb '(template boolean))
             (test-parametric-predicate-operations tn template params1)
@@ -47,14 +52,14 @@ USA.
 (define-test 'parametric-predicate-two-parameters
   (lambda ()
     (let ((pattern '((?* domains -) (? base))))
-      (let* ((template (make-predicate-template 'template pattern))
-             (instantiator (predicate-template-instantiator template)))
+      (let* ((template (make-template 'template pattern))
+             (constructor (predicate-template-constructor template)))
         (test-template-operations template 'template pattern)
 
         (let ((params1 (list (list number? number?) number?))
               (params2 (list (list boolean? boolean?) boolean?)))
-          (let ((tn (apply instantiator params1))
-                (tb (apply instantiator params2)))
+          (let ((tn (apply constructor params1))
+                (tb (apply constructor params2)))
             (test-predicate-operations tn '(template (number number) number))
             (test-predicate-operations tb '(template (boolean boolean) boolean))
             (test-parametric-predicate-operations tn template params1)
@@ -62,11 +67,11 @@ USA.
 
 (define-test 'covariant-ordering
   (lambda ()
-    (let* ((template (make-predicate-template 'foo '((? a))))
-           (instantiator (predicate-template-instantiator template)))
-      (let ((p1 (instantiator (disjoin string? symbol?)))
-            (p2 (instantiator string?))
-            (p3 (instantiator symbol?)))
+    (let* ((template (make-template 'foo '((? a))))
+           (constructor (predicate-template-constructor template)))
+      (let ((p1 (constructor (disjoin string? symbol?)))
+            (p2 (constructor string?))
+            (p3 (constructor symbol?)))
 
         (assert-true (predicate<= p1 p1))
         (assert-false (predicate<= p1 p2))
@@ -84,11 +89,11 @@ USA.
 \f
 (define-test 'contravariant-ordering
   (lambda ()
-    (let* ((template (make-predicate-template 'foo '((? a -))))
-           (instantiator (predicate-template-instantiator template)))
-      (let ((p1 (instantiator (disjoin string? symbol?)))
-            (p2 (instantiator string?))
-            (p3 (instantiator symbol?)))
+    (let* ((template (make-template 'foo '((? a -))))
+           (constructor (predicate-template-constructor template)))
+      (let ((p1 (constructor (disjoin string? symbol?)))
+            (p2 (constructor string?))
+            (p3 (constructor symbol?)))
 
         (assert-true (predicate<= p1 p1))
         (assert-true (predicate<= p1 p2))
@@ -106,13 +111,13 @@ USA.
 
 (define-test 'mixed-ordering
   (lambda ()
-    (let* ((template (make-predicate-template 'foo '((? a -) (? b))))
-           (instantiator (predicate-template-instantiator template)))
-      (let ((p1 (instantiator (disjoin string? symbol?)
-                              (disjoin string? symbol?)))
-            (p2 (instantiator string? string?))
-            (p3 (instantiator string? (disjoin string? symbol?)))
-            (p4 (instantiator (disjoin string? symbol?) string?)))
+    (let* ((template (make-template 'foo '((? a -) (? b))))
+           (constructor (predicate-template-constructor template)))
+      (let ((p1 (constructor (disjoin string? symbol?)
+                            (disjoin string? symbol?)))
+            (p2 (constructor string? string?))
+            (p3 (constructor string? (disjoin string? symbol?)))
+            (p4 (constructor (disjoin string? symbol?) string?)))
 
         (for-each (lambda (predicate)
                     (assert-true (predicate<= predicate predicate)))
@@ -237,7 +242,8 @@ USA.
    (parametric-predicate-template predicate)))
 
 (define (match-numbers pattern values)
-  (parameter-bindings->alist (match-template-pattern pattern values number?)))
+  (parameter-bindings->alist
+   (match-template-pattern pattern values number? 'match-numbers)))
 
 (define (parameter-bindings->alist bindings)
   (map (lambda (binding)