From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 10 Jan 2018 04:47:55 +0000 (-0800)
Subject: Clean up the ad hoc handling of boot-time predicate registrations.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~385
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=96750cb49f63da289c2155c641fb98b8615c7332;p=mit-scheme.git

Clean up the ad hoc handling of boot-time predicate registrations.
---

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