Implement user-defined unparser methods for entities.

New DEFINE-STRUCTURE option PRINT-ENTITY-PROCEDURE is like
PRINT-PROCEDURE, except that the second argument to the procedure
is not a structure instance itself but an entity whose extra is a
structure instance.

New procedure SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD! is like
SET-RECORD-TYPE-UNPARSER-METHOD! with the same difference.

New optional argument to MAKE-RECORD-TYPE specifies an entity
unparser method.

Existing code should be unaffected by the changes, including
existing compiled code that used DEFINE-STRUCTURE.

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index ece048be931572d3e7d4046a194ae374c7e1479f..317bfc51dc438a58dc4ca9aab158acce549dbec3 100644 (file)
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -56,6 +56,9 @@ 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
@@ -114,6 +117,8 @@ 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))
@@ -132,7 +137,8 @@ differences:
            (check-for-illegal-untyped named-option initial-offset-option))
        (if (not tagged?)
            (check-for-illegal-untagged predicate-option
-                                       print-procedure-option))
+                                       print-procedure-option
+                                       print-entity-procedure-option))
        (do ((slots slots (cdr slots))
             (index (if tagged? (+ offset 1) offset) (+ index 1)))
            ((not (pair? slots)))
@@ -159,6 +165,9 @@ 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)
@@ -211,7 +220,9 @@ differences:
     (if initial-offset-option
        (lose initial-offset-option))))
 
-(define (check-for-illegal-untagged predicate-option print-procedure-option)
+(define (check-for-illegal-untagged predicate-option
+                                   print-procedure-option
+                                   print-entity-procedure-option)
   (let ((test
         (lambda (option)
           (if (and option
@@ -221,7 +232,8 @@ differences:
               (error "Structure option illegal for unnamed structure:"
                      (option/original option))))))
     (test predicate-option)
-    (test print-procedure-option)))
+    (test print-procedure-option)
+    (test print-entity-procedure-option)))
 
 (define (compute-constructors constructor-options
                              keyword-constructor-options
@@ -425,6 +437,13 @@ 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
@@ -538,9 +557,9 @@ differences:
 
 (define-record-type <structure>
     (make-structure context conc-name constructors keyword-constructors copier
-                   predicate print-procedure physical-type named?
-                   type-descriptor tag-expression safe-accessors? offset
-                   slots)
+                   predicate print-procedure print-entity-procedure
+                   physical-type named? type-descriptor tag-expression
+                   safe-accessors? offset slots)
     structure?
   (context structure/context)
   (conc-name structure/conc-name)
@@ -549,6 +568,7 @@ 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)
@@ -792,7 +812,8 @@ differences:
        (tag-expression (structure/tag-expression structure))
        (slots (structure/slots structure))
        (context (structure/context structure))
-       (print-procedure (structure/print-procedure structure)))
+       (print-procedure (structure/print-procedure structure))
+       (print-entity-procedure (structure/print-entity-procedure structure)))
     (let ((name (symbol->string (parser-context/name context)))
          (field-names (map slot/name slots))
          (inits
@@ -805,7 +826,8 @@ differences:
                 ',name
                 ',field-names
                 (LIST ,@inits)
-                ,(close print-procedure context))
+                ,(close print-procedure context)
+                ,(close print-entity-procedure context))
               `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
                 ',(structure/physical-type structure)
                 ',name
@@ -821,7 +843,10 @@ differences:
                      '#F)
                 ',(+ (if (structure/tagged? structure) 1 0)
                      (structure/offset structure)
-                     (length slots)))))
+                     (length slots))
+                ,(if (structure/tagged? structure)
+                     (close print-entity-procedure context)
+                     '#F))))
        ,@(if (and tag-expression
                   (not (eq? tag-expression type-name)))
              `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context)

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 152aec62f185d806f05891f437ebd016450dbc30..1741475d67ab69b51b91c128e3ffbbe4b1fd1ebf 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -63,6 +63,7 @@ USA.
 \f
 (define record-type-type-tag)
 (define unparse-record)
+(define record-entity-unparser)
 (define record-description)
 
 (define (initialize-record-type-type!)
@@ -104,6 +105,15 @@ USA.
                     (write-char #\space port)
                     (write (dispatch-tag-contents tag) port))))
                (else record-method))))))
