Eliminate special support for defstruct printers.

In future just use define-unparser-method.

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index ebb2f0237d52a944949f9b7ea6d7d08a5d394546..4cab2ae78926cb05170e32011be5b6a0bf5bc1ca 100644 (file)
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -57,9 +57,6 @@ differences:
   a procedure of two arguments (the unparser state and the structure
   instance) rather than three as in Common Lisp.
 
-* There is an additional option PRINT-ENTITY-PROCEDURE, used to print
-  an entity whose extra object is a structure instance.
-
 * By default, named structures are tagged with a unique object of some
   kind.  In Common Lisp, the structures are tagged with symbols, but
   that depends on the Common Lisp package system to help generate
@@ -105,7 +102,8 @@ differences:
                  ,@(accessor-definitions structure)
                  ,@(modifier-definitions structure)
                  ,@(predicate-definitions structure)
-                 ,@(copier-definitions structure))))))))
+                 ,@(copier-definitions structure)
+                 ,@(printer-definitions structure))))))))
 \f
 ;;;; Parse options
 
@@ -118,8 +116,6 @@ differences:
          (copier-option (find-option 'COPIER options))
          (predicate-option (find-option 'PREDICATE options))
          (print-procedure-option (find-option 'PRINT-PROCEDURE options))
-         (print-entity-procedure-option
-          (find-option 'PRINT-ENTITY-PROCEDURE options))
          (type-option (find-option 'TYPE options))
          (type-descriptor-option (find-option 'TYPE-DESCRIPTOR options))
          (named-option (find-option 'NAMED options))
@@ -138,8 +134,7 @@ differences:
            (check-for-illegal-untyped named-option initial-offset-option))
        (if (not tagged?)
            (check-for-illegal-untagged predicate-option
-                                       print-procedure-option
-                                       print-entity-procedure-option))
+                                       print-procedure-option))
        (do ((slots slots (cdr slots))
             (index (if tagged? (+ offset 1) offset) (+ index 1)))
            ((not (pair? slots)))
@@ -166,9 +161,6 @@ differences:
                                (option/argument print-procedure-option)
                                (and type-option
                                     (default-unparser-text context)))
-                           (if print-entity-procedure-option
-                               (option/argument print-entity-procedure-option)
-                               #f)
                            (if type-option
                                (option/argument type-option)
                                'RECORD)
@@ -222,8 +214,7 @@ differences:
        (lose initial-offset-option))))
 
 (define (check-for-illegal-untagged predicate-option
-                                   print-procedure-option
-                                   print-entity-procedure-option)
+                                   print-procedure-option)
   (let ((test
         (lambda (option)
           (if (and option
@@ -233,8 +224,7 @@ differences:
               (error "Structure option illegal for unnamed structure:"
                      (option/original option))))))
     (test predicate-option)
-    (test print-procedure-option)
-    (test print-entity-procedure-option)))
+    (test print-procedure-option)))
 
 (define (compute-constructors constructor-options
                              keyword-constructor-options
@@ -438,13 +428,6 @@ differences:
       (lambda (arg)
        `(PRINT-PROCEDURE ,(if (false-expression? arg context) #f arg))))))
 
-(define-option 'PRINT-ENTITY-PROCEDURE #f
-  (lambda (option context)
-    (one-required-argument option
-      (lambda (arg)
-       `(PRINT-ENTITY-PROCEDURE
-         ,(if (false-expression? arg context) #f arg))))))
-
 (define-option 'TYPE #f
   (lambda (option context)
     context
@@ -558,9 +541,8 @@ differences:
 
 (define-record-type <structure>
     (make-structure context conc-name constructors keyword-constructors copier
-                   predicate print-procedure print-entity-procedure
-                   physical-type named? type-descriptor tag-expression
-                   safe-accessors? offset slots)
+                   predicate print-procedure physical-type named?
+                   type-descriptor tag-expression safe-accessors? offset slots)
     structure?
   (context structure/context)
   (conc-name structure/conc-name)
@@ -569,7 +551,6 @@ differences:
   (copier structure/copier)
   (predicate structure/predicate)
   (print-procedure structure/print-procedure)
-  (print-entity-procedure structure/print-entity-procedure)
   (physical-type structure/physical-type)
   (named? structure/tagged?)
   (type-descriptor structure/type-descriptor)
@@ -806,9 +787,7 @@ differences:
   (let ((type-name (structure/type-descriptor structure))
        (tag-expression (structure/tag-expression structure))
        (slots (structure/slots structure))
-       (context (structure/context structure))
-       (print-procedure (structure/print-procedure structure))
-       (print-entity-procedure (structure/print-entity-procedure structure)))
+       (context (structure/context structure)))
     (let ((name (symbol->string (parser-context/name context)))
          (field-names (map slot/name slots))
          (inits
@@ -823,34 +802,36 @@ differences:
               `(,(absolute 'MAKE-RECORD-TYPE context)
                 ',name
                 ',field-names
-                (LIST ,@inits)
-                ,(close print-procedure context)
-                ,@(if print-entity-procedure
-                      (list (close print-entity-procedure context))
-                      '()))
+                (LIST ,@inits))
               `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
                 ',(structure/physical-type structure)
                 ',name
                 '#(,@field-names)
                 '#(,@(map slot/index slots))
                 (VECTOR ,@inits)
-                ,(if (structure/tagged? structure)
-                     (close print-procedure context)
-                     '#F)
+                ;; This field was the print-procedure, no longer used.
+                ;; It should be removed after 9.3 is released.
+                #f
                 ,(if (and tag-expression
                           (not (eq? tag-expression type-name)))
                      (close tag-expression context)
                      '#F)
                 ',(+ (if (structure/tagged? structure) 1 0)
                      (structure/offset structure)
-                     (length slots))
-                ,@(if (and (structure/tagged? structure)
-                           print-entity-procedure)
-                      (list (close print-entity-procedure context))
-                      '()))))
+                     (length slots)))))
        ,@(if (and tag-expression
                   (not (eq? tag-expression type-name)))
              `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context)
                 ,(close tag-expression context)
                 ,type-name))
-             '())))))
\ No newline at end of file
+             '())))))
+
+(define (printer-definitions structure)
+  (if (and (structure/predicate structure)
+          (or (structure/record-type? structure)
+              (structure/tagged? structure)))
+      (let ((context (structure/context structure)))
+       `((define-unparser-method
+           ,(close (structure/predicate structure) context)
+           ,(close (structure/print-procedure structure) context))))
+      '()))
\ No newline at end of file

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index f264c302d68b9a06aedd230e1ff7f07efd83bafb..566bfad9215dd11a1d339b95d3a7719d0289b716 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -737,10 +737,7 @@ USA.
                 (make-prefix-node prefix
                                   (numerical-walk (cadr object)
                                                   list-depth))
-                (let ((unparser (unparse-list/unparser object)))
-                  (if unparser
-                      (walk-custom unparser object list-depth)
-                      (walk-pair object list-depth))))))
+                (walk-pair object list-depth))))
          ((symbol? object)
           (if (or (get-param:pp-uninterned-symbols-by-name?)
                   (interned-symbol? object))
@@ -759,12 +756,9 @@ USA.
          ((vector? object)
           (if (zero? (vector-length object))
               (walk-custom unparse-object object list-depth)
-              (let ((unparser (unparse-vector/unparser object)))
-                (if unparser
-                    (walk-custom unparser object list-depth)
-                    (make-prefix-node "#"
-                                      (walk-pair (vector->list object)
-                                                 list-depth))))))
+              (make-prefix-node "#"
+                                (walk-pair (vector->list object)
+                                           list-depth))))
          ((primitive-procedure? object)
           (if (get-param:pp-primitives-by-name?)
               (primitive-procedure-name object)
@@ -817,8 +811,7 @@ USA.
                 (make-list-node
                  (numerical-walk (car pair) list-depth)
                  (let ((list-breadth (+ list-breadth 1)))
-                   (if (and (pair? (cdr pair))
-                            (not (unparse-list/unparser (cdr pair))))
+                   (if (pair? (cdr pair))
                        (loop (cdr pair) list-breadth)
                        (make-list-node
                         "."
@@ -902,11 +895,8 @@ USA.
                 (cadr object)
                 (advance half-pointer (update-queue queue '(CDR CAR)))
                 list-depth))
-              (let ((unparser (unparse-list/unparser object)))
-                (if unparser
-                    (walk-custom unparser object list-depth)
-                    (walk-pair-terminating object half-pointer/queue
-                                           list-depth))))))
+              (walk-pair-terminating object half-pointer/queue
+                                     list-depth))))
        ((symbol? object)
         (if (or (get-param:pp-uninterned-symbols-by-name?)
                 (interned-symbol? object))
@@ -922,14 +912,11 @@ USA.
        ((vector? object)
         (if (zero? (vector-length object))
             (walk-custom unparse-object object list-depth)
-            (let ((unparser (unparse-vector/unparser object)))
-              (if unparser
-                  (walk-custom unparser object list-depth)
-                  (make-prefix-node
-                   "#"
-                   (walk-vector-terminating
-                    (vector->list object)
-                    half-pointer/queue list-depth))))))
+            (make-prefix-node
+             "#"
+             (walk-vector-terminating
+              (vector->list object)
+              half-pointer/queue list-depth))))
        ((primitive-procedure? object)
         (if (get-param:pp-primitives-by-name?)
             (primitive-procedure-name object)
@@ -975,8 +962,7 @@ USA.
                         (car pair) half-pointer/queue list-depth)))
                  (let ((list-breadth (+ list-breadth 1)))
                    (if
-                    (and (pair? (cdr pair))
-                         (not (unparse-list/unparser (cdr pair))))
+                    (pair? (cdr pair))
                     (let ((half-pointer/queue
                            (advance
                             (car half-pointer/queue)
@@ -1041,21 +1027,7 @@ USA.
                        (circularity-string (cdr half-pointer/queue))
                        (numerical-walk-terminating
                         (car pair) half-pointer/queue list-depth)))
-                 (let ((list-breadth (+ list-breadth 1)))
-                   (if (not (unparse-list/unparser (cdr pair)))
-                       (loop (cdr pair) list-breadth)
-                       (make-list-node
-                        "."
-                        (make-singleton-list-node
-                         (if (let ((limit
-                                    (get-param:unparser-list-breadth-limit)))
-                               (and limit
-                                    (>= list-breadth limit)
-                                    (no-highlights? pair)))
-                             "..."
-                             (numerical-walk-terminating
-                              (cdr pair)
-                              half-pointer/queue list-depth)))))))))))))
+                 (loop (cdr pair) (+ list-breadth 1)))))))))
 \f
 ;;;; These procedures allow the walkers to interact with the queue.
 

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index b59e068fd2e1e79945a8cdcbaea8fd471023acc3..3588c244a3d07b3d34349b008ad0cdd05700b07c 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -99,6 +99,8 @@ USA.
 (define (make-record-type type-name field-names
                          #!optional
                          default-inits unparser-method entity-unparser-method)
+  ;; The unparser-method and entity-unparser-method arguments should be removed
+  ;; after the 9.3 release.
   (let ((caller 'MAKE-RECORD-TYPE))
     (if (not (list-of-unique-symbols? field-names))
        (error:not-a list-of-unique-symbols? field-names caller))
@@ -117,19 +119,20 @@ USA.
       (%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)))
-      (%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))
-      (if (and entity-unparser-method
-              (not (default-object? entity-unparser-method)))
-         (set-record-type-entity-unparser-method! record-type
-                                                  entity-unparser-method))
+      (let ((predicate
+            (lambda (object)
+              (%tagged-record? tag object)))
+           (entity-predicate
+            (lambda (object)
+              (%tagged-record-entity? tag object))))
+       (%set-record-type-predicate! record-type predicate)
+       (%set-record-type-entity-predicate! record-type entity-predicate)
+       (if (and unparser-method
+                (not (default-object? unparser-method)))
+           (define-unparser-method predicate unparser-method))
+       (if (and entity-unparser-method
+                (not (default-object? entity-unparser-method)))
+           (define-unparser-method entity-predicate entity-unparser-method)))
       record-type)))
 
 (define (record-type? object)
@@ -564,7 +567,7 @@ USA.
 (define (set-record-type-describer! record-type describer)
   (define-pp-describer (record-predicate record-type)
     describer))
-
+\f
 (define (set-record-type-entity-unparser-method! record-type method)
   (define-unparser-method (record-entity-predicate record-type)
     method))
@@ -579,24 +582,20 @@ USA.
   (set! rtd:structure-type
        (make-record-type "structure-type"
                          '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES
-                                         DEFAULT-INITS UNPARSER-METHOD TAG
-                                         LENGTH ENTITY-UNPARSER-METHOD)))
+                                         DEFAULT-INITS TAG LENGTH)))
   (set! make-define-structure-type
        (let ((constructor (record-constructor rtd:structure-type)))
          (lambda (physical-type name field-names field-indexes default-inits
-                                unparser-method tag length
-                                #!optional entity-unparser-method)
+                                unparser-method tag length)
+           ;; unparser-method arg should be removed after 9.3 is released.
+           (declare (ignore unparser-method))
            (constructor physical-type
                         name
                         field-names
                         field-indexes
                         default-inits
-                        unparser-method
                         tag
-                        length
-                        (if (default-object? entity-unparser-method)
-                            #f
-                            entity-unparser-method)))))
+                        length))))
   (set! structure-type?
        (record-predicate rtd:structure-type))
   (set! structure-type/physical-type
@@ -609,18 +608,10 @@ USA.
        (record-accessor rtd:structure-type 'FIELD-INDEXES))
   (set! structure-type/default-inits
        (record-accessor rtd:structure-type 'DEFAULT-INITS))
-  (set! structure-type/unparser-method
-       (record-accessor rtd:structure-type 'UNPARSER-METHOD))
-  (set! set-structure-type/unparser-method!
-       (record-modifier rtd:structure-type 'UNPARSER-METHOD))
   (set! structure-type/tag
        (record-accessor rtd:structure-type 'TAG))
   (set! structure-type/length
        (record-accessor rtd:structure-type 'LENGTH))
-  (set! structure-type/entity-unparser-method
-       (record-accessor rtd:structure-type 'ENTITY-UNPARSER-METHOD))
-  (set! set-structure-type/entity-unparser-method!
-       (record-modifier rtd:structure-type 'ENTITY-UNPARSER-METHOD))
   unspecific)
 \f
 (define rtd:structure-type)
@@ -635,8 +626,6 @@ USA.
 (define set-structure-type/unparser-method!)
 (define structure-type/tag)
 (define structure-type/length)
-(define structure-type/entity-unparser-method)
-(define set-structure-type/entity-unparser-method!)
 
 (define-integrable (structure-type/field-index type field-name)
   (vector-ref (structure-type/field-indexes type)
@@ -660,14 +649,6 @@ USA.
            i
            (loop (fix:+ i 1)))))))
 \f
-(define (structure-tag/unparser-method tag physical-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)
-  (and (structure-type-tag? tag physical-type)
-       (structure-type/entity-unparser-method (tag->structure-type tag))))
-
 (define (named-structure? object)
   (or (named-list? object)
       (named-vector? object)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 171d75bc0cf8f8573833066e881c6ec2387cb57a..ec6d3faa5c7ca28c0d2af1411733a19ca2750e83 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3785,9 +3785,6 @@ USA.
          error:no-such-slot
          error:uninitialized-slot
          record-type-field-index)
-  (export (runtime unparser)
-         structure-tag/entity-unparser-method
-         structure-tag/unparser-method)
   (export (runtime predicate-metadata)
          cleanup-boot-time-record-predicates!)
   (export (runtime predicate-tagging)
@@ -4852,9 +4849,7 @@ USA.
          get-param:unparser-list-breadth-limit
          get-param:unparser-list-depth-limit
          make-unparser-state
-         unparse-list/prefix-pair?
-         unparse-list/unparser
-         unparse-vector/unparser)
+         unparse-list/prefix-pair?)
   (export (runtime record)
          (rtd:unparser-state <context>)))
 

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 79d7c384914eda0ed74adcfc00fa1dfa025d2d00..39783ab9db7280d173a0f4aaa2905309d13e789e 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -568,24 +568,6 @@ USA.
           (loop (fix:- index 1))))))
 \f
 (define (unparse/vector vector context)
-  (let ((method (unparse-vector/unparser vector)))
-    (if method
-        (invoke-user-method method vector context)
-        (unparse-vector/normal vector context))))
-
-(define (unparse-vector/unparser vector)
-  (and (fix:> (vector-length vector) 0)
-       (let ((tag (safe-vector-ref vector 0)))
-         (or (structure-tag/unparser-method tag 'VECTOR)
-             ;; Check the global tagging table too.
-             (unparser/tagged-vector-method tag)))))
-
-(define (unparse-vector/entity-unparser vector)
-  (and (fix:> (vector-length vector) 0)
-       (structure-tag/entity-unparser-method (safe-vector-ref vector 0)
-                                             'VECTOR)))
-
-(define (unparse-vector/normal vector context)
   (limit-unparse-depth context
     (lambda (context*)
       (let ((end (vector-length vector)))
@@ -653,8 +635,6 @@ USA.
 (define (unparse/pair pair context)
   (cond ((unparse-list/prefix-pair? pair)
          => (lambda (prefix) (unparse-list/prefix-pair prefix pair context)))
-        ((unparse-list/unparser pair)
-         => (lambda (method) (invoke-user-method method pair context)))
         ((and (get-param:unparse-streams?) (stream-pair? pair))
          (unparse-list/stream-pair pair context))
         (else
@@ -678,33 +658,18 @@ USA.
 
 (define (unparse-tail l n context)
   (cond ((pair? l)
-         (let ((method (unparse-list/unparser l)))
-           (if method
-               (begin
-                 (*unparse-string " . " context)
-                 (invoke-user-method method l context))
-               (begin
-                 (*unparse-char #\space context)
-                 (*unparse-object (safe-car l) context)
-                 (if (let ((limit (context-list-breadth-limit context)))
-                       (and limit
-                            (>= n limit)
-                            (pair? (safe-cdr l))))
-                     (*unparse-string " ..." context)
-                     (unparse-tail (safe-cdr l) (+ n 1) context))))))
+        (*unparse-char #\space context)
+        (*unparse-object (safe-car l) context)
+        (if (let ((limit (context-list-breadth-limit context)))
+              (and limit
+                   (>= n limit)
+                   (pair? (safe-cdr l))))
+            (*unparse-string " ..." context)
+            (unparse-tail (safe-cdr l) (+ n 1) context)))
         ((not (null? l))
          (*unparse-string " . " context)
          (*unparse-object l context))))
-
-(define (unparse-list/unparser pair)
-  (let ((tag (safe-car pair)))
-    (or (structure-tag/unparser-method tag 'LIST)
-        ;; Check the global tagging table too.
-        (unparser/tagged-pair-method tag))))
 \f
-(define (unparse-list/entity-unparser pair)
-  (structure-tag/entity-unparser-method (safe-car pair) 'LIST))
-
 (define (unparse-list/prefix-pair prefix pair context)
   (*unparse-string prefix context)
   (*unparse-object (safe-car (safe-cdr pair)) context))
@@ -910,12 +875,6 @@ USA.
                  (else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
         ((get-param:unparse-with-maximum-readability?)
          (*unparse-readable-hash entity context))
-        ((or (and (vector? (%entity-extra entity))
-                  (unparse-vector/entity-unparser (%entity-extra entity)))
-             (and (pair? (%entity-extra entity))
-                  (unparse-list/entity-unparser (%entity-extra entity))))
-         => (lambda (method)
-              (invoke-user-method method entity context)))
         (else (plain 'ENTITY))))
 
 (define (unparse/promise promise context)