From 50af40544121a1ea7b4a9d0932032b5d9a9dd0a2 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 21 Jan 2018 15:40:16 -0800
Subject: [PATCH] Push yet more predicate machinery into boot.

---
 src/runtime/boot.scm      | 21 ++++++++++++++++++---
 src/runtime/gentag.scm    | 12 ++----------
 src/runtime/predicate.scm | 16 ++++++++--------
 src/runtime/runtime.pkg   | 11 +++++++----
 4 files changed, 35 insertions(+), 25 deletions(-)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 389501167..0a36e5200 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -364,10 +364,16 @@ USA.
 
 (define predicate?)
 (define register-predicate!)
-(let ((predicates '()))
+(define predicate->dispatch-tag)
+(define set-predicate-tag!)
+(let ((predicates '())
+      (associations '()))
   (set! predicate?
 	(lambda (object)
-	  (if (memq object predicates) #t #f)))
+	  (if (or (memq object predicates)
+		  (assq object associations))
+	      #t
+	      #f)))
   (set! register-predicate!
 	(lambda (predicate name . keylist)
 	  (defer-boot-action 'predicate-registrations
@@ -375,6 +381,15 @@ USA.
 	      (apply register-predicate! predicate name keylist)))
 	  (set! predicates (cons predicate predicates))
 	  unspecific))
+  (set! predicate->dispatch-tag
+	(lambda (predicate)
+	  (cdr (assq predicate associations))))
+  (set! set-predicate-tag!
+	(lambda (predicate tag)
+	  (set! associations (cons (cons predicate tag) associations))
+	  (defer-boot-action 'set-predicate-tag!
+	    (lambda ()
+	      (set-predicate-tag! predicate tag)))))
   unspecific)
 
 (define (set-dispatch-tag<=! t1 t2)
@@ -413,7 +428,7 @@ USA.
 	(lambda (port)
 	  (write-string "object satisfying " port)
 	  (write predicate port)))))
-
+
 ;;;; Miscellany
 
 (define (object-constant? object)
diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm
index 4c70c25a3..fbfc11c52 100644
--- a/src/runtime/gentag.scm
+++ b/src/runtime/gentag.scm
@@ -62,11 +62,6 @@ USA.
 		  (cdr object)))))
 (register-predicate! tag-name? 'dispatch-tag-name)
 
-(define (set-predicate-tag! predicate tag)
-  (defer-boot-action 'set-predicate-tag!
-    (lambda ()
-      (set-predicate-tag! predicate tag))))
-
 (define (dispatch-tag? object)
   (and (%record? object)
        (dispatch-metatag? (%record-ref object 0))))
@@ -126,13 +121,14 @@ USA.
 (define (dispatch-metatag? object)
   (and (%record? object)
        (eq? metatag-tag (%record-ref object 0))))
+(set-predicate<=! dispatch-metatag? dispatch-tag?)
 
 (define metatag-tag)
 (add-boot-init!
  (lambda ()
    (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '#()))
    (%record-set! metatag-tag 0 metatag-tag)))
-
+
 (define (dispatch-tag-metatag tag)
   (guarantee dispatch-tag? tag 'dispatch-tag-metatag)
   (%record-ref tag 0))
@@ -158,10 +154,6 @@ USA.
   (guarantee dispatch-tag? superset 'add-dispatch-tag-superset)
   (%add-to-weak-set superset (%tag-supersets tag)))
 
-(defer-boot-action 'predicate-relations
-  (lambda ()
-    (set-predicate<=! dispatch-metatag? dispatch-tag?)))
-
 (define-unparser-method dispatch-tag?
   (simple-unparser-method
    (lambda (tag)
diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 89279ce85..39243921d 100644
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -29,12 +29,6 @@ USA.
 
 (declare (usual-integrations))
 
-(define (predicate->dispatch-tag predicate)
-  (let ((tag (get-predicate-tag predicate #f)))
-    (if (not tag)
-        (error:not-a predicate? predicate))
-    tag))
-
 (define (predicate-name predicate)
   (dispatch-tag-name (predicate->dispatch-tag predicate)))
 
@@ -120,8 +114,14 @@ USA.
    (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! set-predicate-tag! (table 'put!)))
+   (set! predicate->dispatch-tag
+	 (named-lambda (predicate->dispatch-tag predicate)
+	   (let ((tag (get-predicate-tag predicate #f)))
+	     (if (not tag)
+		 (error:not-a predicate? predicate))
+	     tag)))
+   (run-deferred-boot-actions 'set-predicate-tag!)
    (set! register-predicate!
 	 (let ((make-simple-tag
 		(dispatch-metatag-constructor
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 13b66f32f..cb7b10add 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -178,6 +178,7 @@ USA.
 	  interrupt-mask/timer-ok
 	  object-constant?
 	  object-pure?
+	  predicate->dispatch-tag
 	  predicate?
 	  register-predicate!
 	  set-dispatch-tag<=!
@@ -206,8 +207,12 @@ USA.
 	  add-boot-init!
 	  defer-boot-action
 	  run-deferred-boot-actions)
+  (export (runtime predicate)
+	  set-predicate-tag!)
   (export (runtime rep)
-	  finished-booting!))
+	  finished-booting!)
+  (export (runtime tagged-dispatch)
+	  set-predicate-tag!))
 
 (define-package (runtime equality)
   (files "equals")
@@ -1852,7 +1857,6 @@ USA.
 	  dispatch-tag=
 	  dispatch-tag>=
 	  no-object?
-	  predicate->dispatch-tag
 	  predicate-name
 	  predicate<=
 	  predicate>=
@@ -5100,8 +5104,7 @@ USA.
 	  make-dispatch-metatag)
   (export (runtime predicate)
 	  add-dispatch-tag-superset
-	  any-dispatch-tag-superset
-	  set-predicate-tag!))
+	  any-dispatch-tag-superset))
 
 (define-package (runtime crypto)
   (files "crypto")
-- 
2.25.1