+  (set! record-entity-unparser
+       (make-generic-procedure 1 'RECORD-ENTITY-UNPARSER))
+  (set-generic-procedure-default-generator! record-entity-unparser
+    (let ((default-method
+          (let ((method (standard-unparser-method 'ENTITY #f)))
+            (lambda (extra) extra method))))
+      (lambda (generic tags)
+       generic tags                    ;ignore
+       default-method)))
   (set! %set-record-type-default-inits!
        %set-record-type-default-inits!/after-boot)
   (set! set-record-type-unparser-method!
@@ -131,7 +141,8 @@ USA.
                        (cons (list i (%record-ref record i)) d)))))))))
 \f
 (define (make-record-type type-name field-names
-                         #!optional default-inits unparser-method)
+                         #!optional
+                         default-inits unparser-method entity-unparser-method)
   (let ((caller 'MAKE-RECORD-TYPE))
     (guarantee-list-of-unique-symbols field-names caller)
     (let* ((names ((ucode-primitive list->vector) field-names))
@@ -149,6 +160,9 @@ USA.
          (%set-record-type-default-inits! record-type default-inits caller))
       (if (not (default-object? unparser-method))
          (set-record-type-unparser-method! record-type unparser-method))
+      (if (not (default-object? entity-unparser-method))
+         (set-record-type-entity-unparser-method! record-type
+                                                  entity-unparser-method))
       record-type)))
 
 (define (record-type? object)
@@ -235,6 +249,16 @@ USA.
   ((vector-ref (%record-type-default-inits record-type)
               (fix:- field-name-index 1))))
 
+(define (record-type-extension record-type)
+  (guarantee-record-type record-type 'RECORD-TYPE-EXTENSION)
+  (%record-type-extension record-type))
+
+(define (set-record-type-extension! record-type extension)
+  (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!)
+  (%set-record-type-extension! record-type extension))
+\f
+;;;; Unparser Methods
+
 (define set-record-type-unparser-method!
   (named-lambda (set-record-type-unparser-method!/booting record-type method)
     (let loop ((ms deferred-unparser-methods))
@@ -264,13 +288,31 @@ USA.
              generic
              (and (eq? (cadr tags) tag) method)))))))
 
-(define (record-type-extension record-type)
-  (guarantee-record-type record-type 'RECORD-TYPE-EXTENSION)
-  (%record-type-extension record-type))
+;;; It's not kosher to use this during the cold load.
 
-(define (set-record-type-extension! record-type extension)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!)
-  (%set-record-type-extension! record-type extension))
+(define (set-record-type-entity-unparser-method! record-type method)
+  (guarantee-record-type record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!)
+  (if method
+      (guarantee-unparser-method method 'SET-RECORD-TYPE-UNPARSER-METHOD!))
+  (let ((tag (%record-type-dispatch-tag record-type)))
+    (remove-generic-procedure-generators record-entity-unparser (list tag))
+    (if method
+       ;; Kludge to make generic dispatch work.
+       (let ((method (lambda (extra) extra method)))
+         (add-generic-procedure-generator record-entity-unparser
+           (lambda (generic tags)
+             generic
+             (and (eq? (car tags) tag) method)))))))
+
+;;; To mimic UNPARSE-RECORD.  Dunno whether anyone cares.
+
+(define (unparse-record-entity state entity)
+  (guarantee-unparser-state state 'UNPARSE-RECORD-ENTITY)
+  (if (entity? entity)
+      (guarantee-record (entity-extra entity) 'UNPARSE-RECORD-ENTITY)
+      (error:wrong-type-argument entity "record entity"
+                                'UNPARSE-RECORD-ENTITY))
+  ((record-entity-unparser (entity-extra entity)) state entity))
 \f
 (define (record-constructor record-type #!optional field-names)
   (guarantee-record-type record-type 'RECORD-CONSTRUCTOR)
@@ -487,29 +529,17 @@ USA.
 \f
 ;;;; Runtime support for DEFINE-STRUCTURE
 
-(define rtd:structure-type)
-(define make-define-structure-type)
-(define structure-type?)
-(define structure-type/physical-type)
-(define structure-type/name)
-(define structure-type/field-names)
-(define structure-type/field-indexes)
-(define structure-type/default-inits)
-(define structure-type/unparser-method)
-(define set-structure-type/unparser-method!)
-(define structure-type/tag)
-(define structure-type/length)
-
 (define (initialize-structure-type-type!)
   (set! rtd:structure-type
        (make-record-type "structure-type"
                          '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES
                                          DEFAULT-INITS UNPARSER-METHOD TAG
-                                         LENGTH)))
+                                         LENGTH ENTITY-UNPARSER-METHOD)))
   (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)
+                                unparser-method tag length
+                                #!optional entity-unparser-method)
            (constructor physical-type
                         name
                         field-names
@@ -517,7 +547,10 @@ USA.
                         default-inits
                         unparser-method
                         tag
-                        length))))
+                        length
+                        (if (default-object? entity-unparser-method)
+                            #f
+                            entity-unparser-method)))))
   (set! structure-type?
        (record-predicate rtd:structure-type))
   (set! structure-type/physical-type
@@ -538,7 +571,26 @@ USA.
        (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)
+(define make-define-structure-type)
+(define structure-type?)
+(define structure-type/physical-type)
+(define structure-type/name)
+(define structure-type/field-names)
+(define structure-type/field-indexes)
+(define structure-type/default-inits)
+(define structure-type/unparser-method)
+(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)
@@ -567,6 +619,11 @@ USA.
     (and type
         (structure-type/unparser-method type))))
 
