From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 28 Jan 2017 23:38:50 +0000 (-0800)
Subject: Upgrade compound-predicate implementation with latest from book.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~37
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0072212ec701cedb56aff8481d1990ac968ed885;p=mit-scheme.git

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 a5edc25bb..183f8f45f 100644
--- 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))))))
+
 (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)
-
 (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)))))
-
-(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))))
 
 (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?))))
-
-(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 18d3f688f..e616c1971 100644
--- 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))))
-
-(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 52e51999b..c1db92604 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -192,32 +192,10 @@ USA.
 
 (define event:predicate-metadata (make-event-distributor))
 
-(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 8ac37293b..531cec085 100644
--- 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")