Push yet more predicate machinery into boot.

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 38950116796d944c24da9fd4abc94541d3262f9e..0a36e5200983f6ddd14f70800d6d1bb2d0efc5fb 100644 (file)
--- 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)))))
-
+\f
 ;;;; Miscellany
 
 (define (object-constant? object)

diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm
index 4c70c25a3f6e40ecabfc731f3ee4b152c718138d..fbfc11c52a4d090c536ef8fdfc543322e43bb155 100644 (file)
--- 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)))
-\f
+
 (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 89279ce8587b0de91cc364725613d36502dc5d27..39243921ddc138dce9c21439f3b71c40554b78db 100644 (file)
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -29,12 +29,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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 13b66f32fba1712bfb812cd12001e34cfef9f08c..cb7b10add70df180d3069416b199d09e8a78f161 100644 (file)
--- 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")