From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 18 Jan 2018 05:10:40 +0000 (-0800)
Subject: Merge predicate-metadata and predicate-lattice into predicate.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~343
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8e5c6a3957d0dffbba639e90cf8b47df7f6f6c22;p=mit-scheme.git

Merge predicate-metadata and predicate-lattice into predicate.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 8ca7a27ab..153c8f6a4 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -471,8 +471,7 @@ USA.
    (RUNTIME UCD-TABLES)
    (RUNTIME UCD-GLUE)
    (RUNTIME BLOWFISH)
-   (RUNTIME PREDICATE-METADATA)
-   (RUNTIME PREDICATE-LATTICE)
+   (RUNTIME PREDICATE)
    (RUNTIME PREDICATE-TAGGING)
    (RUNTIME PREDICATE-DISPATCH)
    (RUNTIME COMPOUND-PREDICATE)
diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
deleted file mode 100644
index 67acfd01e..000000000
--- a/src/runtime/predicate-lattice.scm
+++ /dev/null
@@ -1,122 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
-    2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Predicates: lattice
-;;; package: (runtime predicate-lattice)
-
-(declare (usual-integrations))
-
-(define (predicate<= predicate1 predicate2)
-  (dispatch-tag<= (predicate->dispatch-tag predicate1)
-		  (predicate->dispatch-tag predicate2)))
-
-(define (predicate>= predicate1 predicate2)
-  (predicate<= predicate2 predicate1))
-
-(define (dispatch-tag= tag1 tag2)
-  (guarantee dispatch-tag? tag1 'dispatch-tag=)
-  (guarantee dispatch-tag? tag2 'dispatch-tag=)
-  (eq? tag1 tag2))
-
-(define (dispatch-tag<= tag1 tag2)
-  (guarantee dispatch-tag? tag1 'dispatch-tag<=)
-  (guarantee dispatch-tag? tag2 'dispatch-tag<=)
-  (cached-dispatch-tag<= tag1 tag2))
-
-(define (dispatch-tag>= tag1 tag2)
-  (dispatch-tag<= tag2 tag1))
-
-(define (cached-dispatch-tag<= tag1 tag2)
-  (hash-table-intern! dispatch-tag<=-cache
-		      (cons tag1 tag2)
-		      (lambda () (uncached-dispatch-tag<= tag1 tag2))))
-
-(define (uncached-dispatch-tag<= tag1 tag2)
-  (or (eq? tag1 tag2)
-      (dispatch-tag-is-bottom? tag1)
-      (dispatch-tag-is-top? tag2)
-      (and (not (dispatch-tag-is-top? tag1))
-	   (not (dispatch-tag-is-bottom? tag2))
-	   (let ((v
-		  (find (lambda (v)
-			  (and ((vector-ref v 0) tag1)
-			       ((vector-ref v 1) tag2)))
-			dispatch-tag<=-overrides)))
-	     (if v
-		 ((vector-ref v 2) tag1 tag2)
-		 (any-dispatch-tag-superset (lambda (tag)
-					      (cached-dispatch-tag<= tag tag2))
-					    tag1))))))
-
-(define (define-dispatch-tag<= test1 test2 handler)
-  (set! dispatch-tag<=-overrides
-	(cons (vector test1 test2 handler)
-	      dispatch-tag<=-overrides))
-  unspecific)
-
-(define (any-object? object)
-  (declare (ignore object))
-  #t)
-
-(define (no-object? object)
-  (declare (ignore object))
-  #f)
-
-(define (top-dispatch-tag) the-top-dispatch-tag)
-(define (bottom-dispatch-tag) the-bottom-dispatch-tag)
-
-(define-integrable (dispatch-tag-is-top? tag)
-  (eq? the-top-dispatch-tag tag))
-
-(define-integrable (dispatch-tag-is-bottom? tag)
-  (eq? the-bottom-dispatch-tag tag))
-
-(define-deferred the-top-dispatch-tag
-  (make-compound-tag any-object? 'conjoin '()))
-
-(define-deferred the-bottom-dispatch-tag
-  (make-compound-tag no-object? 'disjoin '()))
-
-(define dispatch-tag<=-cache)
-(define dispatch-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! dispatch-tag<=-cache (make-equal-hash-table))
-   (set! dispatch-tag<=-overrides '())
-   (set! set-dispatch-tag<=!
-	 (named-lambda (set-dispatch-tag<=! tag superset)
-	   (if (not (add-dispatch-tag-superset tag superset))
-	       (error "Tag already has this superset:" tag superset))
-	   (if (dispatch-tag>= tag superset)
-	       (error "Not allowed to create a superset loop:" tag superset))
-	   (hash-table-clear! dispatch-tag<=-cache)))
-   (set! set-predicate<=!
-	 (named-lambda (set-predicate<=! predicate superset)
-	   (set-dispatch-tag<=! (predicate->dispatch-tag predicate)
-				(predicate->dispatch-tag superset))))
-   (run-deferred-boot-actions 'predicate-relations)))
\ No newline at end of file
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate.scm
similarity index 67%
rename from src/runtime/predicate-metadata.scm
rename to src/runtime/predicate.scm
index 8e90f5034..028e140c0 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate.scm
@@ -24,48 +24,127 @@ USA.
 
 |#
 
-;;;; Predicates: metadata
-;;; package: (runtime predicate-metadata)
+;;;; Predicates
+;;; package: (runtime predicate)
 
 (declare (usual-integrations))
 
-(define get-predicate-tag)
-(add-boot-init!
- (lambda ()
-   (let ((table (make-hashed-metadata-table)))
-     (set! predicate? (table 'has?))
-     (set! get-predicate-tag (table 'get))
-     (set! set-predicate-tag! (table 'put!))
-     (run-deferred-boot-actions 'set-predicate-tag!))))
-
-(define (predicate-name predicate)
-  (dispatch-tag-name (predicate->dispatch-tag predicate)))
-
 (define (predicate->dispatch-tag predicate)
   (let ((tag (get-predicate-tag predicate #f)))
     (if (not tag)
         (error:not-a predicate? predicate))
     tag))
 
-(define simple-tag-metatag)
-(define %make-simple-tag)
+(define (predicate-name predicate)
+  (dispatch-tag-name (predicate->dispatch-tag predicate)))
+
+(define (predicate<= predicate1 predicate2)
+  (dispatch-tag<= (predicate->dispatch-tag predicate1)
+		  (predicate->dispatch-tag predicate2)))
+
+(define (predicate>= predicate1 predicate2)
+  (predicate<= predicate2 predicate1))
+
+(define (dispatch-tag= tag1 tag2)
+  (guarantee dispatch-tag? tag1 'dispatch-tag=)
+  (guarantee dispatch-tag? tag2 'dispatch-tag=)
+  (eq? tag1 tag2))
+
+(define (dispatch-tag<= tag1 tag2)
+  (guarantee dispatch-tag? tag1 'dispatch-tag<=)
+  (guarantee dispatch-tag? tag2 'dispatch-tag<=)
+  (cached-dispatch-tag<= tag1 tag2))
+
+(define (dispatch-tag>= tag1 tag2)
+  (dispatch-tag<= tag2 tag1))
+
+(define (cached-dispatch-tag<= tag1 tag2)
+  (hash-table-intern! dispatch-tag<=-cache
+		      (cons tag1 tag2)
+		      (lambda () (uncached-dispatch-tag<= tag1 tag2))))
+
+(define (uncached-dispatch-tag<= tag1 tag2)
+  (or (eq? tag1 tag2)
+      (dispatch-tag-is-bottom? tag1)
+      (dispatch-tag-is-top? tag2)
+      (and (not (dispatch-tag-is-top? tag1))
+	   (not (dispatch-tag-is-bottom? tag2))
+	   (let ((v
+		  (find (lambda (v)
+			  (and ((vector-ref v 0) tag1)
+			       ((vector-ref v 1) tag2)))
+			dispatch-tag<=-overrides)))
+	     (if v
+		 ((vector-ref v 2) tag1 tag2)
+		 (any-dispatch-tag-superset (lambda (tag)
+					      (cached-dispatch-tag<= tag tag2))
+					    tag1))))))
+
+(define (define-dispatch-tag<= test1 test2 handler)
+  (set! dispatch-tag<=-overrides
+	(cons (vector test1 test2 handler)
+	      dispatch-tag<=-overrides))
+  unspecific)
+
+;; TODO(cph): should be a weak-key table, but we don't have tables that have
+;; weak compound keys.
+(define-deferred dispatch-tag<=-cache (make-equal-hash-table))
+(define dispatch-tag<=-overrides '())
+
+(define (any-object? object)
+  (declare (ignore object))
+  #t)
+
+(define (no-object? object)
+  (declare (ignore object))
+  #f)
+
+(define (top-dispatch-tag) the-top-dispatch-tag)
+(define (bottom-dispatch-tag) the-bottom-dispatch-tag)
+
+(define-integrable (dispatch-tag-is-top? tag)
+  (eq? the-top-dispatch-tag tag))
+
+(define-integrable (dispatch-tag-is-bottom? tag)
+  (eq? the-bottom-dispatch-tag tag))
+
+(define-deferred the-top-dispatch-tag
+  (make-compound-tag any-object? 'conjoin '()))
+
+(define-deferred the-bottom-dispatch-tag
+  (make-compound-tag no-object? 'disjoin '()))
+
+(define get-predicate-tag)
 (add-boot-init!
  (lambda ()
-   (set! simple-tag-metatag
-	 (make-dispatch-metatag 'simple-tag))
-   (set! %make-simple-tag
-	 (dispatch-metatag-constructor simple-tag-metatag 'register-predicate!))
-   (run-deferred-boot-actions 'make-dispatch-metatag)
+   (let ((table (make-hashed-metadata-table)))
+     (set! predicate? (table 'has?))
+     (set! get-predicate-tag (table 'get))
+     (set! set-predicate-tag! (table 'put!))
+     (run-deferred-boot-actions 'set-predicate-tag!))
    (set! register-predicate!
-	 (named-lambda (register-predicate! predicate name . keylist)
-	   (guarantee keyword-list? keylist 'register-predicate!)
-	   (let ((tag (%make-simple-tag name predicate #f)))
-	     (for-each (lambda (superset)
-			 (set-dispatch-tag<=!
-			  tag
-			  (predicate->dispatch-tag superset)))
-		       (get-keyword-values keylist '<=))
-	     tag)))
+	 (let ((make-simple-tag
+		(dispatch-metatag-constructor
+		 (make-dispatch-metatag 'simple-tag)
+		 'register-predicate!)))
+	   (named-lambda (register-predicate! predicate name . keylist)
+	     (guarantee keyword-list? keylist 'register-predicate!)
+	     (let ((tag (make-simple-tag name predicate)))
+	       (for-each (lambda (superset)
+			   (set-predicate<=! predicate superset))
+			 (get-keyword-values keylist '<=))
+	       tag))))
+   (set! set-dispatch-tag<=!
+	 (named-lambda (set-dispatch-tag<=! tag superset)
+	   (if (not (add-dispatch-tag-superset tag superset))
+	       (error "Tag already has this superset:" tag superset))
+	   (if (dispatch-tag>= tag superset)
+	       (error "Not allowed to create a superset loop:" tag superset))
+	   (hash-table-clear! dispatch-tag<=-cache)))
+   (set! set-predicate<=!
+	 (named-lambda (set-predicate<=! predicate superset)
+	   (set-dispatch-tag<=! (predicate->dispatch-tag predicate)
+				(predicate->dispatch-tag superset))))
    unspecific))
 
 (add-boot-init!
@@ -198,4 +277,5 @@ USA.
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)
 
-   (run-deferred-boot-actions 'predicate-registrations)))
\ No newline at end of file
+   (run-deferred-boot-actions 'predicate-registrations)
+   (run-deferred-boot-actions 'predicate-relations)))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a04b90f3c..1b4d2bbbd 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1840,15 +1840,8 @@ USA.
   (export (runtime predicate-tagging)
 	  %entity-is-apply-hook?))
 
-(define-package (runtime predicate-metadata)
-  (files "predicate-metadata")
-  (parent (runtime))
-  (export ()
-	  predicate->dispatch-tag
-	  predicate-name))
-
-(define-package (runtime predicate-lattice)
-  (files "predicate-lattice")
+(define-package (runtime predicate)
+  (files "predicate")
   (parent (runtime))
   (export ()
 	  any-object?
@@ -1859,6 +1852,8 @@ USA.
 	  dispatch-tag=
 	  dispatch-tag>=
 	  no-object?
+	  predicate->dispatch-tag
+	  predicate-name
 	  predicate<=
 	  predicate>=
 	  top-dispatch-tag)
@@ -1873,7 +1868,7 @@ USA.
 	  conjoin*
 	  disjoin
 	  disjoin*)
-  (export (runtime predicate-lattice)
+  (export (runtime predicate)
 	  make-compound-tag))
 
 (define-package (runtime parametric-predicate)
@@ -5107,10 +5102,9 @@ USA.
 	  dispatch-tag-name
 	  dispatch-tag?
 	  make-dispatch-metatag)
-  (export (runtime predicate-lattice)
+  (export (runtime predicate)
 	  add-dispatch-tag-superset
-	  any-dispatch-tag-superset)
-  (export (runtime predicate-metadata)
+	  any-dispatch-tag-superset
 	  set-predicate-tag!))
 
 (define-package (runtime crypto)
diff --git a/tests/check.scm b/tests/check.scm
index 87650c323..2368ad63b 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -66,9 +66,8 @@ USA.
     "runtime/test-md5"
     "runtime/test-mime-codec"
     ("runtime/test-parametric-predicate" (runtime parametric-predicate))
+    "runtime/test-predicate"
     ("runtime/test-predicate-dispatch" (runtime predicate-dispatch))
-    ("runtime/test-predicate-lattice" (runtime))
-    ("runtime/test-predicate-metadata" (runtime))
     "runtime/test-process"
     "runtime/test-readwrite"
     "runtime/test-regsexp"
diff --git a/tests/runtime/test-predicate-lattice.scm b/tests/runtime/test-predicate-lattice.scm
deleted file mode 100644
index d6c27eabb..000000000
--- a/tests/runtime/test-predicate-lattice.scm
+++ /dev/null
@@ -1,39 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
-    2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Tests for predicate lattice
-
-(declare (usual-integrations))
-
-(define-test 'ordering
-  (lambda ()
-    (assert-true (predicate<= no-object? string?))
-    (assert-true (predicate<= no-object? no-object?))
-    (assert-false (predicate<= string? no-object?))
-
-    (assert-false (predicate<= any-object? string?))
-    (assert-true (predicate<= any-object? any-object?))
-    (assert-true (predicate<= string? any-object?))))
\ No newline at end of file
diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate.scm
similarity index 85%
rename from tests/runtime/test-predicate-metadata.scm
rename to tests/runtime/test-predicate.scm
index f4b8ef4be..86102a24e 100644
--- a/tests/runtime/test-predicate-metadata.scm
+++ b/tests/runtime/test-predicate.scm
@@ -24,10 +24,10 @@ USA.
 
 |#
 
-;;;; Tests for predicate metadata
+;;;; Tests for predicates
 
 (declare (usual-integrations))
-
+
 (define-test 'non-predicate
   (lambda ()
     (let ((np (lambda (object) object #f)))
@@ -64,4 +64,14 @@ USA.
 	      data)
     (for-each (lambda (non-datum)
 		(assert-type-error (lambda () (tagger non-datum))))
-	      non-data)))
\ No newline at end of file
+	      non-data)))
+
+(define-test 'ordering
+  (lambda ()
+    (assert-true (predicate<= no-object? string?))
+    (assert-true (predicate<= no-object? no-object?))
+    (assert-false (predicate<= string? no-object?))
+
+    (assert-false (predicate<= any-object? string?))
+    (assert-true (predicate<= any-object? any-object?))
+    (assert-true (predicate<= string? any-object?))))
\ No newline at end of file