From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 10 Jan 2018 06:00:39 +0000 (-0800)
Subject: Push definition of register-predicate! to beginning of cold load.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~383
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dded11d8f4c5d522e64f0b4ef678ea8536787a0e;p=mit-scheme.git

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 f11aefde1..40113adca 100644
--- 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 0f6222fb2..7d35ad1a6 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -209,6 +209,23 @@ USA.
 	     (procedure (cddr objects)))
 	(lose))))
 
+;;;; 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 47bbdb8d7..eee490b91 100644
--- 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 1e8757b41..7351107de 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -29,17 +29,10 @@ USA.
 
 (declare (usual-integrations))
 
-(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?)))))
+
 
 (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 34daadb04..2c3cb2b10 100644
--- 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 58ec7a629..7d376506f 100644
--- 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 631f68299..a539f63f7 100644
--- 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)
 
 (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)))
 
 ;;;; Standard Ports
 
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index f7cc1dcd8..1bb091e81 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -29,26 +29,6 @@ USA.
 
 (declare (usual-integrations))
 
-(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)))
-
+
 (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)))))
-
+
 (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 bd63a7c3b..ac772f8c7 100644
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -31,6 +31,7 @@ USA.
 
 (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 f3ced32ab..06cedd430 100644
--- 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 408b5bfb0..82e85fc68 100644
--- 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))
 
 ;;;; Partial URIs
 
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 0b030b953..66af0e758 100644
--- 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?)))
 
 ;;;; Unicode string layout