From 96750cb49f63da289c2155c641fb98b8615c7332 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 9 Jan 2018 20:47:55 -0800
Subject: [PATCH] Clean up the ad hoc handling of boot-time predicate
registrations.
---
src/runtime/bytevector.scm | 13 ++++----
src/runtime/predicate-metadata.scm | 52 ++++++++++++++----------------
src/runtime/record.scm | 48 +++++++++++++++------------
src/runtime/runtime.pkg | 6 ----
src/runtime/ustring.scm | 22 ++++++-------
5 files changed, 70 insertions(+), 71 deletions(-)
diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 28b792d83..1e8757b41 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -29,12 +29,13 @@ USA.
(declare (usual-integrations))
-(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 54ccc9cc8..f7cc1dcd8 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -29,8 +29,6 @@ USA.
(declare (usual-integrations))
-(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)))
(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 806e56f1a..9c59983ce 100644
--- 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))
;;;; Constructors
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f9c7eff66..78471db90 100644
--- 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 d9fd1f21c..0b030b953 100644
--- 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?)))
;;;; Unicode string layout
--
2.25.1