Register record-type predicates.

diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm
index d223c6388e8c67fab122b91cdc51ad0fc1fb4a17..3cb939f2f2f7ed4dc603eec1131f366252dda51a 100644 (file)
--- a/src/runtime/parametric-predicate.scm
+++ b/src/runtime/parametric-predicate.scm
@@ -247,8 +247,6 @@ USA.
  (lambda ()
    (register-predicate! parametric-predicate? 'parametric-predicate
                        '<= predicate?)
-   (register-predicate! predicate-template? 'predicate-template)
-   (register-predicate! parameter-binding? 'parameter-binding)
    (register-predicate! template-pattern? 'template-pattern
                        '<= non-empty-list?)))
 

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index f6766b5280230b6acacea5e401e051e19bbbfb71..93200986590530c82691a4f15eaa740cb0668c59 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -323,4 +323,7 @@ USA.
                        '<= index-fixnum?)
    (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
    (register-predicate! weak-list? 'weak-list)
-   (register-predicate! weak-pair? 'weak-pair)))
\ No newline at end of file
+   (register-predicate! weak-pair? 'weak-pair)
+
+   ;; Must be called after record? is registered:
+   (cleanup-boot-time-record-predicates!)))
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 08c85fe0efb77c42fa9532907c7e8f048b1ac83d..58ea3a1960035def968993fc4e6e9d117252f2a2 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -75,8 +75,9 @@ USA.
          (%record #f
                   #f
                   "record-type"
-                  '#(DISPATCH-TAG NAME FIELD-NAMES DEFAULT-INITS EXTENSION)
-                  (vector-cons 5 #f)
+                  '#(DISPATCH-TAG NAME FIELD-NAMES DEFAULT-INITS EXTENSION TAG)
+                  (vector-cons 6 #f)
+                  #f
                   #f)))
     (set! record-type-type-tag (make-dispatch-tag type))
     (%record-set! type 0 record-type-type-tag)
@@ -146,11 +147,15 @@ USA.
                     (->type-name type-name)
                     names
                     (vector-cons n #f)
+                    #f
                     #f))
           (tag (make-dispatch-tag record-type)))
       (%record-set! record-type 1 tag)
       (if (not (default-object? default-inits))
          (%set-record-type-default-inits! record-type default-inits caller))
+      (%set-record-type-predicate! record-type
+                                  (lambda (object)
+                                    (%tagged-record? tag object)))
       (if (not (default-object? unparser-method))
          (set-record-type-unparser-method! record-type unparser-method))
       (if (not (default-object? entity-unparser-method))
@@ -182,6 +187,12 @@ USA.
 (define-integrable (%set-record-type-extension! record-type extension)
   (%record-set! record-type 5 extension))
 
+(define-integrable (%record-type-tag record-type)
+  (%record-ref record-type 6))
+
+(define-integrable (%set-record-type-tag! record-type tag)
+  (%record-set! record-type 6 tag))
+
 (define-integrable (%record-type-n-fields record-type)
   (vector-length (%record-type-field-names record-type)))
 
@@ -194,7 +205,7 @@ USA.
 
 (define (record-type-name record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-NAME)
-  (%record-type-name record-type))
+  (string-copy (%record-type-name record-type)))
 
 (define (record-type-field-names record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
@@ -253,6 +264,39 @@ USA.
   (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!)
   (%set-record-type-extension! record-type extension))
 \f
+(define boot-time-record-types '())
+
+(define (%set-record-type-predicate! record-type predicate)
+  (set! boot-time-record-types (cons record-type boot-time-record-types))
+  (%set-record-type-tag! record-type predicate))
+
+(define (%record-type-predicate record-type)
+  (%record-type-tag record-type))
+
+(define (%set-record-type-predicate!/after-boot record-type predicate)
+  (%register-record-predicate! predicate record-type)
+  (%set-record-type-tag! record-type (predicate->tag predicate)))
+
+(define (%register-record-predicate! predicate record-type)
+  (register-predicate! predicate
+                      (string->symbol (%record-type-name record-type))
+                      '<= record?))
+
+(define (%record-type-predicate/after-boot! record-type)
+  (tag->predicate (%record-type-tag record-type)))
+
+(define (cleanup-boot-time-record-predicates!)
+  (set! %set-record-type-predicate! %set-record-type-predicate!/after-boot)
+  (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))
+               (%set-record-type-tag! record-type (predicate->tag predicate))))
+           boot-time-record-types)
+  (set! boot-time-record-types)
+  unspecific)
+\f
 ;;;; Unparser Methods
 
 (define set-record-type-unparser-method!
@@ -512,9 +556,7 @@ USA.
 
 (define (record-predicate record-type)
   (guarantee-record-type record-type 'RECORD-PREDICATE)
-  (let ((tag (record-type-dispatch-tag record-type)))
-    (lambda (object)
-      (%tagged-record? tag object))))
+  (%record-type-predicate record-type))
 
 (define (record-accessor record-type field-name)
   (guarantee-record-type record-type 'RECORD-ACCESSOR)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d92d672b703abd21435ee27bd00891034e1cd9ab..512cbea1e7bda1f76fdc308680d9b9c1068a8c83 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3639,6 +3639,10 @@ USA.
   (export (runtime unparser)
          structure-tag/entity-unparser-method
          structure-tag/unparser-method)
+  (export (runtime predicate-metadata)
+         cleanup-boot-time-record-predicates!)
+  (export (runtime tagging)
+         %record-type-tag)
   (initialization (initialize-package!)))
 
 (define-package (runtime tagging)

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