From 8e5c6a3957d0dffbba639e90cf8b47df7f6f6c22 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 Jan 2018 21:10:40 -0800
Subject: [PATCH] Merge predicate-metadata and predicate-lattice into
predicate.
---
src/runtime/make.scm | 3 +-
src/runtime/predicate-lattice.scm | 122 ---------------
.../{predicate-metadata.scm => predicate.scm} | 142 ++++++++++++++----
src/runtime/runtime.pkg | 20 +--
tests/check.scm | 3 +-
tests/runtime/test-predicate-lattice.scm | 39 -----
...dicate-metadata.scm => test-predicate.scm} | 16 +-
7 files changed, 133 insertions(+), 212 deletions(-)
delete mode 100644 src/runtime/predicate-lattice.scm
rename src/runtime/{predicate-metadata.scm => predicate.scm} (67%)
delete mode 100644 tests/runtime/test-predicate-lattice.scm
rename tests/runtime/{test-predicate-metadata.scm => test-predicate.scm} (85%)
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
--
2.25.1