+(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))))
+
 (define (named-structure? object)
   (cond ((record? object) #t)
        ((vector? object)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 19176487b47c35f8863541b57c29d6f3ed0ddf9a..0a735f42c4f712cf6ed55cd455212f971de4161b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3222,6 +3222,7 @@ USA.
          record-constructor
          record-copy
          record-description
+         record-entity-unparser
          record-keyword-constructor
          record-modifier
          record-predicate
@@ -3237,12 +3238,15 @@ USA.
          record-updater
          record?
          set-record-type-default-inits!
+         set-record-type-entity-unparser-method!
          set-record-type-extension!
          set-record-type-unparser-method!
-         unparse-record)
+         unparse-record
+         unparse-record-entity)
   (export (runtime record-slot-access)
          record-type-field-index)
   (export (runtime unparser)
+         structure-tag/entity-unparser-method
          structure-tag/unparser-method)
   (initialization (initialize-package!)))
 

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 5815a789c3ab56d4ebb5304f24f3e053826bcb51..01413a599140a3f4e9beb0be53d9a2228dfa42a5 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -352,7 +352,7 @@ USA.
      (*unparse-string "#[keyword ")
      (unparse-symbol-name s)
      (*unparse-char #\]))))
-
+\f
 (define (unparse-symbol-name s)
   (if (or (string-find-next-char-in-set
           s
@@ -476,6 +476,11 @@ USA.
             ;; 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)
   (limit-unparse-depth
    (lambda ()
@@ -558,6 +563,9 @@ USA.
        ;; Check the global tagging table too.
        (unparser/tagged-pair-method tag))))
 
+(define (unparse-list/entity-unparser pair)
+  (structure-tag/entity-unparser-method (safe-car pair) 'LIST))
+
 (define (unparse-list/prefix-pair prefix pair)
   (*unparse-string prefix)
   (*unparse-object (safe-car (safe-cdr pair))))
@@ -707,7 +715,7 @@ USA.
                 (unparse/flonum ((ucode-primitive floating-vector-ref) v i)))
               (if (< limit length)
                   (*unparse-string " ..."))))))))
-
+\f
 (define (unparse/entity entity)
 
   (define (plain name)
@@ -729,5 +737,18 @@ USA.
                       (compiled-procedure/name proc))
                  => named-arity-dispatched-procedure)
                 (else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
-       (else
-        (plain 'ENTITY))))
\ No newline at end of file
+       (*unparse-with-maximum-readability?*
+        (*unparse-readable-hash entity))
+       ((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))
+       ((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)))
+       (else (plain 'ENTITY))))
\ No newline at end of file