Always register a record predicate.

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index a8e486f3f3f572cd16120647875c504677d45721..d4d133907afc2cd03d26e16768d7c621e883a069 100644 (file)
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -786,17 +786,9 @@ differences:
               `((DEFINE ,tag-name
                   (,(absolute 'RECORD-TYPE-DISPATCH-TAG context)
                    ,tag-expression))
-                (DEFINE (,predicate-name OBJECT)
-                  (DECLARE
-                   (IGNORE-REFERENCE-TRAPS (SET ,(close tag-name context))))
-                  (AND (,(absolute '%RECORD? context) OBJECT)
-                       (,(absolute 'NOT context)
-                        (,(absolute 'ZERO? context)
-                         (,(absolute '%RECORD-LENGTH context) OBJECT)))
-                       (,(absolute 'EQ? context)
-                        (,(absolute '%RECORD-REF context) OBJECT 0)
-                        ;++ Work around a bug in the expander.
-                        ,(close tag-name context)))))))
+                (DEFINE ,predicate-name
+                  (,(absolute 'RECORD-PREDICATE context)
+                   ,(close (structure/type-descriptor structure) context))))))
            ((VECTOR)
             `((DEFINE (,predicate-name OBJECT)
                 (AND (,(absolute 'VECTOR? context) OBJECT)

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 93200986590530c82691a4f15eaa740cb0668c59..ab66b660bed4962ad344865910731400bcd65e26 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -188,7 +188,6 @@ USA.
  (lambda ()
    (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")
 
@@ -205,6 +204,12 @@ USA.
 (define (any-object? object) object #t)
 (define (no-object? object) object #f)
 
+(add-boot-init!
+ (lambda ()
+   (register-predicate! %record? '%record)
+   (register-predicate! record? 'record '<= %record?)
+   (cleanup-boot-time-record-predicates!)))
+
 ;;; Registration of standard predicates
 (add-boot-init!
  (lambda ()
@@ -214,12 +219,11 @@ USA.
    (register-predicate! char? 'char)
    (register-predicate! default-object? 'default-object)
    (register-predicate! eof-object? 'eof-object)
-   (register-predicate! input-port? 'input-port)
+   (register-predicate! input-port? 'input-port '<= port?)
    (register-predicate! list? 'list)
    (register-predicate! number? 'number)
-   (register-predicate! output-port? 'output-port)
+   (register-predicate! output-port? 'output-port '<= port?)
    (register-predicate! pair? 'pair)
-   (register-predicate! port? 'port)
    (register-predicate! procedure? 'procedure)
    (register-predicate! string? 'string)
    (register-predicate! symbol? 'symbol)
@@ -283,12 +287,7 @@ USA.
    (register-predicate! procedure-arity? 'procedure-arity)
    (register-predicate! thunk? 'thunk '<= procedure?)
    (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
-   (register-predicate! unparser-method? 'unparser-method '<= procedure?)
-
-   ;; MIT/GNU Scheme: URIs
-   (register-predicate! uri? 'uniform-resource-identifier)
-   (register-predicate! absolute-uri? 'absolute-uri '<= uri?)
-   (register-predicate! relative-uri? 'relative-uri '<= uri?)))
+   (register-predicate! unparser-method? 'unparser-method '<= procedure?)))
 \f
 (add-boot-init!
  (lambda ()
@@ -305,17 +304,15 @@ USA.
    (register-predicate! environment? 'environment)
    (register-predicate! equality-predicate? 'equality-predicate
                        '<= binary-procedure?)
-   (register-predicate! hash-table? 'hash-table)
+   (register-predicate! i/o-port? 'i/o-port '<= (list input-port? output-port?))
    (register-predicate! interned-symbol? 'interned-symbol '<= symbol?)
    (register-predicate! keyword? 'keyword '<= symbol?)
    (register-predicate! lambda-tag? 'lambda-tag)
    (register-predicate! named-structure? 'named-structure)
    (register-predicate! population? 'population)
    (register-predicate! promise? 'promise)
-   (register-predicate! record? 'record)
    (register-predicate! record-type? 'record-type)
    (register-predicate! stack-address? 'stack-address)
-   (register-predicate! thread? 'thread)
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)
    (register-predicate! unicode-char? 'unicode-char '<= char?)
@@ -323,7 +320,4 @@ USA.
                        '<= index-fixnum?)
    (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
    (register-predicate! weak-list? 'weak-list)
-   (register-predicate! weak-pair? 'weak-pair)
-
-   ;; Must be called after record? is registered:
-   (cleanup-boot-time-record-predicates!)))
\ No newline at end of file
+   (register-predicate! weak-pair? 'weak-pair)))
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 58ea3a1960035def968993fc4e6e9d117252f2a2..db1b093b42d7c155af86b415773e3006b5b6e957 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -290,8 +290,7 @@ USA.
   (set! %record-type-predicate %record-type-predicate/after-boot!)
   (for-each (lambda (record-type)
              (let ((predicate (%record-type-tag record-type)))
-               (if (not (predicate? predicate))
-                   (%register-record-predicate! predicate record-type))
+               (%register-record-predicate! predicate record-type)
                (%set-record-type-tag! record-type (predicate->tag predicate))))
            boot-time-record-types)
   (set! boot-time-record-types)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 512cbea1e7bda1f76fdc308680d9b9c1068a8c83..f3b311cd8e5da9e7a7ba31a3658612254686d7fb 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3642,6 +3642,7 @@ USA.
   (export (runtime predicate-metadata)
          cleanup-boot-time-record-predicates!)
   (export (runtime tagging)
+         %record-type-descriptor
          %record-type-tag)
   (initialization (initialize-package!)))
 

diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index cc4fa0e2421a8e83fbcb3f65c2de24a60739a296..11576336fcea07d24763ed9650dfe26c930940d6 100644 (file)
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -182,8 +182,8 @@ USA.
           (else default-tag)))))
 
    (define-primitive-predicate-method 'record
-     (let ((default-tag (predicate->tag record?)))
+     (let ((default-tag (predicate->tag %record?)))
        (lambda (object)
-        (if (record-type? (%record-ref object 0))
-            (%record-type-tag (%record-ref object 0))
+        (if (record? object)
+            (%record-type-tag (%record-type-descriptor object))
             default-tag))))))
\ No newline at end of file

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index b1c9cede7d8bc6e00088caad6bfbcbe942d84451..e86945f17b07144895ba8e2ae5fd29435e0df2cd 100644 (file)
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -870,55 +870,57 @@ USA.
 (define url:char-set:unreserved)
 (define url:char-set:unescaped)
 
-(define (initialize-package!)
-  (set! char-set:uri-alpha
-       (string->char-set
-        "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
-  (set! char-set:uri-digit (string->char-set "0123456789"))
-  (set! char-set:uri-hex (string->char-set "0123456789abcdefABCDEF"))
-  (set! char-set:uri-scheme
-       (char-set-union char-set:uri-alpha
-                       char-set:uri-digit
-                       (string->char-set "+-.")))
-  (let* ((sub-delims (string->char-set "!$&'()*+,;="))
-        (unreserved
-         (char-set-union char-set:uri-alpha
-                         char-set:uri-digit
-                         (string->char-set "-._~")))
-        (component-chars
-         (lambda (extra)
-           (char-set-union unreserved sub-delims (string->char-set extra)))))
-    (set! char-set:uri-userinfo                (component-chars ":"))
-    (set! char-set:uri-ipvfuture       char-set:uri-userinfo)
-    (set! char-set:uri-reg-name                (component-chars ""))
-    (set! char-set:uri-segment         (component-chars ":@"))
-    (set! char-set:uri-segment-nc      (component-chars "@"))
-    (set! char-set:uri-query           (component-chars ":@/?"))
-    (set! char-set:uri-fragment                char-set:uri-query)
-    (set! char-set:uri-sloppy-auth     (component-chars ":@[]")))
-
-  (set! parser:userinfo                (component-parser-* char-set:uri-userinfo))
-  (set! matcher:reg-name       (component-matcher-* char-set:uri-reg-name))
-  (set! parser:segment         (component-parser-* char-set:uri-segment))
-  (set! parser:segment-nz      (component-parser-+ char-set:uri-segment))
-  (set! parser:segment-nz-nc   (component-parser-+ char-set:uri-segment-nc))
-  (set! parser:query           (component-parser-* char-set:uri-query))
-  (set! parser:fragment                (component-parser-* char-set:uri-fragment))
-
-  (set! interned-uris (make-string-hash-table))
-  (set! interned-uri-authorities (make-string-hash-table))
-
-  ;; backwards compatibility:
-  (set! url:char-set:unreserved
-       (char-set-union char-set:uri-alpha
-                       char-set:uri-digit
-                       (string->char-set "!$'()*+,-._")))
-  (set! url:char-set:unescaped
-       (char-set-union url:char-set:unreserved
-                       (string->char-set ";/?:@&=")))
-
-  (set! uri-merge-defaults (make-uri-merge-defaults))
-  unspecific)
+(add-boot-init!
+ (lambda ()
+   (set! char-set:uri-alpha
+        (string->char-set
+         "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+   (set! char-set:uri-digit (string->char-set "0123456789"))
+   (set! char-set:uri-hex (string->char-set "0123456789abcdefABCDEF"))
+   (set! char-set:uri-scheme
+        (char-set-union char-set:uri-alpha
+                        char-set:uri-digit
+                        (string->char-set "+-.")))
+   (let* ((sub-delims (string->char-set "!$&'()*+,;="))
+         (unreserved
+          (char-set-union char-set:uri-alpha
+                          char-set:uri-digit
+                          (string->char-set "-._~")))
+         (component-chars
+          (lambda (extra)
+            (char-set-union unreserved sub-delims (string->char-set extra)))))
+     (set! char-set:uri-userinfo       (component-chars ":"))
+     (set! char-set:uri-ipvfuture      char-set:uri-userinfo)
+     (set! char-set:uri-reg-name       (component-chars ""))
+     (set! char-set:uri-segment                (component-chars ":@"))
+     (set! char-set:uri-segment-nc     (component-chars "@"))
+     (set! char-set:uri-query          (component-chars ":@/?"))
+     (set! char-set:uri-fragment       char-set:uri-query)
+     (set! char-set:uri-sloppy-auth    (component-chars ":@[]")))
+
+   (set! parser:userinfo       (component-parser-* char-set:uri-userinfo))
+   (set! matcher:reg-name      (component-matcher-* char-set:uri-reg-name))
+   (set! parser:segment                (component-parser-* char-set:uri-segment))
+   (set! parser:segment-nz     (component-parser-+ char-set:uri-segment))
+   (set! parser:segment-nz-nc  (component-parser-+ char-set:uri-segment-nc))
+   (set! parser:query          (component-parser-* char-set:uri-query))
+   (set! parser:fragment       (component-parser-* char-set:uri-fragment))
+
+   (set! interned-uris (make-string-hash-table))
+   (set! interned-uri-authorities (make-string-hash-table))
+
+   ;; backwards compatibility:
+   (set! url:char-set:unreserved
+        (char-set-union char-set:uri-alpha
+                        char-set:uri-digit
+                        (string->char-set "!$'()*+,-._")))
+   (set! url:char-set:unescaped
+        (char-set-union url:char-set:unreserved
+                        (string->char-set ";/?:@&=")))
+
+   (set! uri-merge-defaults (make-uri-merge-defaults))
+   (register-predicate! absolute-uri? 'absolute-uri '<= uri?)
+   (register-predicate! relative-uri? 'relative-uri '<= uri?)))
 \f
 ;;;; Partial URIs