Clean up the ad hoc handling of boot-time predicate registrations.

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 28b792d83e88580c57f4ffaf3c65b6930c20970d..1e8757b41408b0a5e8e7000feb2366b8e25dc9ab 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -29,12 +29,13 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (register-mit-bytevector-predicates!)
-  (register-predicate! u8? 'u8 '<= index-fixnum?)
-  (register-predicate! u16? 'u16 '<= index-fixnum?)
-  (register-predicate! u32? 'u32 '<= (if (fix:fixnum? #xFFFFFFFF)
-                                        index-fixnum?
-                                        exact-nonnegative-integer?)))
+(defer-boot-action 'predicate-registrations
+  (lambda ()
+    (register-predicate! u8? 'u8 '<= index-fixnum?)
+    (register-predicate! u16? 'u16 '<= index-fixnum?)
+    (register-predicate! u32? 'u32 '<= (if (fix:fixnum? #xFFFFFFFF)
+                                          index-fixnum?
+                                          exact-nonnegative-integer?))))
 
 (define (u8? object)
   (and (index-fixnum? object)

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 54ccc9cc843aad843e03c7c5583d0550106767eb..f7cc1dcd8e1ed19b3fe5ff3388860e2bf216b0d4 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -29,8 +29,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define boot-registrations '())
-
 (define (predicate? object)
   (any (lambda (reg)
         (eqv? (car reg) object))
@@ -42,6 +40,15 @@ USA.
              boot-registrations))
   unspecific)
 
+(define (run-deferred-predicate-registrations!)
+  (for-each (lambda (reg)
+             (apply register-predicate! reg))
+           (reverse! boot-registrations))
+  (set! boot-registrations)
+  unspecific)
+
+(define boot-registrations '())
+
 (define get-predicate-tag)
 (define set-predicate-tag!)
 (add-boot-init!
@@ -53,19 +60,20 @@ USA.
      (set! register-predicate! register-predicate!/after-boot)
      unspecific)))
 
-(define (register-predicate!/after-boot predicate name . keylist)
-  (guarantee keyword-list? keylist 'register-predicate!)
-  (let ((tag
-         (make-tag name
-                   predicate
-                  predicate-tagging-strategy:never
-                  'register-predicate!
-                   (get-keyword-value keylist 'extra)
-                   (get-keyword-value keylist 'description))))
-    (for-each (lambda (superset)
-               (set-tag<=! tag (predicate->tag superset)))
-             (get-keyword-values keylist '<=))
-    tag))
+(define register-predicate!/after-boot
+  (named-lambda (register-predicate! predicate name . keylist)
+    (guarantee keyword-list? keylist 'register-predicate!)
+    (let ((tag
+          (make-tag name
+                    predicate
+                    predicate-tagging-strategy:never
+                    'register-predicate!
+                    (get-keyword-value keylist 'extra)
+                    (get-keyword-value keylist 'description))))
+      (for-each (lambda (superset)
+                 (set-tag<=! tag (predicate->tag superset)))
+               (get-keyword-values keylist '<=))
+      tag)))
 \f
 (define (predicate-name predicate)
   (tag-name (predicate->tag predicate 'predicate-name)))
@@ -251,8 +259,6 @@ USA.
 
    (register-predicate! flo:flonum? 'flonum '<= real?)
 
-   (register-mit-bytevector-predicates!)
-
    ;; MIT/GNU Scheme: lists
    (register-predicate! alist? 'association-list '<= list?)
    (register-predicate! keyword-list? 'keyword-list '<= list?)
@@ -325,14 +331,6 @@ USA.
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)
 
-   (register-ustring-predicates!)
-
-   (cleanup-boot-time-record-predicates!)))
+   (run-deferred-boot-actions 'predicate-registrations)))
 
-(add-boot-init!
- (lambda ()
-   (for-each (lambda (reg)
-              (apply register-predicate! reg))
-            (reverse! boot-registrations))
-   (set! boot-registrations)
-   unspecific))
\ No newline at end of file
+(add-boot-init! run-deferred-predicate-registrations!)
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 806e56f1a5c053baa0b8c9fa64492b4ef41b270d..9c59983ce40144bc3dc3a5a8a9f56864155c707d 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -207,7 +207,7 @@ USA.
     unspecific))
 
 (define (initialize-record-procedures!)
-  (run-deferred-boot-actions 'record-type-predicates))
+  (run-deferred-boot-actions 'record-procedures))
 
 (define (record-type-default-value record-type field-name)
   (record-type-default-value-by-index
@@ -223,11 +223,22 @@ USA.
   %record-type-tag)
 
 (define (%set-record-type-predicate! record-type predicate)
-  (defer-boot-action 'record-type-predicates
+  (defer-boot-action 'predicate-registrations
     (lambda ()
       (%set-record-type-predicate! record-type predicate)))
   (%set-record-type-tag! record-type predicate))
 
+(defer-boot-action 'predicate-registrations
+  (lambda ()
+    (set! %record-type-predicate
+         (named-lambda (%record-type-predicate record-type)
+           (tag->predicate (%record-type-tag record-type))))
+    (set! %set-record-type-predicate!
+         (named-lambda (%set-record-type-predicate! record-type predicate)
+           (%register-record-predicate! predicate record-type)
+           (%set-record-type-tag! record-type (predicate->tag predicate))))
+    unspecific))
+
 (define (%register-record-predicate! predicate record-type)
   (register-predicate! predicate
                       (string->symbol
@@ -238,11 +249,24 @@ USA.
   %record-type-entity-tag)
 
 (define (%set-record-type-entity-predicate! record-type predicate)
-  (defer-boot-action 'record-type-predicates
+  (defer-boot-action 'predicate-registrations
     (lambda ()
       (%set-record-type-entity-predicate! record-type predicate)))
   (%set-record-type-entity-tag! record-type predicate))
 
+(defer-boot-action 'predicate-registrations
+  (lambda ()
+    (set! %record-type-entity-predicate
+         (named-lambda (%record-type-entity-predicate record-type)
+           (tag->predicate (%record-type-entity-tag record-type))))
+    (set! %set-record-type-entity-predicate!
+         (named-lambda (%set-record-type-entity-predicate! record-type
+                                                           predicate)
+           (%register-record-entity-predicate! predicate record-type)
+           (%set-record-type-entity-tag! record-type
+                                         (predicate->tag predicate))))
+    unspecific))
+
 (define (%register-record-entity-predicate! predicate record-type)
   (register-predicate! predicate
                       (string->symbol
@@ -250,24 +274,6 @@ USA.
                         (strip-angle-brackets (%record-type-name record-type))
                         "-entity"))
                       '<= record-entity?))
-
-(define (cleanup-boot-time-record-predicates!)
-  (set! %record-type-predicate
-       (named-lambda (%record-type-predicate record-type)
-         (tag->predicate (%record-type-tag record-type))))
-  (set! %set-record-type-predicate!
-       (named-lambda (%set-record-type-predicate! record-type predicate)
-         (%register-record-predicate! predicate record-type)
-         (%set-record-type-tag! record-type (predicate->tag predicate))))
-  (set! %record-type-entity-predicate
-       (named-lambda (%record-type-entity-predicate record-type)
-         (tag->predicate (%record-type-entity-tag record-type))))
-  (set! %set-record-type-entity-predicate!
-       (named-lambda (%set-record-type-entity-predicate! record-type predicate)
-         (%register-record-entity-predicate! predicate record-type)
-         (%set-record-type-entity-tag! record-type
-                                       (predicate->tag predicate))))
-  (run-deferred-boot-actions 'record-type-predicates))
 \f
 ;;;; Constructors
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f9c7eff66b88f51a1446c1d431ff422a4be1bb81..78471db90e0945bc62fcd186bcd6ad4ccec7827d 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1082,8 +1082,6 @@ USA.
          substring
          substring?
          vector->string)
-  (export (runtime predicate-metadata)
-         register-ustring-predicates!)
   (export (runtime symbol)
          %ascii-ustring!
          %ascii-ustring-allocate
@@ -1143,8 +1141,6 @@ USA.
          utf32le->string
          utf8->string
          vector->bytevector)
-  (export (runtime predicate-metadata)
-         register-mit-bytevector-predicates!)
   (export (runtime ucd-tables)
          vector->bytevector-u16be))
 
@@ -3779,8 +3775,6 @@ USA.
          error:no-such-slot
          error:uninitialized-slot
          record-type-field-index)
-  (export (runtime predicate-metadata)
-         cleanup-boot-time-record-predicates!)
   (export (runtime predicate-tagging)
          %record-type-descriptor
          %record-type-tag)

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index d9fd1f21c009a21d379fd14a62a98980b468e754..0b030b953f133d2e5cb2eb7701759c51c4ffce0e 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -75,17 +75,17 @@ USA.
        ((slice? string) (not (slice-mutable? string)))
        (else (fail))))
 
-(define (register-ustring-predicates!)
-  (register-predicate! string? 'string)
-  (register-predicate! mutable-string? 'mutable-string '<= string?)
-  (register-predicate! immutable-string? 'immutable-string '<= string?)
-  (register-predicate! nfc-string? 'nfc-string '<= string?)
-  (register-predicate! legacy-string? 'legacy-string
-                      '<= string?
-                      '<= mutable-string?)
-  (register-predicate! ustring? 'unicode-string '<= string?)
-  (register-predicate! slice? 'string-slice '<= string?)
-  (register-predicate! 8-bit-string? '8-bit-string '<= string?))
+(defer-boot-action 'predicate-registrations
+  (lambda ()
+    (register-predicate! mutable-string? 'mutable-string '<= string?)
+    (register-predicate! immutable-string? 'immutable-string '<= string?)
+    (register-predicate! nfc-string? 'nfc-string '<= string?)
+    (register-predicate! legacy-string? 'legacy-string
+                        '<= string?
+                        '<= mutable-string?)
+    (register-predicate! ustring? 'unicode-string '<= string?)
+    (register-predicate! slice? 'string-slice '<= string?)
+    (register-predicate! 8-bit-string? '8-bit-string '<= string?)))
 \f
 ;;;; Unicode string layout