Move set-{dispatch-tag,predicate}<=! into boot for use in cold load.

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index d8f30aeb387df5c6753ead9fdd03bc1660d6b702..38950116796d944c24da9fd4abc94541d3262f9e 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -377,6 +377,16 @@ USA.
          unspecific))
   unspecific)
 
+(define (set-dispatch-tag<=! t1 t2)
+  (defer-boot-action 'predicate-relations
+    (lambda ()
+      (set-dispatch-tag<=! t1 t2))))
+
+(define (set-predicate<=! p1 p2)
+  (defer-boot-action 'predicate-relations
+    (lambda ()
+      (set-predicate<=! p1 p2))))
+
 (define (guarantee predicate object #!optional caller)
   (if (predicate object)
       object

diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm
index 2826b78ea48f2f8e6b0c2d4938374aa6be82dce5..4c70c25a3f6e40ecabfc731f3ee4b152c718138d 100644 (file)
--- a/src/runtime/gentag.scm
+++ b/src/runtime/gentag.scm
@@ -132,11 +132,6 @@ USA.
  (lambda ()
    (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '#()))
    (%record-set! metatag-tag 0 metatag-tag)))
-
-(define (set-dispatch-tag<=! t1 t2)
-  (defer-boot-action 'predicate-relations
-    (lambda ()
-      (set-dispatch-tag<=! t1 t2))))
 \f
 (define (dispatch-tag-metatag tag)
   (guarantee dispatch-tag? tag 'dispatch-tag-metatag)

diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index c38ee3a27c4e6a0db9c581239922bd63c048f1ea..67acfd01e27ec9f04798cd0cfbdd752263224bac 100644 (file)
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -36,10 +36,6 @@ USA.
 (define (predicate>= predicate1 predicate2)
   (predicate<= predicate2 predicate1))
 
-(define (set-predicate<=! predicate superset)
-  (set-dispatch-tag<=! (predicate->dispatch-tag predicate 'set-predicate<=!)
-                      (predicate->dispatch-tag superset 'set-predicate<=!)))
-
 (define (dispatch-tag= tag1 tag2)
   (guarantee dispatch-tag? tag1 'dispatch-tag=)
   (guarantee dispatch-tag? tag2 'dispatch-tag=)
@@ -119,4 +115,8 @@ USA.
           (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-metadata.scm
index a97e56bf5e2e84382bb004c08a7f1c995cdff994..8e90f50343c94a8e7d562e0ddcca8a8ac12a01d8 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -39,12 +39,12 @@ USA.
      (run-deferred-boot-actions 'set-predicate-tag!))))
 
 (define (predicate-name predicate)
-  (dispatch-tag-name (predicate->dispatch-tag predicate 'predicate-name)))
+  (dispatch-tag-name (predicate->dispatch-tag predicate)))
 
-(define (predicate->dispatch-tag predicate #!optional caller)
+(define (predicate->dispatch-tag predicate)
   (let ((tag (get-predicate-tag predicate #f)))
     (if (not tag)
-        (error:not-a predicate? predicate caller))
+        (error:not-a predicate? predicate))
     tag))
 
 (define simple-tag-metatag)

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index eec437270cb64c9217cb52e24e8d9362ca641d8a..36065a19b9179b2a0205da82d079b97da8a70e56 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -44,7 +44,7 @@ USA.
       object))
 
 (define (predicate-tagger predicate)
-  (%tag-tagger (predicate->dispatch-tag predicate 'predicate-tagger) predicate))
+  (%tag-tagger (predicate->dispatch-tag predicate) predicate))
 
 (define (dispatch-tag-tagger tag)
   (%tag-tagger tag (dispatch-tag->predicate tag)))

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index c9c3e29d3e29b31e4c26776585ef366c5d4ab276..e90f897e7780365a88818ae3269a150821ce70c3 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -74,6 +74,7 @@ USA.
                               (if (default-object? default-inits)
                                   (vector-cons n #f)
                                   (list->vector default-inits)))))
+       (set-predicate<=! predicate record?)
        (if (and unparser-method
                 (not (default-object? unparser-method)))
            (define-unparser-method predicate unparser-method))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 36928f0dee19d656e4e8419495e4330d1b31581b..a04b90f3ca5ecda839393648516f2a538f110a3a 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -180,6 +180,8 @@ USA.
          object-pure?
          predicate?
          register-predicate!
+         set-dispatch-tag<=!
+         set-predicate<=!
          simple-parser-method
          simple-unparser-method
          standard-unparser-method
@@ -1859,7 +1861,6 @@ USA.
          no-object?
          predicate<=
          predicate>=
-         set-predicate<=!
          top-dispatch-tag)
   (export (runtime)
          define-dispatch-tag<=))
@@ -5105,8 +5106,7 @@ USA.
          dispatch-tag-metatag
          dispatch-tag-name
          dispatch-tag?
-         make-dispatch-metatag
-         set-dispatch-tag<=!)
+         make-dispatch-metatag)
   (export (runtime predicate-lattice)
          add-dispatch-tag-superset
          any-dispatch-tag-superset)