From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 07:30:39 +0000 (-0800)
Subject: Change new files to use boot-init mechanism.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~211
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=96f9a52dda039136bbb9d755bd31f51df7163615;p=mit-scheme.git

Change new files to use boot-init mechanism.

Also change to use guarantee, and to register lots of standard predicates.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index af67806de..b39b258a8 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -33,8 +33,6 @@ USA.
   (and (index-fixnum? object)
        (fix:< object #x100)))
 
-(define-guarantee byte "byte")
-
 (define-primitives
   (allocate-bytevector 1)
   (bytevector-fill! 4)
@@ -43,7 +41,10 @@ USA.
   (bytevector-u8-set! 3)
   (bytevector? 1))
 
-(define-guarantee bytevector "byte vector")
+(add-boot-init!
+ (lambda ()
+   (register-predicate! byte? 'byte '<= exact-nonnegative-integer?)
+   (register-predicate! bytevector? 'bytevector)))
 
 (define (make-bytevector k #!optional byte)
   (let ((bytevector (allocate-bytevector k)))
@@ -86,12 +87,12 @@ USA.
    (if (default-object? end) (bytevector-length from) end)))
 
 (define (string->utf8 string #!optional start end)
-  (guarantee-string string 'string->utf8)
+  (guarantee string? string 'string->utf8)
   (let* ((end
 	  (if (default-object? end)
 	      (string-length string)
 	      (begin
-		(guarantee-index-fixnum end 'string->utf8)
+		(guarantee index-fixnum? end 'string->utf8)
 		(if (not (fix:<= end (string-length string)))
 		    (error:bad-range-argument end 'string->utf8))
 		end)))
@@ -99,7 +100,7 @@ USA.
 	  (if (default-object? start)
 	      0
 	      (begin
-		(guarantee-index-fixnum start 'string->utf8)
+		(guarantee index-fixnum? start 'string->utf8)
 		(if (not (fix:<= start end))
 		    (error:bad-range-argument start 'string->utf8))
 		start))))
@@ -161,12 +162,12 @@ USA.
 	  (else (error "Not a unicode character:" char)))))
 
 (define (utf8->string bytevector #!optional start end)
-  (guarantee-bytevector bytevector 'utf8->string)
+  (guarantee bytevector? bytevector 'utf8->string)
   (let* ((end
 	  (if (default-object? end)
 	      (bytevector-length bytevector)
 	      (begin
-		(guarantee-index-fixnum end 'utf8->string)
+		(guarantee index-fixnum? end 'utf8->string)
 		(if (not (fix:<= end (bytevector-length bytevector)))
 		    (error:bad-range-argument end 'utf8->string))
 		end)))
@@ -174,7 +175,7 @@ USA.
 	 (if (default-object? start)
 	     0
 	     (begin
-	       (guarantee-index-fixnum start 'utf8->string)
+	       (guarantee index-fixnum? start 'utf8->string)
 	       (if (not (fix:<= start end))
 		   (error:bad-range-argument start 'utf8->string))
 	       start))))
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 3de6e6bcb..abb6b1dbc 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -454,6 +454,7 @@ USA.
    (RUNTIME TAGGING)
    (RUNTIME HASH)
    (RUNTIME DYNAMIC)
+   (RUNTIME BYTEVECTOR)
    (RUNTIME REGULAR-SEXPRESSION)
    ;; Microcode data structures
    (RUNTIME HISTORY)
diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index 6840d334a..af0a271cc 100644
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -104,13 +104,14 @@ USA.
 
 (define tag<=-cache)
 (define tag<=-overrides)
-(define (initialize-package!)
-  (set! tag<=-cache (make-equal-hash-table))
-  (set! tag<=-overrides '())
-  (add-event-receiver! event:predicate-metadata metadata-event!)
+(add-boot-init!
+ (lambda ()
+   (set! tag<=-cache (make-equal-hash-table))
+   (set! tag<=-overrides '())
+   (add-event-receiver! event:predicate-metadata metadata-event!)
 
-  (define-tag<= bottom-tag? tag? true-tag<=)
-  (define-tag<= tag? top-tag? true-tag<=)
+   (define-tag<= bottom-tag? tag? true-tag<=)
+   (define-tag<= tag? top-tag? true-tag<=)
 
-  (define-tag<= non-bottom-tag? bottom-tag? false-tag<=)
-  (define-tag<= top-tag? non-top-tag? false-tag<=))
\ No newline at end of file
+   (define-tag<= non-bottom-tag? bottom-tag? false-tag<=)
+   (define-tag<= top-tag? non-top-tag? false-tag<=)))
\ No newline at end of file
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 1583b090d..001916793 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -33,13 +33,14 @@ USA.
 (define get-predicate-tag)
 (define set-predicate-tag!)
 (define delete-predicate-tag!)
-(define (initialize-metadata-table!)
-  (let ((table (make-hashed-metadata-table)))
-    (set! predicate? (table 'has?))
-    (set! get-predicate-tag (table 'get-if-available))
-    (set! set-predicate-tag! (table 'put!))
-    (set! delete-predicate-tag! (table 'delete!))
-    unspecific))
+(add-boot-init!
+ (lambda ()
+   (let ((table (make-hashed-metadata-table)))
+     (set! predicate? (table 'has?))
+     (set! get-predicate-tag (table 'get-if-available))
+     (set! set-predicate-tag! (table 'put!))
+     (set! delete-predicate-tag! (table 'delete!))
+     unspecific)))
 
 (define boot-registrations (cons '() '()))
 (define (register-predicate! . args)
@@ -63,7 +64,7 @@ USA.
 (define (predicate->tag predicate #!optional caller)
   (let ((tag (get-predicate-tag predicate #f)))
     (if (not tag)
-        (error:wrong-type-argument predicate "predicate" caller))
+        (error:not-a predicate? predicate caller))
     tag))
 
 (define (predicate-name predicate)
@@ -187,25 +188,24 @@ USA.
 
 (define the-top-tag)
 (define the-bottom-tag)
-(define (initialize-package!)
-  (initialize-metadata-table!)
-
-  ;; Transition to post-boot registration
-  (set! register-predicate! register-predicate!/after-boot)
-  (do ((regs (car boot-registrations) (cdr regs)))
-      ((not (pair? regs)))
-    (apply register-predicate! (car regs)))
-  (set! boot-registrations)
-
-  (register-predicate! predicate? 'predicate)
-  (register-predicate! tag-name? 'tag-name)
-  (register-predicate! tag? 'tag)
-  (register-predicate! any-object? '(conjoin) 'description "any object")
-  (register-predicate! no-object? '(disjoin) 'description "no object")
-
-  (set! the-top-tag (predicate->tag any-object?))
-  (set! the-bottom-tag (predicate->tag no-object?))
-  unspecific)
+(add-boot-init!
+ (lambda ()
+   ;; Transition to post-boot registration
+   (set! register-predicate! register-predicate!/after-boot)
+   (do ((regs (car boot-registrations) (cdr regs)))
+       ((not (pair? regs)))
+     (apply register-predicate! (car regs)))
+   (set! boot-registrations)
+
+   (register-predicate! predicate? 'predicate)
+   (register-predicate! tag-name? 'tag-name)
+   (register-predicate! tag? 'tag)
+   (register-predicate! any-object? '(conjoin) 'description "any object")
+   (register-predicate! no-object? '(disjoin) 'description "no object")
+
+   (set! the-top-tag (predicate->tag any-object?))
+   (set! the-bottom-tag (predicate->tag no-object?))
+   unspecific))
 
 (define (top-tag) the-top-tag)
 (define (top-tag? object) (eqv? the-top-tag object))
@@ -214,4 +214,101 @@ USA.
 (define (bottom-tag? object) (eqv? the-bottom-tag object))
 
 (define (any-object? object) object #t)
-(define (no-object? object) object #f)
\ No newline at end of file
+(define (no-object? object) object #f)
+
+
+;;; Registration of standard predicates
+(add-boot-init!
+ (lambda ()
+   ;; R7RS
+   (register-predicate! boolean? 'boolean)
+   (register-predicate! char? 'char)
+   (register-predicate! default-object? 'default-object)
+   (register-predicate! eof-object? 'eof-object)
+   (register-predicate! input-port? 'input-port)
+   (register-predicate! list? 'list)
+   (register-predicate! number? 'number)
+   (register-predicate! output-port? 'output-port)
+   (register-predicate! pair? 'pair)
+   (register-predicate! port? 'port)
+   (register-predicate! procedure? 'procedure)
+   (register-predicate! string? 'string)
+   (register-predicate! symbol? 'symbol)
+   (register-predicate! vector? 'vector)
+
+   (register-predicate! real? 'real-number '<= number?)
+   (register-predicate! rational? 'rational-number '<= real?)
+   (register-predicate! integer? 'integer '<= rational?)
+
+   (register-predicate! null? 'empty-list '<= list?)
+
+   ;; SRFI-1
+   (register-predicate! circular-list? 'circular-list)
+   (register-predicate! dotted-list? 'dotted-list)
+   (register-predicate! not-pair? 'not-pair)))
+
+;;; Registration of predicates defined earlier in the boot load
+(add-boot-init!
+ (lambda ()
+   ;; MIT/GNU Scheme: specialized arithmetic
+   (register-predicate! exact-integer? 'exact-integer '<= integer?)
+   (register-predicate! exact-nonnegative-integer? 'exact-nonnegative-integer
+			'<= exact-integer?)
+   (register-predicate! exact-positive-integer? 'exact-positive-integer
+			'<= exact-integer?)
+   (register-predicate! exact-rational? 'exact-rational '<= rational?)
+
+   (register-predicate! fix:fixnum? 'fixnum '<= exact-integer?)
+   (register-predicate! index-fixnum? 'index-fixnum '<= fix:fixnum?)
+   (register-predicate! negative-fixnum? 'negative-fixnum '<= fix:fixnum?)
+   (register-predicate! positive-fixnum? 'positive-fixnum '<= fix:fixnum?)
+   (set-predicate<=! positive-fixnum? exact-positive-integer?)
+
+   (register-predicate! non-negative-fixnum? 'non-negative-fixnum
+			'<= fix:fixnum?)
+   (set-predicate<=! non-negative-fixnum? exact-nonnegative-integer?)
+   (register-predicate! non-positive-fixnum? 'non-positive-fixnum
+			'<= fix:fixnum?)
+
+   (register-predicate! flo:flonum? 'flonum '<= real?)
+
+   ;; MIT/GNU Scheme: lists
+   (register-predicate! alist? 'association-list '<= list?)
+   (register-predicate! keyword-list? 'keyword-list '<= list?)
+   (register-predicate! list-of-unique-symbols? 'list-of-unique-symbols
+			'<= list?)
+   (register-predicate! unique-keyword-list? 'unique-keyword-list
+			'<= keyword-list?)
+
+   ;; MIT/GNU Scheme: procedures
+   (register-predicate! apply-hook? 'apply-hook '<= procedure?)
+   (register-predicate! compiled-procedure? 'compiled-procedure '<= procedure?)
+   (register-predicate! entity? 'entity '<= procedure?)
+   (register-predicate! generic-procedure? 'generic-procedure '<= procedure?)
+   (register-predicate! primitive-procedure? 'primitive-procedure
+			'<= procedure?)
+   (register-predicate! thunk? 'thunk '<= procedure?)
+   (register-predicate! unparser-method? 'unparser-method '<= procedure?)
+
+   ;; MIT/GNU Scheme: other stuff
+   (register-predicate! absolute-uri? 'absolute-uri)
+   (register-predicate! dispatch-tag? 'dispatch-tag)
+   (register-predicate! environment? 'environment)
+   (register-predicate! interned-symbol? 'interned-symbol '<= symbol?)
+   (register-predicate! keyword? 'keyword '<= symbol?)
+   (register-predicate! lambda-tag? 'lambda-tag '<= symbol?)
+   (register-predicate! named-structure? 'named-structure)
+   (register-predicate! population? 'population)
+   (register-predicate! record? 'record)
+   (register-predicate! record-type? 'record-type)
+   (register-predicate! relative-uri? 'relative-uri)
+   (register-predicate! thread? 'thread)
+   (register-predicate! thread-mutex? 'thread-mutex)
+   (register-predicate! undefined-value? 'undefined-value)
+   (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
+   (register-predicate! uri? 'uniform-resource-identifier)
+   (register-predicate! weak-list? 'weak-list)
+   (register-predicate! weak-pair? 'weak-pair)
+
+   (set-predicate<=! absolute-uri? uri?)
+   (set-predicate<=! relative-uri? uri?)))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2ab8b3830..ef1e73820 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1774,8 +1774,7 @@ USA.
 	  tag-name
 	  tag?
 	  top-tag
-	  top-tag?)
-  (initialization (initialize-package!)))
+	  top-tag?))
 
 (define-package (runtime predicate-lattice)
   (files "predicate-lattice")
@@ -1787,8 +1786,7 @@ USA.
 	  define-tag<=
 	  tag<=
 	  tag=
-	  tag>=)
-  (initialization (initialize-package!)))
+	  tag>=))
 
 (define-package (runtime environment)
   (files "uenvir")
@@ -3489,7 +3487,7 @@ USA.
 	  register-c-callback
 	  set-alien/ctype!
 	  update-html-index
-	  update-optiondb)	  
+	  update-optiondb)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)
@@ -3604,8 +3602,7 @@ USA.
   (export (runtime)
 	  tagged-object-tag)
   (export (runtime unparser)
-	  get-tagged-object-unparser-method)
-  (initialization (initialize-package!)))
+	  get-tagged-object-unparser-method))
 
 (define-package (runtime reference-trap)
   (files "urtrap")
diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index fec5f84da..e6b028de6 100644
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -58,10 +58,11 @@ USA.
   (system-pair-cdr object))
 
 (define unparser-methods)
-(define (initialize-package!)
-  (register-predicate! tagged-object? 'tagged-object)
-  (set! unparser-methods (make-key-weak-eqv-hash-table))
-  unspecific)
+(add-boot-init!
+ (lambda ()
+   (register-predicate! tagged-object? 'tagged-object)
+   (set! unparser-methods (make-key-weak-eqv-hash-table))
+   unspecific))
 
 (define (get-tagged-object-unparser-method object)
   (hash-table-ref/default unparser-methods (tagged-object-tag object) #f))
@@ -69,6 +70,7 @@ USA.
 (define (set-tagged-object-unparser-method! tag unparser)
   (if unparser
       (begin
-	(guarantee-unparser-method unparser 'set-tagged-object-unparser-method!)
+	(guarantee unparser-method? unparser
+		   'set-tagged-object-unparser-method!)
 	(hash-table-set! unparser-methods tag unparser))
       (hash-table-delete! unparser-methods tag)))
\ No newline at end of file