Upgrade compound-predicate implementation with latest from book.

Also clean up the initialization sequence.

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index a5edc25bb64215eaa712634e28908006d325358c..183f8f45f6ee29c970395f8dfb66732faff73152 100644 (file)
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -36,32 +36,14 @@ USA.
            operator
             (make-compound-tag-extra operator operands)))
 
-(define (compound-tag? object)
-  (and (tag? object)
-       (tag-is-compound? object)))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! compound-tag? 'compound-tag '<= tag?)))
-
 (define (tag-is-compound? tag)
-  (or (compound-tag-extra? (tag-extra tag))
-      (top-tag? tag)
-      (bottom-tag? tag)))
+  (compound-tag-extra? (tag-extra tag)))
 
 (define (compound-tag-operator tag)
-  (cond ((compound-tag-extra? (tag-extra tag))
-         (compound-tag-extra-operator (tag-extra tag)))
-        ((top-tag? tag) 'conjoin)
-        ((bottom-tag? tag) 'disjoin)
-        (else (error:not-a compound-tag? tag 'compound-tag-operator))))
+  (compound-tag-extra-operator (tag-extra tag)))
 
 (define (compound-tag-operands tag)
-  (cond ((compound-tag-extra? (tag-extra tag))
-         (compound-tag-extra-operands (tag-extra tag)))
-        ((top-tag? tag) '())
-        ((bottom-tag? tag) '())
-        (else (error:not-a compound-tag? tag 'compound-tag-operands))))
+  (compound-tag-extra-operands (tag-extra tag)))
 
 (define-record-type <compound-tag-extra>
     (make-compound-tag-extra operator operands)
@@ -69,6 +51,29 @@ USA.
   (operator compound-tag-extra-operator)
   (operands compound-tag-extra-operands))
 
+(define (tag-is-disjoin? object)
+  (and (tag-is-compound? object)
+       (eq? 'disjoin (compound-tag-operator object))))
+
+(define (tag-is-conjoin? object)
+  (and (tag-is-compound? object)
+       (eq? 'conjoin (compound-tag-operator object))))
+
+(add-boot-init!
+ (lambda ()
+
+   (define-tag<= tag? tag-is-disjoin?
+     (lambda (tag1 tag2)
+       (any (lambda (component2)
+             (tag<= tag1 component2))
+           (compound-tag-operands tag2))))
+
+   (define-tag<= tag-is-conjoin? tag?
+     (lambda (tag1 tag2)
+       (any (lambda (component1)
+             (tag<= component1 tag2))
+           (compound-tag-operands tag1))))))
+\f
 (define (compound-predicate? object)
   (and (predicate? object)
        (tag-is-compound? (predicate->tag object))))
@@ -84,180 +89,127 @@ USA.
 (define (compound-predicate-operands predicate)
   (map tag->predicate (compound-tag-operands (predicate->tag predicate))))
 
-(define (compound-predicate-predicate operator)
-  (define (predicate object)
-    (and (predicate? object)
-         (let ((tag (predicate->tag object)))
-           (and (tag-is-compound? tag)
-                (eq? operator (compound-tag-operator tag))))))
-  (register-predicate! predicate `(compound-predicate-predicate ,operator)
-                       '<= compound-predicate?)
-  predicate)
-\f
 (define (disjoin . predicates)
   (disjoin* predicates))
 
-(define (unmemoized:disjoin* predicates)
-  (lambda (object)
-    (any (lambda (predicate)
-           (predicate object))
-         predicates)))
+(define (disjoin* predicates)
+  (make-predicate (lambda (object)
+                   (any (lambda (predicate)
+                          (predicate object))
+                        predicates))
+                 'disjoin
+                 predicates))
 
 (define (conjoin . predicates)
   (conjoin* predicates))
 
-(define (unmemoized:conjoin* predicates)
-  (lambda (object)
-    (every (lambda (predicate)
-             (predicate object))
-           predicates)))
-
-(define (unmemoized:is-list-of predicate)
-  (lambda (object)
-    (and (list? object)
-         (every predicate object))))
-
-(define (unmemoized:is-non-empty-list-of predicate)
-  (lambda (object)
-    (and (non-empty-list? object)
-         (every predicate object))))
-
-(define (unmemoized:is-pair-of car-predicate cdr-predicate)
-  (lambda (object)
-    (and (pair? object)
-         (car-predicate (car object))
-         (cdr-predicate (cdr object)))))
-\f
-(define (memoize-uniform-nary operator nullary procedure)
-  (let ((memoizer
-         (lset-memoizer eqv?
-                        (lambda (predicates) predicates)
-                        (lambda (predicates)
-                          (make-predicate (lambda () (procedure predicates))
-                                          operator
-                                          predicates)))))
-    (lambda (predicates)
-      (guarantee list? predicates)
-      (let ((predicates (delete-duplicates predicates eqv?)))
-        (cond ((null? predicates)
-               nullary)
-              ((and (pair? predicates) (null? (cdr predicates)))
-               (car predicates))
-              (else
-               (memoizer predicates)))))))
-
-(define (memoize-unary operator procedure)
-  (weak-eqv-memoizer (lambda (p1) p1)
-                     (lambda (p1)
-                       (make-predicate (lambda () (procedure p1))
-                                       operator
-                                       (list p1)))))
-
-(define (memoize-binary operator procedure)
-  (list-memoizer eqv?
-                 (lambda (p1 p2) (list p1 p2))
-                 (lambda (p1 p2)
-                   (make-predicate (lambda () (procedure p1 p2))
-                                   operator
-                                   (list p1 p2)))))
-
-(define (make-predicate get-predicate operator operands)
+(define (conjoin* predicates)
+  (make-predicate (lambda (object)
+                   (every (lambda (predicate)
+                            (predicate object))
+                          predicates))
+                 '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)
   (tag->predicate
-   (let ((builder (get-compound-operator-builder operator #f))
-         (operand-tags (map predicate->tag operands)))
-     (if (not builder)
-         (error:not-a compound-operator? operator 'make-predicate))
-     (builder (lambda ()
-                (make-compound-tag (get-predicate) operator operand-tags))
-              operator
-              operand-tags))))
+   ((compound-operator-builder operator)
+    datum-test
+    operator
+    (map predicate->tag operands))))
 \f
 (define compound-operator?)
-(define get-compound-operator-builder)
-(define set-compound-operator-builder!)
+(define compound-operator-builder)
+(define define-compound-operator)
 (add-boot-init!
  (lambda ()
    (let ((table (make-hashed-metadata-table)))
      (set! compound-operator? (table 'has?))
-     (set! get-compound-operator-builder (table 'get-if-available))
-     (set! set-compound-operator-builder! (table 'put!))
+     (set! compound-operator-builder (table 'get))
+     (set! define-compound-operator (table 'put!))
      unspecific)
    (register-predicate! compound-operator? 'compound-predicate '<= symbol?)))
 
-(define (define-compound-operator operator builder)
-  (guarantee symbol? operator 'define-compound-operator)
-  (set-compound-operator-builder! operator builder)
-  operator)
-
 (add-boot-init!
  (lambda ()
 
-   (define (builder:uniform-nary builder)
-     (lambda (get-tag operator operand-tags)
-       (let ((operand-tags
-             (append-map (lambda (tag)
-                           (if (and (tag-is-compound? tag)
-                                    (eq? operator (compound-tag-operator tag)))
-                               (compound-tag-operands tag)
-                               (list tag)))
-                         operand-tags)))
-        (if (and (pair? operand-tags) (null? (cdr operand-tags)))
-            (car operand-tags)
-            (builder get-tag operand-tags)))))
+   (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 'disjoin
-     (builder:uniform-nary
-      (lambda (get-tag operand-tags)
-       (if (any top-tag? operand-tags)
-           (top-tag)
-           (let ((tag (get-tag)))
-             (for-each (lambda (tag*)
-                         (set-tag<=! tag* tag))
-                       operand-tags)
-             tag)))))
+   (define-compound-operator 'is-list-of
+     (make-listish-memoizer))
 
-   (define-compound-operator 'conjoin
-     (builder:uniform-nary
-      (lambda (get-tag operand-tags)
-       (if (any bottom-tag? operand-tags)
-           (bottom-tag)
-           (let ((tag (get-tag)))
-             (for-each (lambda (tag*)
-                         (set-tag<=! tag tag*))
-                       operand-tags)
-             tag)))))))
+   (define-compound-operator 'is-non-empty-list-of
+     (make-listish-memoizer))
+
+   (define-compound-operator 'is-pair-of
+     (make-listish-memoizer))))
 
 (add-boot-init!
  (lambda ()
 
-   (define (simple-nary superset)
-     (let ((superset-tag (predicate->tag superset)))
-       (lambda (get-tag operator operand-tags)
-        operator operand-tags
-        (let ((tag (get-tag)))
-          (set-tag<=! tag superset-tag)
-          tag))))
+   (define (make-joinish-memoizer tag-is-limit?)
+     (let ((memoizer
+           (simple-lset-memoizer eq?
+             (lambda (datum-test operator tags)
+               (declare (ignore datum-test operator))
+               tags)
+             make-compound-tag)))
+       (lambda (datum-test operator tags)
+        (let ((tags
+               (delete-duplicates
+                (append-map
+                 (lambda (tag)
+                   (if (and (tag-is-compound? tag)
+                            (eq? operator
+                                 (compound-tag-operator tag)))
+                       (compound-tag-operands tag)
+                       (list tag)))
+                 tags)
+                eq?)))
+          (if (and (pair? tags) (null? (cdr tags)))
+              (car tags)
+              (or (find tag-is-limit? tags)
+                  (memoizer datum-test operator tags)))))))
 
-   (define-compound-operator 'is-list-of (simple-nary list?))
-   (define-compound-operator 'is-non-empty-list-of
-     (simple-nary non-empty-list?))
-   (define-compound-operator 'is-pair-of (simple-nary pair?))))
-\f
-(define disjoin*)
-(define conjoin*)
-(define is-list-of)
-(define is-non-empty-list-of)
-(define is-pair-of)
+   (define-compound-operator 'disjoin
+     (make-joinish-memoizer tag-is-top?))
+
+   (define-compound-operator 'conjoin
+     (make-joinish-memoizer tag-is-bottom?))))
+
+(define any-object?)
+(define no-object?)
 (add-boot-init!
  (lambda ()
-   (set! disjoin*
-        (memoize-uniform-nary 'disjoin no-object? unmemoized:disjoin*))
-   (set! conjoin*
-        (memoize-uniform-nary 'conjoin any-object? unmemoized:conjoin*))
-   (set! is-list-of
-        (memoize-unary 'is-list-of unmemoized:is-list-of))
-   (set! is-non-empty-list-of
-        (memoize-unary 'is-list-of unmemoized:is-non-empty-list-of))
-   (set! is-pair-of
-        (memoize-binary 'is-pair-of unmemoized:is-pair-of))
+   (set! any-object? (conjoin))
+   (set! no-object? (disjoin))
+   (set! the-top-tag (predicate->tag any-object?))
+   (set! the-bottom-tag (predicate->tag no-object?))
    unspecific))
\ No newline at end of file

diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index 18d3f688f6a573a58914dc427d4d79498636c418..e616c1971ffbbd4faeecf9ee51cea8163d1a7ea5 100644 (file)
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -55,11 +55,47 @@ USA.
                      (lambda () (uncached-tag<= tag1 tag2))))
 
 (define (uncached-tag<= tag1 tag2)
-  (or (eqv? tag1 tag2)
-      ((get-override-handler tag1 tag2) tag1 tag2)
-      (any (lambda (tag)
-             (cached-tag<= tag tag2))
-           (get-tag-supersets tag1))))
+  (or (eq? tag1 tag2)
+      (tag-is-bottom? tag1)
+      (tag-is-top? tag2)
+      (and (not (tag-is-top? tag1))
+          (not (tag-is-bottom? tag2))
+          (let ((v
+                 (find (lambda (v)
+                         (and ((vector-ref v 0) tag1)
+                              ((vector-ref v 1) tag2)))
+                       tag<=-overrides)))
+            (if v
+                ((vector-ref v 2) tag1 tag2)
+                (any (lambda (tag)
+                       (cached-tag<= tag tag2))
+                     (get-tag-supersets tag1)))))))
+
+(define (define-tag<= test1 test2 handler)
+  (set! tag<=-overrides
+       (cons (vector test1 test2 handler)
+             tag<=-overrides))
+  unspecific)
+
+(define (top-tag) the-top-tag)
+(define (bottom-tag) the-bottom-tag)
+
+(define-integrable (tag-is-top? tag) (eq? the-top-tag tag))
+(define-integrable (tag-is-bottom? tag) (eq? the-bottom-tag tag))
+
+;; These definitions will be overwritten when the tags are created:
+(define the-top-tag #f)
+(define the-bottom-tag #f)
+
+(define tag<=-cache)
+(define tag<=-overrides)
+(add-boot-init!
+ (lambda ()
+   ;; TODO(cph): should be a weak-key table, but we don't have tables that have
+   ;; weak compound keys.
+   (set! tag<=-cache (make-equal-hash-table))
+   (set! tag<=-overrides '())
+   (add-event-receiver! event:predicate-metadata metadata-event!)))
 
 (define (metadata-event! operator tag . rest)
   (if (and (eq? operator 'set-tag<=!)
@@ -69,46 +105,4 @@ USA.
             (error "Tag already has this superset:" tag superset))
         (if (tag>= tag superset)
             (error "Not allowed to create a superset loop:" tag superset))))
-  (hash-table-clear! tag<=-cache))
-
-(define (get-override-handler tag1 tag2)
-  (let ((p
-        (find (lambda (p)
-                (and ((caar p) tag1)
-                     ((cdar p) tag2)))
-              tag<=-overrides)))
-    (if p
-       (cdr p)
-       false-tag<=)))
-
-(define (define-tag<= predicate1 predicate2 handler)
-  (let ((p
-        (find (lambda (p)
-                (and (eqv? (caar p) predicate1)
-                     (eqv? (cdar p) predicate2)))
-              tag<=-overrides)))
-    (if p
-       (if (not (eqv? (cdr p) handler))
-           (error "Can't redefine tag<= override:" predicate1 predicate2))
-       (begin
-         (set! tag<=-overrides
-               (cons (cons (cons predicate1 predicate2) handler)
-                     tag<=-overrides))
-         unspecific))))
-\f
-(define (false-tag<= tag1 tag2) tag1 tag2 #f)
-(define (true-tag<= tag1 tag2) tag1 tag2 #t)
-
-(define tag<=-cache)
-(define tag<=-overrides)
-(add-boot-init!
- (lambda ()
-   (set! tag<=-cache (make-equal-hash-table))
-   (set! tag<=-overrides '())
-   (add-event-receiver! event:predicate-metadata metadata-event!)
-
-   (define-tag<= bottom-tag? tag? true-tag<=)
-   (define-tag<= tag? top-tag? true-tag<=)
-
-   (define-tag<= non-bottom-tag? bottom-tag? false-tag<=)
-   (define-tag<= top-tag? non-top-tag? false-tag<=)))
\ No newline at end of file
+  (hash-table-clear! tag<=-cache))
\ No newline at end of file

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 52e51999b75489c8ba67e81538a8c5eb0ef1c952..c1db926046f0c30a2043e4a6350f984ba9c3797a 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -192,32 +192,10 @@ USA.
 
 (define event:predicate-metadata (make-event-distributor))
 \f
-(define the-top-tag)
-(define the-bottom-tag)
 (add-boot-init!
  (lambda ()
    (register-predicate! predicate? 'predicate)
    (register-predicate! tag-name? 'tag-name)
-   (register-predicate! any-object? '(conjoin) 'description "any object")
-   (register-predicate! no-object? '(disjoin) 'description "no object")
-
-   (set! the-top-tag (predicate->tag any-object?))
-   (set! the-bottom-tag (predicate->tag no-object?))
-   unspecific))
-
-(define (top-tag) the-top-tag)
-(define (top-tag? object) (eqv? the-top-tag object))
-(define (non-top-tag? object) (not (top-tag? object)))
-
-(define (bottom-tag) the-bottom-tag)
-(define (bottom-tag? object) (eqv? the-bottom-tag object))
-(define (non-bottom-tag? object) (not (bottom-tag? object)))
-
-(define (any-object? object) object #t)
-(define (no-object? object) object #f)
-
-(add-boot-init!
- (lambda ()
    (register-predicate! %record? '%record)
    (register-predicate! record? 'record '<= %record?)
    (cleanup-boot-time-record-predicates!)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8ac37293b18336c12b4317f6ed43ca7b2a3ff6a8..531cec0855117bfcd49d374e9e8f3d1c7954fd27 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1883,12 +1883,10 @@ USA.
   (files "predicate-metadata")
   (parent (runtime))
   (export ()
-         any-object?
          error:not-a
          error:not-a-list-of
          guarantee
          guarantee-list-of
-         no-object?
          predicate-description
          predicate-name
          predicate-tagger
@@ -1899,15 +1897,11 @@ USA.
          set-predicate<=!
          unregister-predicate!)
   (export (runtime)
-         bottom-tag
-         bottom-tag?
          delete-tag!
          event:predicate-metadata
          get-tag-subsets
          get-tag-supersets
          make-tag
-         non-bottom-tag?
-         non-top-tag?
          predicate->tag
          set-tag<=!
          tag->predicate
@@ -1917,9 +1911,7 @@ USA.
          tag-tagger
          tag-tagging-strategy
          tag-untagger
-         tag?
-         top-tag
-         top-tag?))
+         tag?))
 
 (define-package (runtime predicate-lattice)
   (files "predicate-lattice")
@@ -1928,18 +1920,25 @@ USA.
          predicate<=
          predicate>=)
   (export (runtime)
+         bottom-tag
          define-tag<=
+         tag-is-bottom?
+         tag-is-top?
          tag<=
          tag=
-         tag>=))
+         tag>=
+         top-tag)
+  (export (runtime compound-predicate)
+         the-bottom-tag
+         the-top-tag))
 
 (define-package (runtime compound-predicate)
   (files "compound-predicate")
   (parent (runtime))
   (export ()
+         any-object?
          compound-predicate-operands
          compound-predicate-operator
-         compound-predicate-predicate
          compound-predicate?
          conjoin
          conjoin*
@@ -1947,7 +1946,12 @@ USA.
          disjoin*
          is-list-of
          is-non-empty-list-of
-         is-pair-of))
+         is-pair-of
+         no-object?)
+  (export (runtime)
+         compound-tag-operands
+         compound-tag-operator
+         tag-is-compound?))
 
 (define-package (runtime parametric-predicate)
   (files "parametric-predicate")
@@ -1968,7 +1972,11 @@ USA.
           predicate-template-parameter-names
           predicate-template-pattern
           predicate-template-predicate
-          predicate-template?))
+          predicate-template?)
+  (export (runtime)
+         parametric-tag-bindings
+         parametric-tag-template
+         tag-is-parametric?))
 
 (define-package (runtime predicate-tagging)
   (files "predicate-tagging")