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