From 45886666e03aecdd2af308b76df38f2a033b99d7 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 5 Jan 2017 19:13:29 -0800
Subject: [PATCH] Implement predicate lattice support.

---
 src/runtime/make.scm              |   1 +
 src/runtime/predicate-lattice.scm | 116 ++++++++++++++++++++++++++++++
 src/runtime/runtime.pkg           |  13 ++++
 3 files changed, 130 insertions(+)
 create mode 100644 src/runtime/predicate-lattice.scm

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index ace2e4125..67cd24b2e 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -451,6 +451,7 @@ USA.
    (RUNTIME HASH-TABLE)
    ((RUNTIME TAGGING) INITIALIZE-UNPARSER!)
    (RUNTIME PREDICATE-METADATA)
+   (RUNTIME PREDICATE-LATTICE)
    (RUNTIME HASH)
    (RUNTIME DYNAMIC)
    (RUNTIME REGULAR-SEXPRESSION)
diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
new file mode 100644
index 000000000..6840d334a
--- /dev/null
+++ b/src/runtime/predicate-lattice.scm
@@ -0,0 +1,116 @@
+#| -*-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)
+  (tag<= (predicate->tag predicate1)
+         (predicate->tag predicate2)))
+
+(define (predicate>= predicate1 predicate2)
+  (predicate<= predicate2 predicate1))
+
+(define (tag= tag1 tag2)
+  (guarantee tag? tag1 'tag=)
+  (guarantee tag? tag2 'tag=)
+  (eq? tag1 tag2))
+
+(define (tag<= tag1 tag2)
+  (guarantee tag? tag1 'tag<=)
+  (guarantee tag? tag2 'tag<=)
+  (cached-tag<= tag1 tag2))
+
+(define (tag>= tag1 tag2)
+  (tag<= tag2 tag1))
+
+(define (cached-tag<= tag1 tag2)
+  (hash-table-intern! tag<=-cache
+		      (cons tag1 tag2)
+		      (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))))
+
+(define (metadata-event! operator tag . rest)
+  (if (and (eq? operator 'set-tag<=!)
+           (pair? rest))
+      (let ((superset (car rest)))
+        (if (tag<= tag superset)
+            (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 (non-top-tag? object) (not (top-tag? object)))
+(define (non-bottom-tag? object) (not (bottom-tag? object)))
+
+(define tag<=-cache)
+(define tag<=-overrides)
+(define (initialize-package!)
+  (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
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 87b6b7417..f602bf218 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1779,6 +1779,19 @@ USA.
 	  top-tag?)
   (initialization (initialize-package!)))
 
+(define-package (runtime predicate-lattice)
+  (files "predicate-lattice")
+  (parent (runtime))
+  (export ()
+	  predicate<=
+	  predicate>=)
+  (export (runtime)
+	  define-tag<=
+	  tag<=
+	  tag=
+	  tag>=)
+  (initialization (initialize-package!)))
+
 (define-package (runtime environment)
   (files "uenvir")
   (parent (runtime))
-- 
2.25.1