From 96750cb49f63da289c2155c641fb98b8615c7332 Mon Sep 17 00:00:00 2001 From: Chris Hanson 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