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 af67806de033a88a0e54cd1b996ddd0e51f33256..b39b258a8dda2e25b53b092cecd04c77f6190cc2 100644 (file)
--- 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)))
 \f
 (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)))))
 \f
 (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 3de6e6bcb7fd28a9e9eb029677a4c3a1a850a4c6..abb6b1dbcaf1cc27227883204b2b85ca7fb0017c 100644 (file)
--- 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 6840d334a2a109bd74d7b94019f2089d478c764e..af0a271ccd1a79fdac215950e7f132db038bedbd 100644 (file)
--- 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 1583b090dd0b383103e5a826ad5fdfb6223560f1..0019167930590f3375fbd363caf833887ba77db8 100644 (file)
--- 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.
 \f
 (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)))
+\f
+;;; 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 2ab8b383039c64d9c6c8278a87167539b5d6ab07..ef1e73820a0e433264c2d00f90358ae598fc77f7 100644 (file)
--- 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 fec5f84dac4a948e62f04a5e5e98a8769f5d2893..e6b028de6053a7d25d607b96704298a6be863340 100644 (file)
--- 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