Convert record support to use new predicate dispatchers.

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 78b84bc70fb752b00e347ef4f92bb013072c911e..2ae868bd9062fa224d689e33710312dac4a083e1 100644 (file)
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -142,7 +142,7 @@ USA.
 
 (define (tagged-vector/description object)
   (cond ((named-structure? object)
-        named-structure/description)
+        pp-description)
        ((tagged-vector? object)
         (vector-tag-description (tagged-vector/tag object)))
        (else

diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm
index 9f8b2d8e9d66cef5665ecebbc2f90d6e6d14cae0..65a71c0e259784ac5ffc9149db4e91e37d87661c 100644 (file)
--- a/src/runtime/debug.scm
+++ b/src/runtime/debug.scm
@@ -825,7 +825,7 @@ USA.
       (for-each (lambda (element)
                  (newline port)
                  (debugger-pp element 0 port))
-               (named-structure/description (dstate/subproblem dstate))))))
+               (pp-description (dstate/subproblem dstate))))))
 
 (define-command (command/print-frame-elements dstate port)
   (debugger-presentation

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 354e47b6b23bc87c84e5ba1ad07118886de59f9b..daa01d73ea36546bf242c3dc770cd71420ade560 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -180,15 +180,7 @@ USA.
 
    (define-predicate-dispatch-default-handler pp-description
      (lambda (object)
-       (cond ((named-structure? object)
-             (named-structure/description object))
-            ((%record? object)         ; unnamed record
-             (let loop ((i (- (%record-length object) 1)) (d '()))
-               (if (< i 0)
-                   d
-                   (loop (- i 1)
-                         (cons (list i (%record-ref object i)) d)))))
-            ((and (entity? object)
+       (cond ((and (entity? object)
                   (record? (entity-extra object)))
              ((record-entity-describer (entity-extra object)) object))
             (else #f))))

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 4d5f4e8a94309d305d1fc407181416c1041ffd17..45808bbf255fa4243b474dd159c86e937b1787ff 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -214,10 +214,7 @@ USA.
 (add-boot-init!
  (lambda ()
    (register-predicate! predicate? 'predicate)
-   (register-predicate! tag-name? 'tag-name)
-   (register-predicate! %record? '%record)
-   (register-predicate! record? 'record '<= %record?)
-   (cleanup-boot-time-record-predicates!)))
+   (register-predicate! tag-name? 'tag-name)))
 
 ;;; Registration of standard predicates
 (add-boot-init!
@@ -325,8 +322,18 @@ USA.
    (register-predicate! keyword? 'keyword '<= symbol?)
    (register-predicate! lambda-tag? 'lambda-tag)
    (register-predicate! named-structure? 'named-structure)
+   (register-predicate! named-list? 'named-list
+                       '<= non-empty-list?
+                       '<= named-structure?)
+   (register-predicate! named-vector? 'named-vector
+                       '<= vector?
+                       '<= named-structure?)
    (register-predicate! population? 'population)
    (register-predicate! promise? 'promise)
+   (register-predicate! %record? '%record)
+   (register-predicate! record? 'record
+                       '<= %record?
+                       '<= named-structure?)
    (register-predicate! record-type? 'record-type '<= record?)
    (register-predicate! stack-address? 'stack-address)
    (register-predicate! thread-mutex? 'thread-mutex)
@@ -340,7 +347,9 @@ USA.
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)
 
-   (register-ustring-predicates!)))
+   (register-ustring-predicates!)
+
+   (cleanup-boot-time-record-predicates!)))
 
 (add-boot-init!
  (lambda ()

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 94d8a125a00a6cabf91afb28cd88d8ac0839af80..7d258e0aaf085f58198f09c78567349135329596 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -259,120 +259,6 @@ USA.
   (set! boot-time-record-types)
   unspecific)
 \f
-;;;; Unparser Methods
-
-(define unparse-record)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! unparse-record
-         (standard-predicate-dispatcher 'unparse-record 2))
-
-    (define-predicate-dispatch-default-handler unparse-record
-      (standard-unparser-method 'record #f))
-
-    (define-predicate-dispatch-handler unparse-record
-      (list any-object? record?)
-      (standard-unparser-method
-       (lambda (record)
-        (strip-angle-brackets
-         (%record-type-name (%record-type-descriptor record))))
-       #f))
-
-    (define-predicate-dispatch-handler unparse-record
-      (list any-object? record-type?)
-      (standard-unparser-method 'record-type
-       (lambda (type port)
-         (write-char #\space port)
-         (display (%record-type-name type) port))))
-
-    (define-predicate-dispatch-handler unparse-record
-      (list any-object? dispatch-tag?)
-      (simple-unparser-method 'dispatch-tag
-       (lambda (tag)
-         (list (dispatch-tag-contents tag)))))))
-
-(define set-record-type-unparser-method!
-  (deferred-property-setter
-    (variable-setter set-record-type-unparser-method!)
-    (named-lambda (set-record-type-unparser-method! record-type method)
-      (guarantee unparser-method? method 'set-record-type-unparser-method!)
-      (define-predicate-dispatch-handler unparse-record
-       (list any-object? (record-predicate record-type))
-       method))))
-
-(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)))))
-\f
-(define record-description)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! record-description
-         (standard-predicate-dispatcher 'record-description 1))
-
-    (define-predicate-dispatch-default-handler record-description
-      (lambda (record)
-       (let loop ((i (fix:- (%record-length record) 1)) (d '()))
-         (if (fix:< i 0)
-             d
-             (loop (fix:- i 1)
-                   (cons (list i (%record-ref record i)) d))))))
-
-    (define-predicate-dispatch-handler record-description
-      (list record?)
-      (lambda (record)
-       (let ((type (%record-type-descriptor record)))
-         (map (lambda (field-name)
-                `(,field-name
-                  ,((record-accessor type field-name) record)))
-              (record-type-field-names type)))))))
-
-(define set-record-type-describer!
-  (deferred-property-setter
-    (variable-setter set-record-type-describer!)
-    (named-lambda (set-record-type-describer! record-type describer)
-      (guarantee unary-procedure? describer 'set-record-type-describer!)
-      (define-predicate-dispatch-handler record-description
-       (list (record-predicate record-type))
-       describer))))
-
-(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))))
-\f
 ;;;; Constructors
 
 (define (record-constructor record-type #!optional field-names)
@@ -590,6 +476,91 @@ USA.
 (define-guarantee record-type "record type")
 (define-guarantee record "record")
 \f
+;;;; Printing
+
+(define-unparser-method record?
+  (standard-unparser-method
+   (lambda (record)
+     (strip-angle-brackets
+      (%record-type-name (%record-type-descriptor record))))
+   #f))
+
+(define-unparser-method record-type?
+  (standard-unparser-method 'record-type
+    (lambda (type port)
+      (write-char #\space port)
+      (display (%record-type-name type) port))))
+
+(define-unparser-method dispatch-tag?
+  (simple-unparser-method 'dispatch-tag
+    (lambda (tag)
+      (list (dispatch-tag-contents tag)))))
+
+(define (set-record-type-unparser-method! record-type method)
+  (define-unparser-method (record-predicate record-type)
+    method))
+
+(define-pp-describer %record?
+  (lambda (record)
+    (let loop ((i (fix:- (%record-length record) 1)) (d '()))
+      (if (fix:< i 0)
+         d
+         (loop (fix:- i 1)
+               (cons (list i (%record-ref record i)) d))))))
+
+(define-pp-describer record?
+  (lambda (record)
+    (let ((type (%record-type-descriptor record)))
+      (map (lambda (field-name)
+            `(,field-name
+              ,((record-accessor type field-name) record)))
+          (record-type-field-names type)))))
+
+(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))))
+\f
 ;;;; Runtime support for DEFINE-STRUCTURE
 
 (define (initialize-structure-type-type!)
@@ -678,45 +649,55 @@ USA.
            (loop (fix:+ i 1)))))))
 \f
 (define (structure-tag/unparser-method tag physical-type)
-  (let ((type (tag->structure-type tag physical-type)))
-    (and type
-        (structure-type/unparser-method type))))
+  (and (structure-type-tag? tag physical-type)
+       (structure-type/unparser-method (tag->structure-type tag))))
 
 (define (structure-tag/entity-unparser-method tag physical-type)
-  (let ((type (tag->structure-type tag physical-type)))
-    (and type
-        (structure-type/entity-unparser-method type))))
+  (and (structure-type-tag? tag physical-type)
+       (structure-type/entity-unparser-method (tag->structure-type tag))))
 
 (define (named-structure? object)
-  (cond ((record? object) #t)
-       ((vector? object)
-        (and (not (fix:= (vector-length object) 0))
-             (tag->structure-type (vector-ref object 0) 'VECTOR)))
-       ((pair? object) (tag->structure-type (car object) 'LIST))
-       (else #f)))
-
-(define (tag->structure-type tag physical-type)
+  (or (named-list? object)
+      (named-vector? object)
+      (record? object)))
+
+(define (named-list? object)
+  (and (pair? object)
+       (structure-type-tag? (car object) 'list)
+       (list? (cdr object))))
+
+(define (named-vector? object)
+  (and (vector? object)
+       (fix:> (vector-length object) 0)
+       (structure-type-tag? (vector-ref object 0) 'vector)))
+
+(define (structure-type-tag? tag physical-type)
+  (let ((type (tag->structure-type tag)))
+    (and type
+        (eq? (structure-type/physical-type type) physical-type))))
+
+(define (tag->structure-type tag)
   (if (structure-type? tag)
-      (and (eq? (structure-type/physical-type tag) physical-type)
-          tag)
+      tag
       (let ((type (named-structure/get-tag-description tag)))
        (and (structure-type? type)
-            (eq? (structure-type/physical-type type) physical-type)
             type))))
 
-(define (named-structure/description structure)
-  (cond ((record? structure)
-        (record-description structure))
-       ((named-structure? structure)
-        => (lambda (type)
-             (let ((accessor (if (pair? structure) list-ref vector-ref)))
-               (map (lambda (field-name index)
-                      `(,field-name ,(accessor structure index)))
-                    (vector->list (structure-type/field-names type))
-                    (vector->list (structure-type/field-indexes type))))))
-       (else
-        (error:wrong-type-argument structure "named structure"
-                                   'NAMED-STRUCTURE/DESCRIPTION))))
+(define-pp-describer named-list?
+  (lambda (pair)
+    (let ((type (tag->structure-type (car pair))))
+      (map (lambda (field-name index)
+            `(,field-name ,(list-ref pair index)))
+          (vector->list (structure-type/field-names type))
+          (vector->list (structure-type/field-indexes type))))))
+
+(define-pp-describer named-vector?
+  (lambda (vector)
+    (let ((type (tag->structure-type (vector-ref vector 0))))
+      (map (lambda (field-name index)
+            `(,field-name ,(vector-ref vector index)))
+          (vector->list (structure-type/field-names type))
+          (vector->list (structure-type/field-indexes type))))))
 
 (define (define-structure/default-value type field-name)
   ((structure-type/default-init type field-name)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5fa235215e107e62258f5e426697438531af79a9..942bd60d2be3827fd82857d004e5b5b2df0aa234 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3749,8 +3749,9 @@ USA.
          list-of-unique-symbols?
          make-define-structure-type
          make-record-type
-         named-structure/description
+         named-list?
          named-structure?
+         named-vector?
          record-accessor
          record-constructor
          record-copy
@@ -3773,8 +3774,7 @@ USA.
          set-record-type-entity-describer!
          set-record-type-entity-unparser-method!
          set-record-type-extension!
-         set-record-type-unparser-method!
-         unparse-record)
+         set-record-type-unparser-method!)
   (export (runtime pretty-printer)
          record-entity-describer)
   (export (runtime record-slot-access)

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index de06b5776103cc92e60a7f178e626c96d20d07cb..1d7ef2b0bc6506fbebb8ca174116a77785cb1297 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -642,7 +642,8 @@ USA.
        ((uri? record) (unparse/uri record context))
        ((get-param:unparse-with-maximum-readability?)
         (*unparse-readable-hash record context))
-       (else (invoke-user-method unparse-record record context))))
+       (else
+        (*unparse-with-brackets 'record record context #f))))
 
 (define (unparse/uri uri context)
   (*unparse-string "#<" context)