Push definition of register-predicate! to beginning of cold load.

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index f11aefde13878a8cd93f5648093cb373536981cb..40113adca4d20937410526f5c76ba52070bd6193 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -63,27 +63,24 @@ USA.
   (and (binary-port? object)
        (port-input-buffer object)
        #t))
+(register-predicate! binary-input-port? 'binary-input-port
+                    '<= binary-port?)
 
 (define (binary-output-port? object)
   (and (binary-port? object)
        (port-output-buffer object)
        #t))
+(register-predicate! binary-output-port? 'binary-output-port
+                    '<= binary-port?)
 
 (define (binary-i/o-port? object)
   (and (binary-port? object)
        (port-input-buffer object)
        (port-output-buffer object)
        #t))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! binary-input-port? 'binary-input-port
-                       '<= binary-port?)
-   (register-predicate! binary-output-port? 'binary-output-port
-                       '<= binary-port?)
-   (register-predicate! binary-i/o-port? 'binary-i/o-port
-                       '<= binary-input-port?
-                       '<= binary-output-port?)))
+(register-predicate! binary-i/o-port? 'binary-i/o-port
+                    '<= binary-input-port?
+                    '<= binary-output-port?)
 
 (define-unparser-method binary-port?
   (standard-unparser-method
@@ -175,15 +172,12 @@ USA.
         (and (fix:= (output-sink-custom-length sink) 2)
              (eq? bytevector-output-port-tag
                   (output-sink-custom-ref sink 0))))))
+(register-predicate! bytevector-output-port? 'bytevector-output-port
+                    '<= binary-output-port?)
 
 (define bytevector-output-port-tag
   (list 'bytevector-output-port-tag))
 
-(add-boot-init!
- (lambda ()
-   (register-predicate! bytevector-output-port? 'bytevector-output-port
-                       '<= binary-output-port?)))
-
 (define (call-with-output-bytevector procedure)
   (let ((port (open-output-bytevector)))
     (procedure port)
@@ -275,6 +269,8 @@ USA.
 (define (positionable-binary-port? object)
   (and (binary-port? object)
        (binary-port-positionable? object)))
+(register-predicate! positionable-binary-port? 'positionable-binary-port
+                    '<= binary-port?)
 
 (define (binary-port-positionable? port)
   (let ((ib (port-input-buffer port))
@@ -287,11 +283,6 @@ USA.
                    (channel-type=file? ic))
               (channel-type=file? (or ic oc)))))))
 
-(add-boot-init!
- (lambda ()
-   (register-predicate! positionable-binary-port? 'positionable-binary-port
-                       '<= binary-port?)))
-
 (define (binary-port-length port)
   (guarantee positionable-binary-port? port 'port-length)
   (channel-file-length (or (let ((ib (port-input-buffer port)))
@@ -811,10 +802,7 @@ USA.
 (define (input-source? object)
   (and (source/sink? object)
        (eq? 'source (source/sink-flavor object))))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! input-source? 'input-source '<= source/sink?)))
+(register-predicate! input-source? 'input-source '<= source/sink?)
 
 (define input-source-channel source/sink-channel)
 (define input-source-port source/sink-port)
@@ -848,10 +836,7 @@ USA.
 (define (output-sink? object)
   (and (source/sink? object)
        (eq? 'sink (source/sink-flavor object))))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! output-sink? 'output-sink '<= source/sink?)))
+(register-predicate! output-sink? 'output-sink '<= source/sink?)
 
 (define output-sink-channel source/sink-channel)
 (define output-sink-port source/sink-port)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 0f6222fb21b4816304203737feaeff5b8ef122f2..7d35ad1a6cdbba940f36d9b5cad8c1c40cb293d7 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -209,6 +209,23 @@ USA.
             (procedure (cddr objects)))
        (lose))))
 \f
+;;;; Predicate registrations
+
+(define predicate?)
+(define register-predicate!)
+(let ((predicates '()))
+  (set! predicate?
+       (lambda (object)
+         (if (memq object predicates) #t #f)))
+  (set! register-predicate!
+       (lambda (predicate name . keylist)
+         (defer-boot-action 'predicate-registrations
+           (lambda ()
+             (apply register-predicate! predicate name keylist)))
+         (set! predicates (cons predicate predicates))
+         unspecific))
+  unspecific)
+
 ;;;; Miscellany
 
 (define (object-constant? object)

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 47bbdb8d7958497c50a72300c9c944dc848cd970..eee490b9112d6c0d81af4af44da8e5e87bb66618 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -77,6 +77,7 @@ USA.
                            (cdr p))))
              object)
        (alist-has-unique-keys? object)))
+(register-predicate! elements? 'interface-elements)
 
 (define-record-type <bundle-interface>
     (%make-bundle-interface tag name element-names element-properties)
@@ -136,6 +137,7 @@ USA.
                (symbol? (car p)))
              object)
        (alist-has-unique-keys? object)))
+(register-predicate! bundle-alist? 'bundle-alist '<= alist?)
 
 (define-record-type <bundle-metadata>
     (make-bundle-metadata interface values)
@@ -147,6 +149,10 @@ USA.
   (and (entity? object)
        (bundle-metadata? (entity-extra object))))
 
+(defer-boot-action 'predicate-registrations
+  (lambda ()
+    (register-predicate! bundle? 'bundle '<= entity?)))
+
 (define (bundle-interface bundle)
   (bundle-metadata-interface (entity-extra bundle)))
 
@@ -204,11 +210,5 @@ USA.
           (list name (bundle-ref bundle name)))
         (bundle-names bundle))))
 
-(define bundle-printers)
-(add-boot-init!
- (lambda ()
-   (set! bundle-printers (make-key-weak-eqv-hash-table))
-   (register-predicate! bundle-interface? 'bundle-interface '<= predicate?)
-   (register-predicate! elements? 'interface-elements)
-   (register-predicate! bundle? 'bundle '<= entity?)
-   (register-predicate! bundle-alist? 'bundle-alist '<= alist?)))
\ No newline at end of file
+(define-deferred bundle-printers
+  (make-key-weak-eqv-hash-table))
\ No newline at end of file

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 1e8757b41408b0a5e8e7000feb2366b8e25dc9ab..7351107de682f2157cf6e6687d02959d62bd7751 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -29,17 +29,10 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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)
        (fix:< object #x100)))
+(register-predicate! u8? 'u8 '<= index-fixnum?)
 
 (define-primitives
   (allocate-bytevector 1)
@@ -173,6 +166,7 @@ USA.
 (define (u16? object)
   (and (index-fixnum? object)
        (fix:< object #x10000)))
+(register-predicate! u16? 'u16 '<= index-fixnum?)
 
 (define (bytevector-u16be-ref bytevector index)
   (if (not (fix:< (fix:+ index 1) (bytevector-length bytevector)))
@@ -239,7 +233,8 @@ USA.
 
    (define (u32? object)
      (and (index-fixnum? object)
-         (fix:<= object #xFFFFFFFF))))
+         (fix:<= object #xFFFFFFFF)))
+   (register-predicate! u32? 'u32 '<= index-fixnum?))
  ;; Must use bignums:
  (begin
    (define-integrable (bytes->u32be b0 b1 b2 b3)
@@ -262,7 +257,12 @@ USA.
 
    (define (u32? object)
      (and (exact-nonnegative-integer? object)
-         (int:<= object #xFFFFFFFF)))))
+         (int:<= object #xFFFFFFFF)))
+
+   (add-boot-init!
+    (lambda ()
+      (register-predicate! u32? 'u32 '<= exact-nonnegative-integer?)))))
+
 \f
 (define-integrable (bytes->u32le b0 b1 b2 b3) (bytes->u32be b3 b2 b1 b0))
 (define-integrable u32le-byte0 u32be-byte3)

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index 34daadb0403fc611c3b1d0c36235bff72f7e5072..2c3cb2b107af96d7d7d36cbe39f4985267dd6170 100644 (file)
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -128,8 +128,7 @@ USA.
    (let ((table (make-hashed-metadata-table)))
      (set! compound-operator? (table 'has?))
      (set! compound-operator-builder (table 'get))
-     (set! define-compound-operator (table 'put!))
-     unspecific)
+     (set! define-compound-operator (table 'put!)))
    (register-predicate! compound-operator? 'compound-predicate '<= symbol?)))
 
 (add-boot-init!

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 58ec7a6297f1d3d89ebd56c1bd535b599798d112..7d376506f1c65bcfd26d006ece5978b4b121d368 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -503,7 +503,6 @@ USA.
    (RUNTIME FLOATING-POINT-ENVIRONMENT)
    ((RUNTIME THREAD) INITIALIZE-HIGH!)
    ;; I/O
-   (RUNTIME BINARY-PORT)
    (RUNTIME PORT)
    (RUNTIME OUTPUT-PORT)
    (RUNTIME GENERIC-I/O-PORT)

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 631f68299240d8959b10e709fa8d1888fa4f5c5e..a539f63f769228b2bb2a9ec14c05e4bde65cb556 100644 (file)
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -151,10 +151,7 @@ USA.
        (pair? (cdr object))
        (procedure? (cadr object))
        (null? (cddr object))))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! textual-port-type-operation? 'port-type-operation)))
+(register-predicate! textual-port-type-operation? 'port-type-operation)
 \f
 (define (parse-operations-list operations parent-type)
   (parse-operations-list-1
@@ -400,11 +397,15 @@ USA.
   (and (textual-port? object)
        (port-type-supports-input? (textual-port-type object))
        #t))
+(register-predicate! textual-input-port? 'textual-input-port
+                    '<= textual-port?)
 
 (define (textual-output-port? object)
   (and (textual-port? object)
        (port-type-supports-output? (textual-port-type object))
        #t))
+(register-predicate! textual-output-port? 'textual-output-port
+                    '<= textual-port?)
 
 (define (textual-i/o-port? object)
   (and (textual-port? object)
@@ -412,15 +413,8 @@ USA.
         (and (port-type-supports-input? type)
              (port-type-supports-output? type)
              #t))))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! textual-input-port? 'textual-input-port
-                       '<= textual-port?)
-   (register-predicate! textual-output-port? 'textual-output-port
-                       '<= textual-port?)
-   (register-predicate! textual-i/o-port? 'textual-i/o-port
-                       '<= textual-port?)))
+(register-predicate! textual-i/o-port? 'textual-i/o-port
+                    '<= textual-port?)
 
 (define-unparser-method textual-port?
   (standard-unparser-method
@@ -710,6 +704,7 @@ USA.
 (define (blocking-mode? object)
   (or (eq? 'blocking object)
       (eq? 'nonblocking object)))
+(register-predicate! blocking-mode? 'blocking-mode)
 
 (define (channel-blocking-mode channel)
   (if channel
@@ -747,6 +742,7 @@ USA.
 (define (terminal-mode? object)
   (or (eq? 'cooked object)
       (eq? 'raw object)))
+(register-predicate! terminal-mode? 'terminal-mode)
 
 (define (channel-terminal-mode channel)
   (if (and channel (channel-type=terminal? channel))
@@ -764,11 +760,6 @@ USA.
                         (and channel (channel-type=terminal? channel)))
                       channel-terminal-mode
                       set-channel-terminal-mode!))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! blocking-mode? 'blocking-mode)
-   (register-predicate! terminal-mode? 'terminal-mode)))
 \f
 ;;;; Standard Ports
 

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index f7cc1dcd8e1ed19b3fe5ff3388860e2bf216b0d4..1bb091e81670f414ba5290cead975d1bced15b14 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -29,26 +29,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (predicate? object)
-  (any (lambda (reg)
-        (eqv? (car reg) object))
-       boot-registrations))
-
-(define (register-predicate! predicate name . keylist)
-  (set! boot-registrations
-       (cons (cons* predicate name keylist)
-             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!
@@ -74,7 +54,7 @@ USA.
                  (set-tag<=! tag (predicate->tag superset)))
                (get-keyword-values keylist '<=))
       tag)))
-\f
+
 (define (predicate-name predicate)
   (tag-name (predicate->tag predicate 'predicate-name)))
 
@@ -171,7 +151,7 @@ USA.
   (simple-unparser-method 'tag
     (lambda (tag)
       (list (tag-name tag)))))
-\f
+
 (define (tag-description tag)
   (or (%tag-description tag)
       (object->description (tag-name tag))))
@@ -331,6 +311,4 @@ USA.
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)
 
-   (run-deferred-boot-actions 'predicate-registrations)))
-
-(add-boot-init! run-deferred-predicate-registrations!)
\ No newline at end of file
+   (run-deferred-boot-actions 'predicate-registrations)))
\ No newline at end of file

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index bd63a7c3b6bc8ef1ba5735340df85213a9b39360..ac772f8c7853b2ca1d653d279d615b7199e05861 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -31,6 +31,7 @@ USA.
 \f
 (define-integrable (tagged-object? object)
   (object-type? (ucode-type tagged-object) object))
+(register-predicate! tagged-object? 'tagged-object)
 
 (define (object-tagger predicate)
   (let ((tag (predicate->tag predicate)))
@@ -57,7 +58,6 @@ USA.
 (define unparser-methods)
 (add-boot-init!
  (lambda ()
-   (register-predicate! tagged-object? 'tagged-object)
    (set! unparser-methods (make-key-weak-eqv-hash-table))
    unspecific))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f3ced32ab201e67198f13c26029fd71a6ae492c0..06cedd4303286ba6439009cd7d8ce365c50c0d8a 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -158,6 +158,8 @@ USA.
          interrupt-mask/timer-ok
          object-constant?
          object-pure?
+         predicate?
+         register-predicate!
          simple-parser-method
          simple-unparser-method
          standard-unparser-method
@@ -1817,8 +1819,6 @@ USA.
          predicate-tagger
          predicate-tagging-strategy
          predicate-untagger
-         predicate?
-         register-predicate!
          set-predicate<=!)
   (export (runtime)
          event:predicate-metadata

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index 408b5bfb004758d35dcc5ef648609cfd045a4b17..82e85fc68657764b01ed1c3b08109981f1949779 100644 (file)
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -70,10 +70,12 @@ USA.
 (define (absolute-uri? object)
   (and (uri? object)
        (uri-absolute? object)))
+(register-predicate! absolute-uri? 'absolute-uri '<= uri?)
 
 (define (relative-uri? object)
   (and (uri? object)
        (uri-relative? object)))
+(register-predicate! relative-uri? 'relative-uri '<= uri?)
 
 (define-guarantee uri "URI")
 (define-guarantee absolute-uri "absolute URI")
@@ -900,8 +902,7 @@ USA.
                         (string->char-set ";/?:@&=")))
 
    (set! uri-merge-defaults (make-uri-merge-defaults))
-   (register-predicate! absolute-uri? 'absolute-uri '<= uri?)
-   (register-predicate! relative-uri? 'relative-uri '<= uri?)))
+   unspecific))
 \f
 ;;;; Partial URIs
 

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 0b030b953f133d2e5cb2eb7701759c51c4ffce0e..66af0e758b770941bb5548b7ec6fc72b4ca35451 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))))
 
-(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?)))
+(add-boot-init!
+ (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