Clean up handling of entities with records as extra.

Implement record-entity? and record-entity-predicate.
Also clean up printing support for these.

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index daa01d73ea36546bf242c3dc770cd71420ade560..f264c302d68b9a06aedd230e1ff7f07efd83bafb 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -180,10 +180,8 @@ USA.
 
    (define-predicate-dispatch-default-handler pp-description
      (lambda (object)
-       (cond ((and (entity? object)
-                  (record? (entity-extra object)))
-             ((record-entity-describer (entity-extra object)) object))
-            (else #f))))
+       (declare (ignore object))
+       #f))
 
    (set! define-pp-describer
         (named-lambda (define-pp-describer predicate describer)

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 45808bbf255fa4243b474dd159c86e937b1787ff..7938785b3399944fc14f331696ebbef127502c0e 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -291,6 +291,7 @@ USA.
    (register-predicate! binary-procedure? 'binary-procedure '<= procedure?)
    (register-predicate! compiled-procedure? 'compiled-procedure '<= procedure?)
    (register-predicate! entity? 'entity '<= procedure?)
+   (register-predicate! record-entity? 'record-entity '<= entity?)
    (register-predicate! generic-procedure? 'generic-procedure '<= procedure?)
    (register-predicate! memoizer? 'memoizer '<= apply-hook?)
    (register-predicate! primitive-procedure? 'primitive-procedure

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 7d258e0aaf085f58198f09c78567349135329596..932d4e521b4a59e7d23197ee61494251972eb392 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -56,6 +56,10 @@ USA.
   (and (%record? object)
        (eq? (%record-tag object) tag)))
 
+(define (%tagged-record-entity? tag object)
+  (and (entity? object)
+       (%tagged-record? tag (entity-extra object))))
+
 (define (%copy-record record)
   (let ((length (%record-length record)))
     (let ((result (%make-record (%record-tag record) length)))
@@ -71,8 +75,10 @@ USA.
          (%record #f
                   #f
                   "record-type"
-                  '#(DISPATCH-TAG NAME FIELD-NAMES DEFAULT-INITS EXTENSION TAG)
-                  (vector-cons 6 #f)
+                  '#(dispatch-tag name field-names default-inits
+                                  extension tag entity-tag)
+                  (vector-cons 7 #f)
+                  #f
                   #f
                   #f)))
     (set! record-type-type-tag (make-dispatch-tag type))
@@ -83,16 +89,7 @@ USA.
 (define (initialize-record-procedures!)
   (set! %set-record-type-default-inits!
        %set-record-type-default-inits!/after-boot)
-  (run-deferred-boot-actions 'record/procedures))
-
-(define (deferred-property-setter setter handler)
-  (defer-boot-action 'record/procedures
-    (lambda ()
-      (setter handler)))
-  (lambda args
-    (defer-boot-action 'record/procedures
-      (lambda ()
-       ((ucode-primitive apply) handler args)))))
+  unspecific)
 \f
 (define (make-record-type type-name field-names
                          #!optional
@@ -109,14 +106,18 @@ USA.
                     names
                     (vector-cons n #f)
                     #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)))
+       (lambda (object)
+         (%tagged-record? tag object)))
+      (%set-record-type-entity-predicate! record-type
+       (lambda (object)
+         (%tagged-record-entity? tag object)))
       (if (and unparser-method
               (not (default-object? unparser-method)))
          (set-record-type-unparser-method! record-type unparser-method))
@@ -156,6 +157,12 @@ USA.
 (define-integrable (%set-record-type-tag! record-type tag)
   (%record-set! record-type 6 tag))
 
+(define-integrable (%record-type-entity-tag record-type)
+  (%record-ref record-type 7))
+
+(define-integrable (%set-record-type-entity-tag! record-type tag)
+  (%record-set! record-type 7 tag))
+
 (define-integrable (%record-type-n-fields record-type)
   (vector-length (%record-type-field-names record-type)))
 
@@ -227,37 +234,55 @@ USA.
   (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!)
   (%set-record-type-extension! record-type extension))
 \f
-(define boot-time-record-types '())
+(define %record-type-predicate
+  %record-type-tag)
 
 (define (%set-record-type-predicate! record-type predicate)
-  (set! boot-time-record-types (cons record-type boot-time-record-types))
+  (defer-boot-action 'record-type-predicates
+    (lambda ()
+      (%set-record-type-predicate! record-type predicate)))
   (%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))
+                      (string->symbol
+                       (strip-angle-brackets (%record-type-name record-type)))
                       '<= record?))
 
-(define (%record-type-predicate/after-boot! record-type)
-  (tag->predicate (%record-type-tag record-type)))
+(define %record-type-entity-predicate
+  %record-type-entity-tag)
+
+(define (%set-record-type-entity-predicate! record-type predicate)
+  (defer-boot-action 'record-type-predicates
+    (lambda ()
+      (%set-record-type-entity-predicate! record-type predicate)))
+  (%set-record-type-entity-tag! record-type predicate))
+
+(define (%register-record-entity-predicate! predicate record-type)
+  (register-predicate! predicate
+                      (string->symbol
+                       (string-append
+                        (strip-angle-brackets (%record-type-name record-type))
+                        "-entity"))
+                      '<= record-entity?))
 
 (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)))
-               (%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)
+  (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))
 \f
 ;;;; Constructors
 
@@ -397,6 +422,10 @@ USA.
        (dispatch-tag? (%record-tag object))
        (record-type? (dispatch-tag-contents (%record-tag object)))))
 
+(define (record-entity? object)
+  (and (entity? object)
+       (record? (entity-extra object))))
+
 (define (record-type-descriptor record)
   (guarantee-record record 'RECORD-TYPE-DESCRIPTOR)
   (%record-type-descriptor record))
@@ -409,6 +438,10 @@ USA.
   (guarantee-record-type record-type 'RECORD-PREDICATE)
   (%record-type-predicate record-type))
 
+(define (record-entity-predicate record-type)
+  (guarantee-record-type record-type 'record-entity-predicate)
+  (%record-type-entity-predicate record-type))
+
 (define (record-accessor record-type field-name)
   (guarantee-record-type record-type 'RECORD-ACCESSOR)
   (let ((tag (record-type-dispatch-tag record-type))
@@ -478,6 +511,9 @@ USA.
 \f
 ;;;; Printing
 
+(define-unparser-method %record?
+ (standard-unparser-method 'record #f))
+
 (define-unparser-method record?
   (standard-unparser-method
    (lambda (record)
@@ -519,47 +555,14 @@ USA.
 (define (set-record-type-describer! record-type describer)
   (define-pp-describer (record-predicate record-type)
     describer))
-\f
-(define record-entity-unparser)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! record-entity-unparser
-         (standard-predicate-dispatcher 'record-entity-unparser 1))
-
-    (define-predicate-dispatch-default-handler record-entity-unparser
-      (standard-unparser-method 'entity #f))))
-
-(define set-record-type-entity-unparser-method!
-  (deferred-property-setter
-    (variable-setter set-record-type-entity-unparser-method!)
-    (named-lambda (set-record-type-entity-unparser-method! record-type method)
-      (guarantee unparser-method? method
-                'set-record-type-entity-unparser-method!)
-      (define-predicate-dispatch-handler record-entity-unparser
-       (list (record-predicate record-type))
-       (lambda (record)
-         (declare (ignore record))
-         method)))))
-
-(define record-entity-describer)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! record-entity-describer
-         (standard-predicate-dispatcher 'record-entity-describer 1))
-
-    (define-predicate-dispatch-default-handler record-entity-describer
-      (lambda (entity)
-       (declare (ignore entity))
-       #f))))
-
-(define set-record-type-entity-describer!
-  (deferred-property-setter
-    (variable-setter set-record-type-entity-describer!)
-    (named-lambda (set-record-type-entity-describer! record-type describer)
-      (guarantee unary-procedure? describer 'set-record-type-entity-describer!)
-      (define-predicate-dispatch-handler record-entity-describer
-       (list (record-predicate record-type))
-       describer))))
+
+(define (set-record-type-entity-unparser-method! record-type method)
+  (define-unparser-method (record-entity-predicate record-type)
+    method))
+
+(define (set-record-type-entity-describer! record-type describer)
+  (define-pp-describer (record-entity-predicate record-type)
+    describer))
 \f
 ;;;; Runtime support for DEFINE-STRUCTURE
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 942bd60d2be3827fd82857d004e5b5b2df0aa234..34c08fc5601a864a9dae9f0e116d732e15a65b95 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3755,6 +3755,8 @@ USA.
          record-accessor
          record-constructor
          record-copy
+         record-entity?
+         record-entity-predicate
          record-keyword-constructor
          record-modifier
          record-predicate
@@ -3775,12 +3777,9 @@ USA.
          set-record-type-entity-unparser-method!
          set-record-type-extension!
          set-record-type-unparser-method!)
-  (export (runtime pretty-printer)
-         record-entity-describer)
   (export (runtime record-slot-access)
          record-type-field-index)
   (export (runtime unparser)
-         record-entity-unparser
          structure-tag/entity-unparser-method
          structure-tag/unparser-method)
   (export (runtime predicate-metadata)

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 1d7ef2b0bc6506fbebb8ca174116a77785cb1297..20248a928cba6858e7930e6477dcb8f118c7daa5 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -928,13 +928,6 @@ USA.
                  (else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
         ((get-param:unparse-with-maximum-readability?)
          (*unparse-readable-hash entity context))
-        ((record? (%entity-extra entity))
-         ;; Kludge to make the generic dispatch mechanism work.
-         (invoke-user-method
-          (lambda (state entity)
-            ((record-entity-unparser (%entity-extra entity)) state entity))
-          entity
-         context))
         ((or (and (vector? (%entity-extra entity))
                   (unparse-vector/entity-unparser (%entity-extra entity)))
              (and (pair? (%entity-extra entity))