Major refactor to how printer methods work.

* Replaced define-unparser-method with define-print-method.  A print method is
  an ordinary procedure that accepts an object and an output port as its
  arguments and prints whatever it wants to.  The translation layer required by
  older unparser methods is no longer needed.

* New standard-print-method is roughly equivalent to simple-unparser-method.

* New bracketed-print-method is roughly equivalent to standard-unparser-method.

* Changed the printer to handle standard-print-method specially when detecting
  cycles and shared structure, so that an object using that print method has its
  parts walked when looking for shared/cyclic structure.

diff --git a/src/compiler/base/blocks.scm b/src/compiler/base/blocks.scm
index 6b9e4230e0690265994131b0f13ad21ca5432796..fdb904053523308788ff299560fc5a7da1af357b 100644 (file)
--- a/src/compiler/base/blocks.scm
+++ b/src/compiler/base/blocks.scm
@@ -113,7 +113,7 @@ from the continuation, and then "glued" into place afterwards.
     block))
 \f
 (define-vector-tag-unparser block-tag
-  (simple-unparser-method "LIAR:block"
+  (standard-print-method "LIAR:block"
     (lambda (block)
       (cons (enumeration/index->name block-types (block-type block))
            (let ((procedure (block-procedure block)))

diff --git a/src/compiler/base/ctypes.scm b/src/compiler/base/ctypes.scm
index feb28518a1eb95df563e6f365969ec3449535367..fed668187ef05e2bcf22bd4b77caef3eb2886887 100644 (file)
--- a/src/compiler/base/ctypes.scm
+++ b/src/compiler/base/ctypes.scm
@@ -59,7 +59,7 @@ USA.
     (make-scfg application '())))
 
 (define-vector-tag-unparser application-tag
-  (simple-unparser-method
+  (standard-print-method
    (lambda (application)
      (case (application-type application)
        ((COMBINATION) "LIAR:combination")

diff --git a/src/compiler/base/enumer.scm b/src/compiler/base/enumer.scm
index 1bc378d44eccbff46b02d5cb477a80fb57b24ef8..d4aee06a152bf81b78c4af895940917ac1b24bb5 100644 (file)
--- a/src/compiler/base/enumer.scm
+++ b/src/compiler/base/enumer.scm
@@ -38,7 +38,7 @@ USA.
 (define-structure (enumerand
                   (conc-name enumerand/)
                   (print-procedure
-                   (simple-unparser-method "LIAR:enumerand"
+                   (standard-print-method "LIAR:enumerand"
                      (lambda (enumerand)
                        (list (enumerand/name enumerand))))))
   (enumeration false read-only true)

diff --git a/src/compiler/base/lvalue.scm b/src/compiler/base/lvalue.scm
index 2f9a4f8f4aa4a9bbefc631a11c5e7df3c1bab6b9..bdec69508467509f7a6232fdead365f85ac37bd8 100644 (file)
--- a/src/compiler/base/lvalue.scm
+++ b/src/compiler/base/lvalue.scm
@@ -98,7 +98,7 @@ USA.
       (variable-normal-offset variable)))
 
 (define-vector-tag-unparser variable-tag
-  (simple-unparser-method "LIAR:variable"
+  (standard-print-method "LIAR:variable"
     (lambda (variable)
       (list (variable-name variable)))))
 

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 1ff8c182899b3521cb2125a2f177e4d81ff9c694..ccf95248155f91d28b86e728887f1ea47978ec31 100644 (file)
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -46,10 +46,9 @@ USA.
   (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
     (set-vector-tag-%unparser!
      root-tag
-     (simple-unparser-method
+     (standard-print-method
       (lambda (object)
-       (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))
-      #f))
+       (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
     (named-lambda (make-vector-tag parent name enumeration)
       (let ((tag
             (%make-vector-tag (or parent root-tag)

diff --git a/src/compiler/base/proced.scm b/src/compiler/base/proced.scm
index 98f117444f28f6abda593cd0e3d78fadda437470..77d0786ac31f14b2fab90e5b99a98ad3cd3e8407 100644 (file)
--- a/src/compiler/base/proced.scm
+++ b/src/compiler/base/proced.scm
@@ -108,7 +108,7 @@ USA.
         (lambda (procedure)
           (enumeration/index->name continuation-types
                                    (procedure-type procedure)))))
-    (simple-unparser-method
+    (standard-print-method
      (lambda (procedure)
        (if (eq? (get-type procedure) 'PROCEDURE)
           "LIAR:procedure"

diff --git a/src/compiler/base/rvalue.scm b/src/compiler/base/rvalue.scm
index 556dc5f0f910798bd248e3c4f18c1e6ff28a5d4c..7b3621cfe21f528e775306ce0f2dd8382fae33f5 100644 (file)
--- a/src/compiler/base/rvalue.scm
+++ b/src/compiler/base/rvalue.scm
@@ -96,7 +96,7 @@ USA.
          constant))))
 
 (define-vector-tag-unparser constant-tag
-  (simple-unparser-method "LIAR:constant"
+  (standard-print-method "LIAR:constant"
     (lambda (constant)
       (list (constant-value constant)))))
 
@@ -114,7 +114,7 @@ USA.
   (make-rvalue reference-tag block lvalue safe?))
 
 (define-vector-tag-unparser reference-tag
-  (simple-unparser-method "LIAR:reference"
+  (standard-print-method "LIAR:reference"
     (lambda (reference)
       (list (variable-name (reference-lvalue reference))))))
 
@@ -150,7 +150,7 @@ USA.
   (make-rvalue unassigned-test-tag block lvalue))
 
 (define-vector-tag-unparser unassigned-test-tag
-  (simple-unparser-method "LIAR:unassigned-test"
+  (standard-print-method "LIAR:unassigned-test"
     (lambda (unassigned-test)
       (list (unassigned-test-lvalue unassigned-test)))))
 

diff --git a/src/compiler/base/subprb.scm b/src/compiler/base/subprb.scm
index 64fafacb786bd66ee71405930ccc59d99ad62549..e314c3b495d0da9c97703d07dfbbf6e34d6834a3 100644 (file)
--- a/src/compiler/base/subprb.scm
+++ b/src/compiler/base/subprb.scm
@@ -114,7 +114,7 @@ known that the continuation need not be used.
                   (constructor virtual-continuation/%make)
                   (conc-name virtual-continuation/)
                   (print-procedure
-                   (simple-unparser-method "LIAR:virtual-continuation"
+                   (standard-print-method "LIAR:virtual-continuation"
                      (lambda (continuation)
                        (let ((type (virtual-continuation/type continuation)))
                          (if type

diff --git a/src/compiler/rtlbase/rtlobj.scm b/src/compiler/rtlbase/rtlobj.scm
index 1de11688b7e7c25a925798c9fa518f8bbbf577b3..b4c4fdfd464d2b02b6ee75b914579d0c2cb452ff 100644 (file)
--- a/src/compiler/rtlbase/rtlobj.scm
+++ b/src/compiler/rtlbase/rtlobj.scm
@@ -33,7 +33,7 @@ USA.
                   (constructor make-rtl-expr
                                (rgraph label entry-edge debugging-info))
                   (print-procedure
-                   (simple-unparser-method "LIAR:rtl-expr"
+                   (standard-print-method "LIAR:rtl-expr"
                      (lambda (expression)
                        (list (rtl-expr/label expression))))))
   (rgraph false read-only true)
@@ -53,7 +53,7 @@ USA.
                                        debugging-info
                                        next-continuation-offset stack-leaf?))
                   (print-procedure
-                   (simple-unparser-method "LIAR:rtl-procedure"
+                   (standard-print-method "LIAR:rtl-procedure"
                      (lambda (procedure)
                        (list (rtl-procedure/label procedure))))))
   (rgraph false read-only true)
@@ -87,7 +87,7 @@ USA.
                                        next-continuation-offset
                                        debugging-info))
                   (print-procedure
-                   (simple-unparser-method "LIAR:rtl-continuation"
+                   (standard-print-method "LIAR:rtl-continuation"
                      (lambda (continuation)
                        (list (rtl-continuation/label continuation))))))
   (rgraph false read-only true)

diff --git a/src/compiler/rtlbase/valclass.scm b/src/compiler/rtlbase/valclass.scm
index 0c5fad0112e49e6d1c5702460e18f8f7e173b8dc..df7bd08ac2a81fb8d2a150120daf26e3e0151275 100644 (file)
--- a/src/compiler/rtlbase/valclass.scm
+++ b/src/compiler/rtlbase/valclass.scm
@@ -32,7 +32,7 @@ USA.
                   (conc-name value-class/)
                   (constructor %make-value-class (name parent))
                   (print-procedure
-                   (simple-unparser-method 'VALUE-CLASS
+                   (standard-print-method 'VALUE-CLASS
                      (lambda (class)
                        (list (value-class/name class))))))
   (name false read-only true)

diff --git a/src/compiler/rtlopt/rcseht.scm b/src/compiler/rtlopt/rcseht.scm
index a578b6eb74bfa33eb4c37e0290c7e7205db759e6..fdc655ffcfea79ba61d9a7147a107b54dccae261 100644 (file)
--- a/src/compiler/rtlopt/rcseht.scm
+++ b/src/compiler/rtlopt/rcseht.scm
@@ -47,7 +47,7 @@ USA.
 (define-structure (element
                   (constructor %make-element)
                   (constructor make-element (expression))
-                  (print-procedure (simple-unparser-method "LIAR:element" #f)))
+                  (print-procedure (standard-print-method "LIAR:element")))
   (expression false read-only true)
   (cost false)
   (in-memory? false)

diff --git a/src/compiler/rtlopt/rcserq.scm b/src/compiler/rtlopt/rcserq.scm
index bf5e5467dcc4a993b6daf7508d5b328d0d928564..51f87db5bc993f5934b844d48313e11df7eeab57 100644 (file)
--- a/src/compiler/rtlopt/rcserq.scm
+++ b/src/compiler/rtlopt/rcserq.scm
@@ -32,7 +32,7 @@ USA.
 (define-structure (quantity
                   (copier quantity-copy)
                   (print-procedure
-                   (simple-unparser-method "LIAR:quantity" #f)))
+                   (standard-print-method "LIAR:quantity")))
   (number false read-only true)
   (first-register false)
   (last-register false))

diff --git a/src/compiler/rtlopt/rdflow.scm b/src/compiler/rtlopt/rdflow.scm
index b0742afaf0995dc042f035d1cd4a1d563a4aad86..6e08a6e39d7138ecc201515d40fc9440d976d5c5 100644 (file)
--- a/src/compiler/rtlopt/rdflow.scm
+++ b/src/compiler/rtlopt/rdflow.scm
@@ -72,7 +72,7 @@ USA.
                   (conc-name rnode/)
                   (constructor make-rnode (register))
                   (print-procedure
-                   (simple-unparser-method 'RNODE
+                   (standard-print-method 'RNODE
                      (lambda (rnode)
                        (list (rnode/register rnode))))))
   (register false read-only true)

diff --git a/src/cref/object.scm b/src/cref/object.scm
index f6956190c8b3e3e4435350ba127925e7704984df..f2706bc0939369d9328460b8d3115a859106f5cf 100644 (file)
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -51,7 +51,7 @@ USA.
                   (constructor make-package (name parent))
                   (conc-name package/)
                   (print-procedure
-                   (simple-unparser-method 'package
+                   (standard-print-method 'package
                      (lambda (package)
                        (list (package/name package))))))
   (name #f read-only #t)
@@ -107,7 +107,7 @@ USA.
                   (constructor %make-binding (package name value-cell new?))
                   (conc-name binding/)
                   (print-procedure
-                   (simple-unparser-method 'binding
+                   (standard-print-method 'binding
                      (lambda (binding)
                        (list (binding/name binding)
                              (package/name (binding/package binding)))))))
@@ -170,7 +170,7 @@ USA.
                   (constructor %make-reference (package name))
                   (conc-name reference/)
                   (print-procedure
-                   (simple-unparser-method 'reference
+                   (standard-print-method 'reference
                      (lambda (reference)
                        (list (reference/name reference)
                              (package/name (reference/package reference)))))))

diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm
index df80244791b9613c0465f74d197c7b31f0e6f780..1ecc3af5d72dcbe4e34897bb264fb150c9776d0f 100644 (file)
--- a/src/edwin/artdebug.scm
+++ b/src/edwin/artdebug.scm
@@ -974,10 +974,9 @@ Prefix argument means do not kill the debugger buffer."
 (define-structure (unparser-literal
                   (conc-name unparser-literal/)
                   (print-procedure
-                   (general-unparser-method
-                    (lambda (instance port)
-                      (write-string (unparser-literal/string instance)
-                                    port))))
+                   (lambda (instance port)
+                     (write-string (unparser-literal/string instance)
+                                   port)))
                   (constructor unparser-literal/make))
   string)
 

diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm
index d529a8a8ca7bc4edccb05d3102ab7c312174ab51..ae36ce26ef5885b3ba358797eb18277aa657b433 100644 (file)
--- a/src/edwin/bufwin.scm
+++ b/src/edwin/bufwin.scm
@@ -501,7 +501,7 @@ USA.
 (define-structure (outline
                   (constructor %make-outline)
                   (print-procedure
-                   (standard-unparser-method 'OUTLINE
+                   (bracketed-print-method 'OUTLINE
                      (lambda (outline port)
                        (write-string "index: " port)
                        (write (outline-index-length outline) port)
@@ -569,7 +569,7 @@ USA.
 (define-structure (o3
                   (constructor %make-o3)
                   (print-procedure
-                   (standard-unparser-method 'O3
+                   (bracketed-print-method 'O3
                      (lambda (o3 port)
                        (write-string "index: " port)
                        (write (o3-index o3) port)

diff --git a/src/edwin/calias.scm b/src/edwin/calias.scm
index ec0e3570134ee27d0f71665fc405fa6dc54bc514..be5c33efcf18b236282759d32405ac4d87d49e92 100644 (file)
--- a/src/edwin/calias.scm
+++ b/src/edwin/calias.scm
@@ -217,11 +217,9 @@ USA.
 (define-structure (special-key (constructor %make-special-key)
                               (conc-name special-key/)
                               (print-procedure
-                               (standard-unparser-method 'special-key
-                                 (lambda (key port)
-                                   (write-char #\space port)
-                                   (write-string (special-key/name key)
-                                                 port)))))
+                               (standard-print-method 'special-key
+                                 (lambda (key)
+                                   (list (special-key/name key))))))
   (symbol #f read-only #t)
   (bucky-bits #f read-only #t))
 

diff --git a/src/edwin/clscon.scm b/src/edwin/clscon.scm
index 1b07c78b7aa522e12060be3d9e8021bfa2fc9fb5..7e9887c3bfcbdeeefe060876b49d5cf1550d0b52 100644 (file)
--- a/src/edwin/clscon.scm
+++ b/src/edwin/clscon.scm
@@ -57,7 +57,7 @@ USA.
                  (list->vector (map car transforms))
                  (list->vector (map cdr transforms))
                  (make-vector (length transforms) (lambda () #f))
-                 (standard-unparser-method name #f)
+                 (standard-print-method name)
                  class
                  object-size))
               class))))

diff --git a/src/edwin/comman.scm b/src/edwin/comman.scm
index 345ca6e7e9987144c73fdeea8aea0f0d9824272c..b237842d8c7b1ae4532cd9440782d09dcb0ffb38 100644 (file)
--- a/src/edwin/comman.scm
+++ b/src/edwin/comman.scm
@@ -31,7 +31,7 @@ USA.
 (define-structure (command
                   (constructor %make-command ())
                   (print-procedure
-                   (simple-unparser-method 'COMMAND
+                   (standard-print-method 'COMMAND
                      (lambda (command)
                        (list (command-name command))))))
   name
@@ -103,7 +103,7 @@ USA.
 (define-structure (variable
                   (constructor %make-variable ())
                   (print-procedure
-                   (simple-unparser-method 'VARIABLE
+                   (standard-print-method 'VARIABLE
                      (lambda (variable)
                        (list (variable-name variable))))))
   name

diff --git a/src/edwin/display.scm b/src/edwin/display.scm
index a6cd0556a336365c8c350fc19d2dc30c4af5d673..32f92d75c0f32a7cfb235f82c1199f2654e206b6 100644 (file)
--- a/src/edwin/display.scm
+++ b/src/edwin/display.scm
@@ -33,7 +33,7 @@ USA.
                   (conc-name display-type/)
                   (constructor %make-display-type)
                   (print-procedure
-                   (simple-unparser-method 'DISPLAY-TYPE
+                   (standard-print-method 'DISPLAY-TYPE
                      (lambda (display-type)
                        (list (display-type/name display-type))))))
   (name false read-only true)

diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm
index 2f9deb0d5514e26721235f69b68380317d6c1767..9c7e9e83e9441178a033025c82f6cd1464fd1544 100644 (file)
--- a/src/edwin/editor.scm
+++ b/src/edwin/editor.scm
@@ -443,11 +443,9 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
                   (constructor make-input-event (type operator . operands))
                   (conc-name input-event/)
                   (print-procedure
-                   (standard-unparser-method
-                    'input-event
-                    (lambda (event port)
-                      (write-char #\space port)
-                      (write (input-event/type event) port)))))
+                   (standard-print-method 'input-event
+                     (lambda (event)
+                       (list (input-event/type event))))))
   (type #f read-only #t)
   (operator #f read-only #t)
   (operands #f read-only #t))

diff --git a/src/edwin/edtstr.scm b/src/edwin/edtstr.scm
index 7f9e9588fbf8d3fabbcb42636e7f72a7745fe855..6d07c46c3d7b04d23e7b422fe0cd7fb884604e1f 100644 (file)
--- a/src/edwin/edtstr.scm
+++ b/src/edwin/edtstr.scm
@@ -129,8 +129,8 @@ USA.
 (define (button-name button)
   (symbol->string (button-symbol button)))
 
-(define-unparser-method button?
-  (simple-unparser-method (record-type-name <button>)
+(define-print-method button?
+  (standard-print-method (record-type-name <button>)
     (lambda (button)
       (list (button-symbol button)))))
 

diff --git a/src/edwin/keyparse.scm b/src/edwin/keyparse.scm
index e84764a95bbf30a1684ac614caca975392b28025..eb26d7cb8a3f838e00581a6a592f9cb94e0df0c9 100644 (file)
--- a/src/edwin/keyparse.scm
+++ b/src/edwin/keyparse.scm
@@ -120,7 +120,7 @@ USA.
                   (keyword-constructor make-keyparser-fragment)
                   (conc-name keyparser-fragment/)
                   (print-procedure
-                   (simple-unparser-method 'KEYPARSER-FRAGMENT
+                   (standard-print-method 'KEYPARSER-FRAGMENT
                      (lambda (fragment)
                        (list (keyparser-fragment/keyword fragment))))))
   ;; Keyword that introduces the structure.
@@ -325,7 +325,7 @@ See \\[complete-keyword]."
 (define-structure (keyparser-stack-entry
                   (conc-name keyparser-stack-entry/)
                   (print-procedure
-                   (simple-unparser-method 'KEYPARSER-STACK-ENTRY
+                   (standard-print-method 'KEYPARSER-STACK-ENTRY
                      (lambda (entry)
                        (list (keyparser-stack-entry/keyword entry))))))
   (pattern #f read-only #t)

diff --git a/src/edwin/modes.scm b/src/edwin/modes.scm
index 96cc943e5caf36917b1edd35845f784c749661c0..675f17e7cb5c878553a7d4b371ffe3611afa5d0c 100644 (file)
--- a/src/edwin/modes.scm
+++ b/src/edwin/modes.scm
@@ -33,7 +33,7 @@ USA.
                                (name major? display-name super-mode
                                      %description initialization comtabs))
                   (print-procedure
-                   (simple-unparser-method 'MODE
+                   (standard-print-method 'MODE
                      (lambda (mode)
                        (cons (mode-name mode)
                              (if (mode-major? mode)

diff --git a/src/edwin/struct.scm b/src/edwin/struct.scm
index 2080c6bd45b6d0455ae4381322dfb748104ec69b..9042b967a8b5a72b290a2dc10bbb818153de2686 100644 (file)
--- a/src/edwin/struct.scm
+++ b/src/edwin/struct.scm
@@ -296,7 +296,7 @@ USA.
 (define-structure (mark
                   (constructor make-temporary-mark)
                   (print-procedure
-                   (simple-unparser-method 'MARK
+                   (standard-print-method 'MARK
                      (lambda (mark)
                        (list (or (mark-buffer mark)
                                  (mark-group mark))

diff --git a/src/edwin/window.scm b/src/edwin/window.scm
index b5dfb87015b45a3d15772faa4399a64bda2a9ec9..84f744d0f9f481849851df2a1c227cdbd3d55a3b 100644 (file)
--- a/src/edwin/window.scm
+++ b/src/edwin/window.scm
@@ -364,7 +364,7 @@ USA.
   (vector-set! inferior 4 redisplay-flags))
 
 (unparser/set-tagged-vector-method! %inferior-tag
-  (standard-unparser-method 'INFERIOR
+  (bracketed-print-method 'INFERIOR
     (lambda (inferior port)
       (write-string " " port)
       (write (inferior-window inferior) port)

diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm
index f806cd73ef0c3f6bef0218ffe88a14e2f3076c1b..2e0294346b8ba83981e16498b72f0feff3500cd2 100644 (file)
--- a/src/gdbm/gdbm.scm
+++ b/src/gdbm/gdbm.scm
@@ -289,7 +289,7 @@ USA.
 \f
 (define-structure (gdbf (constructor make-gdbf)
                        (print-procedure
-                        (simple-unparser-method 'GDBF
+                        (standard-print-method 'GDBF
                           (lambda (gdbf)
                             (list (gdbf-filename gdbf))))))
   ;; Note that communicating through this malloced-per-GDBM_FILE

diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm
index fe590f569ae2160af2f111912af5d4b58937bdaf..ec4e7f9f7490cdc16f2ceba4884d311bbb3035a6 100644 (file)
--- a/src/imail/imail-core.scm
+++ b/src/imail/imail-core.scm
@@ -968,7 +968,7 @@ USA.
                   (safe-accessors #t)
                   (constructor #f)
                   (print-procedure
-                   (simple-unparser-method 'HEADER-FIELD
+                   (standard-print-method 'HEADER-FIELD
                      (lambda (header)
                        (list (header-field-name header))))))
   (name #f read-only #t)

diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm
index 1857cbefee6ab2b0d3561d4ee5f7612ab7a945e6..3044bcb0ed9d2b7a2e0e7bf4dc0cb3bcf7dbf65b 100644 (file)
--- a/src/imail/imail-mime.scm
+++ b/src/imail/imail-mime.scm
@@ -753,7 +753,7 @@ USA.
 (define-structure (mime-encoding
                    (conc-name mime-encoding/)
                    (print-procedure
-                    (simple-unparser-method 'MIME-ENCODING
+                    (standard-print-method 'MIME-ENCODING
                       (lambda (encoding)
                         (list (mime-encoding/name encoding)))))
                    (constructor %make-mime-encoding))

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 0c709420bbcaa2e97a4db2f3067fa27754866804..8d86117569b945c3010c72682e1e3a3d47034adb 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -92,14 +92,13 @@ USA.
                     '<= binary-input-port?
                     '<= binary-output-port?)
 
-(define-unparser-method binary-port?
-  (standard-unparser-method
+(define-print-method binary-port?
+  (standard-print-method
    (lambda (port)
      (cond ((binary-i/o-port? port) 'binary-i/o-port)
           ((binary-input-port? port) 'binary-input-port)
           ((binary-output-port? port) 'binary-output-port)
-          (else 'binary-port)))
-   #f))
+          (else 'binary-port)))))
 \f
 ;;;; Bytevector input ports
 

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 0b0d10c0a0c6290711a4dbdaee614dd39d4f69fc..ad39b52600e9d93df9ecf693108eeb112c6dff28 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -303,57 +303,59 @@ USA.
 \f
 ;;;; Printing
 
-(define (define-unparser-method predicate unparser)
-  (defer-boot-action 'unparser-methods
+(define (define-print-method predicate print-method)
+  (defer-boot-action 'print-methods
     (lambda ()
-      (define-unparser-method predicate unparser))))
+      (define-print-method predicate print-method))))
+
+(define (standard-print-method name #!optional get-parts)
+  (%record standard-print-method-tag
+          name
+          (if (and get-parts (not (default-object? get-parts)))
+              get-parts
+              (lambda (object)
+                (declare (ignore object))
+                '()))))
+
+;;; Would have used normal records here but the record abstraction is defined
+;;; after this is needed.
+
+(define (standard-print-method? object)
+  (and (%record? object)
+       (fix:= 3 (%record-length object))
+       (eq? standard-print-method-tag (%record-ref object 0))))
+
+(define (standard-print-method-name spm object)
+  (let ((name (%record-ref spm 1)))
+    (if (procedure? name)
+       (name object)
+       name)))
+
+(define (standard-print-method-parts spm object)
+  ((%record-ref spm 2) object))
+
+(define-integrable standard-print-method-tag
+  '|#[standard-print-method-tag]|)
+
+(define (bracketed-print-method name printer)
+  (lambda (object port)
+    (if (get-param:print-with-maximum-readability?)
+       (begin
+         (write-string "#@" port)
+         (write (hash-object object) port))
+       (begin
+         (write-string "#[" port)
+         (display (if (procedure? name) (name object) name) port)
+         (write-char #\space port)
+         (write (hash-object object) port)
+         (if printer (printer object port))
+         (write-char #\] port)))))
 
 (define (define-pp-describer predicate describer)
   (defer-boot-action 'pp-describers
     (lambda ()
       (define-pp-describer predicate describer))))
 
-(define (unparser-method? object)
-  (and (procedure? object)
-       (procedure-arity-valid? object 2)))
-
-(define (general-unparser-method procedure)
-  (lambda (state object)
-    (with-current-unparser-state state
-      (lambda (port)
-       (if (get-param:print-with-maximum-readability?)
-           (begin
-             (write-string "#@" port)
-             (write (hash-object object) port))
-           (procedure object port))))))
-
-(define (bracketed-unparser-method procedure)
-  (general-unparser-method
-   (lambda (object port)
-     (write-string "#[" port)
-     (procedure object port)
-     (write-char #\] port))))
-
-(define (standard-unparser-method name procedure)
-  (bracketed-unparser-method
-   (lambda (object port)
-     (display (if (procedure? name)
-                 (name object)
-                 name)
-             port)
-     (write-char #\space port)
-     (write (hash-object object) port)
-     (if procedure (procedure object port)))))
-
-(define (simple-unparser-method name get-parts)
-  (standard-unparser-method name
-    (and get-parts
-        (lambda (object port)
-          (for-each (lambda (object)
-                      (write-char #\space port)
-                      (write object port))
-                    (get-parts object))))))
-
 (define (simple-parser-method procedure)
   (lambda (objects lose)
     (or (and (pair? (cdr objects))

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 2dc34a890c57a0837e997e7e28e0a2f8f269f50c..f2d398d6e5ef86232fd418a8e43295bb8d43d991 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -88,14 +88,15 @@ USA.
     bundle?
   (alist bundle-alist))
 
-(define-unparser-method bundle?
-  (standard-unparser-method
-   (lambda (bundle)
-     (record-type-name (record-type-descriptor bundle)))
-   (lambda (bundle port)
-     (let ((handler (bundle-ref bundle 'write-self #f)))
-       (if handler
-          (handler port))))))
+(define-print-method bundle?
+  (standard-print-method
+      (lambda (bundle)
+       (record-type-name (record-type-descriptor bundle)))
+    (lambda (bundle)
+      (let ((handler (bundle-ref bundle 'summarize-self #f)))
+       (if handler
+           (handler)
+           '())))))
 
 (define-pp-describer bundle?
   (lambda (bundle)

diff --git a/src/runtime/condvar.scm b/src/runtime/condvar.scm
index 561f80bf178b6b83549c15c46978a770f56559ce..6d0d9f5ccdf8ce6896df48db81fe744bef7aa692 100644 (file)
--- a/src/runtime/condvar.scm
+++ b/src/runtime/condvar.scm
@@ -34,7 +34,7 @@ USA.
                   (constructor %make-condition-variable
                                (name waiter-head waiter-tail))
                   (print-procedure
-                   (simple-unparser-method 'condition-variable
+                   (standard-print-method 'condition-variable
                      (lambda (condvar)
                        (cond ((condition-variable-name condvar) => list)
                              (else '()))))))

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index 76cbccb416a97fa1a115cd68d81de82b57d7d473..339b4036b994159ab3b45aa105f0f382f981f552 100644 (file)
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -291,9 +291,8 @@ differences:
   (symbol (parser-context/name context) '?))
 
 (define (default-unparser-text context)
-  `(,(absolute 'standard-unparser-method context)
-    ',(parser-context/name context)
-    #f))
+  `(,(absolute 'standard-print-method context)
+    ',(parser-context/name context)))
 
 (define (default-type-name context)
   (symbol 'rtd: (parser-context/name context)))
@@ -841,7 +840,7 @@ differences:
           (or (structure/record-type? structure)
               (structure/tagged? structure)))
       (let ((context (structure/context structure)))
-       `((define-unparser-method
+       `((define-print-method
            ,(close (structure/predicate structure) context)
            ,(close (structure/print-procedure structure) context))))
       '()))
\ No newline at end of file

diff --git a/src/runtime/dispatch-tag.scm b/src/runtime/dispatch-tag.scm
index b740c78c10529fdbdc074a20a52fce1185492d62..864fc5a9ce2d853b809e61a7745b4e8822d68eb1 100644 (file)
--- a/src/runtime/dispatch-tag.scm
+++ b/src/runtime/dispatch-tag.scm
@@ -173,8 +173,8 @@ USA.
   (guarantee dispatch-tag? superset 'add-dispatch-tag-superset)
   (%add-to-weak-set superset (%tag-supersets tag)))
 
-(define-unparser-method dispatch-tag?
-  (simple-unparser-method
+(define-print-method dispatch-tag?
+  (standard-print-method
    (lambda (tag)
      (if (dispatch-metatag? tag) 'dispatch-metatag 'dispatch-tag))
    (lambda (tag)

diff --git a/src/runtime/error.scm b/src/runtime/error.scm
index 34eaa756fc7c0d0b0f7e29c117afb35de3d91731..030c451e317a875c0103113e4dd022b0d28a08cd 100644 (file)
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -36,10 +36,9 @@ USA.
                   (constructor %make-condition-type
                                (name field-indexes number-of-fields reporter))
                   (print-procedure
-                   (standard-unparser-method 'condition-type
-                     (lambda (type port)
-                       (write-char #\space port)
-                       (write-string (%condition-type/name type) port)))))
+                   (standard-print-method 'condition-type
+                     (lambda (type)
+                       (list (%condition-type/name type))))))
   (name #f read-only #t)
   generalizations
   (field-indexes #f read-only #t)
@@ -65,7 +64,7 @@ USA.
               (compute-field-indexes generalization field-names))
           (lambda (n-fields field-indexes)
             (%make-condition-type
-             (cond ((string? name) (string-copy name))
+             (cond ((string? name) (string->immutable name))
                    ((symbol? name) (symbol->string name))
                    ((not name) "(anonymous)")
                    (else
@@ -158,12 +157,10 @@ USA.
                   (constructor %%make-condition
                                (type continuation restarts field-values))
                   (print-procedure
-                   (standard-unparser-method 'condition
-                     (lambda (condition port)
-                       (write-char #\space port)
-                       (write-string
-                        (%condition-type/name (%condition/type condition))
-                        port)))))
+                   (standard-print-method 'condition
+                     (lambda (condition)
+                       (list (%condition-type/name
+                              (%condition/type condition)))))))
   (type #f read-only #t)
   (continuation #f read-only #t)
   (restarts #f read-only #t)
@@ -312,13 +309,12 @@ USA.
                   (constructor %make-restart
                                (name reporter effector interactor))
                   (print-procedure
-                   (standard-unparser-method 'restart
-                     (lambda (restart port)
-                       (write-char #\space port)
+                   (standard-print-method 'restart
+                     (lambda (restart)
                        (let ((name (%restart/name restart)))
                          (if name
-                             (write name port)
-                             (write-string "(anonymous)" port)))))))
+                             (list name)
+                             '()))))))
   (name #f read-only #t)
   (reporter #f read-only #t)
   (effector #f read-only #t)

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 43b8a4a55207c00020878032c2787d44ba02595c..af3de3978ac132ea1eb49479b887922f401ad1ca 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -45,8 +45,8 @@ USA.
 ;; two digits representing a larger number, then RADIX is their base.
 (define %radix)
 
-(define-unparser-method alien?
-  (standard-unparser-method
+(define-print-method alien?
+  (bracketed-print-method
    'alien
    (lambda (alien port)
      (write-char #\space port)
@@ -182,7 +182,7 @@ USA.
                   ;; To be fasdump/loadable.
                   (type vector) (named 'alien-function)
                   (print-procedure
-                   (standard-unparser-method 'alien-function
+                   (bracketed-print-method 'alien-function
                     (lambda (alienf port)
                       (write-char #\space port)
                       (write-string (%alien-function/name alienf)

diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm
index 31290e6bcb8203e0840c0fb8b2a2d10052da545a..176521001b3eb7c7b8eae1f8efed2191436da8c4 100644 (file)
--- a/src/runtime/gdbm.scm
+++ b/src/runtime/gdbm.scm
@@ -118,7 +118,7 @@ USA.
                                    opt val)))
 
 (define-structure (gdbf
-                  (print-procedure (simple-unparser-method 'gdbf
+                  (print-procedure (standard-print-method 'gdbf
                                      (lambda (gdbf)
                                        (list (gdbf-filename gdbf))))))
   descriptor

diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm
index 81c8e8140b6860990bad48f9a2ffb885ce403756..be4096db3729b972d531e6b90cba25618d715cc3 100644 (file)
--- a/src/runtime/graphics.scm
+++ b/src/runtime/graphics.scm
@@ -53,7 +53,7 @@ USA.
                     operation/set-line-style
                     custom-operations))
                   (print-procedure
-                   (simple-unparser-method 'graphics-type
+                   (standard-print-method 'graphics-type
                      (lambda (type)
                        (list (graphics-device-type/name type))))))
   (name false read-only true)

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index a9cac454b02e7129bfcabb890ef1996a805763e8..956cf55c4bb841aa96dd4a022684d87aa45dde3a 100644 (file)
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -89,6 +89,15 @@ USA.
                                   (list (cons 'name name) ...)))))
              env))
 
+    (if (unbound? env 'standard-print-method)
+       (eval '(define (standard-print-method name #!optional get-parts)
+                (simple-unparser-method name
+                                        (if (default-object? get-parts)
+                                            #f
+                                            get-parts)))
+             env))
+    (provide-rename env 'standard-unparser-method 'bracketed-print-method)
+
     (for-each (lambda (old-name)
                (provide-rename env old-name (symbol 'scode- old-name)))
              '(access-environment

diff --git a/src/runtime/http-io.scm b/src/runtime/http-io.scm
index c4595fa5a5ce0268a619a138325fdfae45abf361..d55d1b8977ec3179a415c88eb23163548fb8f8b4 100644 (file)
--- a/src/runtime/http-io.scm
+++ b/src/runtime/http-io.scm
@@ -49,8 +49,8 @@ USA.
       (guarantee-headers&body headers body 'make-http-request)
     (%make-http-request method uri version headers body)))
 
-(define-unparser-method http-request?
-  (simple-unparser-method 'http-request
+(define-print-method http-request?
+  (standard-print-method 'http-request
     (lambda (request)
       (list (http-request-method request)
            (uri->string (http-request-uri request))))))
@@ -72,8 +72,8 @@ USA.
       (guarantee-headers&body headers body 'make-http-response)
     (%make-http-response version status reason headers body)))
 
-(define-unparser-method http-response?
-  (simple-unparser-method 'http-response
+(define-print-method http-response?
+  (standard-print-method 'http-response
     (lambda (response)
       (list (http-response-status response)))))
 

diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm
index 14154b1c235190cbb69f05c69bc0c0511daab9fa..a5fbdebfc49b359b7d7bab2b8e954d7cf17ce421 100644 (file)
--- a/src/runtime/http-syntax.scm
+++ b/src/runtime/http-syntax.scm
@@ -234,8 +234,8 @@ USA.
 
 (define-guarantee http-header "HTTP header field")
 
-(define-unparser-method http-header?
-  (simple-unparser-method 'http-header
+(define-print-method http-header?
+  (standard-print-method 'http-header
     (lambda (header)
       (list (http-header-name header)))))
 

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 7ba4a4e06f9ef86f7f6e46b2172a2b1e0add08c1..959eb33b731250dc03b82ec5fb810be1ffa01fbe 100644 (file)
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -73,8 +73,8 @@ USA.
         (make-record-type "package" '(parent children name environment))))
     (set! package-tag rtd)
     (for-each (lambda (p) (%record-set! p 0 rtd)) *packages*)
-    (define-unparser-method (record-predicate rtd)
-      (simple-unparser-method 'package
+    (define-print-method (record-predicate rtd)
+      (standard-print-method 'package
        (lambda (package)
          (list (package/name package)))))))
 \f

diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm
index 317234281e2cc0fa38dd947910a3895e2ba47bfe..80294bb72c81f8b9ab90ba458b4d85c182494e29 100644 (file)
--- a/src/runtime/pathname.scm
+++ b/src/runtime/pathname.scm
@@ -110,8 +110,8 @@ these rules:
 
 (define-guarantee pathname "pathname")
 
-(define-unparser-method pathname?
-  (simple-unparser-method 'pathname
+(define-print-method pathname?
+  (standard-print-method 'pathname
     (lambda (pathname)
       (list (->namestring pathname)))))
 

diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm
index f5bdca0ae2e9443973936a191df4a15646c73374..f1d233a334cb15d1e5e847273fa6a27d8edec756 100644 (file)
--- a/src/runtime/poplat.scm
+++ b/src/runtime/poplat.scm
@@ -38,7 +38,7 @@ USA.
 
 (define (initialize-unparser!)
   (unparser/set-tagged-pair-method! population-tag
-                                   (standard-unparser-method 'population #f)))
+                                   (standard-print-method 'population)))
 
 (define bogus-false '(bogus-false))
 (define population-tag '(population))

diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 53d59cf0a71b92afb8d841e14d8699b976f4c445..4ccbb2f154044b2064488a7c536bf7d5f5cd7ee0 100644 (file)
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -238,8 +238,7 @@ USA.
                        '<= procedure?)
    (register-predicate! procedure-arity? 'procedure-arity)
    (register-predicate! thunk? 'thunk '<= procedure?)
-   (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
-   (register-predicate! unparser-method? 'unparser-method '<= procedure?)))
+   (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)))
 \f
 (add-boot-init!
  (lambda ()

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index e97bea5dc6462318f33af06e1d282e36e6f7cdbd..5f3bf2e1a937fd258ee338cff208285e1f1c528e 100644 (file)
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -246,7 +246,11 @@ USA.
   (let ((table (make-strong-eq-hash-table)))
 
     (define (walk object)
-      (cond ((pair? object)
+      (cond ((get-print-method-parts object)
+            => (lambda (parts)
+                 (if (mark! object)
+                     (for-each walk parts))))
+           ((pair? object)
             (if (mark! object)
                 (begin
                   (walk (car object))
@@ -283,24 +287,51 @@ USA.
     (print-number (cdr label) context)
     (*print-char (if def? #\= #\#) context)
     def?))
+\f
+(define (print-object-1 object context)
+  (let ((print-method (get-print-method object)))
+    (cond ((standard-print-method? print-method)
+          (*print-with-brackets
+           (standard-print-method-name print-method object)
+           object
+           context
+           (lambda (context*)
+             (for-each (lambda (part)
+                         (*print-char #\space context*)
+                         (print-object part context*))
+                       (standard-print-method-parts print-method object)))))
+         (print-method
+          (parameterize* (list (cons initial-context context))
+            (lambda ()
+              (print-method object (context-port context)))))
+         (else
+          ((vector-ref dispatch-table
+                       ((ucode-primitive primitive-object-type 1) object))
+           object
+           context)))))
 
-(define-deferred print-object-1
-  (standard-predicate-dispatcher 'print-object-1 2))
+(define (get-print-method-parts object)
+  (let ((print-method (get-print-method object)))
+    (and (standard-print-method? print-method)
+        (standard-print-method-parts print-method object))))
+
+(define-deferred get-print-method
+  (standard-predicate-dispatcher 'get-print-method 1))
 
 (add-boot-init!
  (lambda ()
-   (define-predicate-dispatch-default-handler print-object-1
-     (lambda (object context)
-       ((vector-ref dispatch-table
-                   ((ucode-primitive primitive-object-type 1) object))
-       object
-       context)))
-   (set! define-unparser-method
-        (named-lambda (define-unparser-method predicate unparser)
-          (define-predicate-dispatch-handler print-object-1
-            (list predicate context?)
-            unparser)))
-   (run-deferred-boot-actions 'unparser-methods)))
+   (set! define-print-method
+        (named-lambda (define-print-method predicate print-method)
+          (define-predicate-dispatch-handler get-print-method
+            (list predicate)
+            (lambda (object)
+              (declare (ignore object))
+              print-method))))
+   (define-predicate-dispatch-default-handler get-print-method
+     (lambda (object)
+       (declare (ignore object))
+       #f))
+   (run-deferred-boot-actions 'print-methods)))
 \f
 (define dispatch-table)
 (add-boot-init!
@@ -371,8 +402,7 @@ USA.
   (char-in-set? char (context-char-set context)))
 
 (define (*print-with-brackets name object context procedure)
-  (if (or (and (get-param:print-with-maximum-readability?) object)
-          (context-in-brackets? context))
+  (if (and (get-param:print-with-maximum-readability?) object)
       (*print-readable-hash object context)
       (begin
        (*print-string "#[" context)
@@ -385,7 +415,6 @@ USA.
                (*print-char #\space context*)
                (*print-hash object context*)))
          (cond (procedure
-                (*print-char #\space context*)
                 (procedure context*))
                ((get-param:print-with-datum?)
                 (*print-char #\space context*)
@@ -402,10 +431,12 @@ USA.
       ((non-pointer)
        (*print-with-brackets type object context
          (lambda (context*)
+          (*print-char #\space context*)
            (*print-datum object context*))))
       (else                             ;UNDEFINED, GC-INTERNAL
        (*print-with-brackets type #f context
          (lambda (context*)
+          (*print-char #\space context*)
            (*print-datum object context*)))))))
 
 (define (user-object-type object)
@@ -464,6 +495,7 @@ USA.
       (print-symbol-name (symbol->string symbol) context)
       (*print-with-brackets 'uninterned-symbol symbol context
         (lambda (context*)
+         (*print-char #\space context*)
          (*print-string (symbol->string symbol) context*)))))
 
 (define (print-symbol symbol context)
@@ -602,7 +634,7 @@ USA.
                              (begin
                                (*print-char #\space context*)
                                (print-object (safe-vector-ref vector index)
-                                                context*)
+                                             context*)
                                (loop (fix:+ index 1))))))
                    (*print-char #\) context*))
                  (*print-string "#()" context*))))))))
@@ -632,7 +664,7 @@ USA.
                        (begin
                          (*print-char #\space context*)
                          (print-number (bytevector-u8-ref bytevector index)
-                                        context*)
+                                       context*)
                          (loop (fix:+ index 1))))))
              (*print-char #\) context*))
            (*print-string "#u8()" context*))))))
@@ -755,6 +787,7 @@ USA.
             required optional rest body
             (and (not (eq? name scode-lambda-name:unnamed))
                  (lambda (context*)
+                   (*print-char #\space context*)
                    (print-object name context*))))))))
 
 (define (print-primitive-procedure procedure context)
@@ -766,7 +799,10 @@ USA.
          ((get-param:print-with-maximum-readability?)
           (*print-readable-hash procedure context))
          (else
-          (*print-with-brackets 'primitive-procedure #f context print-name)))))
+          (*print-with-brackets 'primitive-procedure #f context
+            (lambda (context*)
+              (*print-char #\space context*)
+              (print-name context*)))))))
 
 (define (print-compiled-entry entry context)
   (let* ((type (compiled-entry-type entry))
@@ -782,6 +818,7 @@ USA.
        (let ((name (and procedure? (compiled-procedure/name entry))))
          (receive (filename block-number)
              (compiled-entry/filename-and-index entry)
+           (*print-char #\space context*)
            (*print-char #\( context*)
            (if name
                (*print-string name context*))
@@ -810,26 +847,31 @@ USA.
 (define (print-return-address return-address context)
   (*print-with-brackets 'return-address return-address context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (return-address/name return-address) context*))))
 
 (define (print-assignment assignment context)
   (*print-with-brackets 'assignment assignment context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-assignment-name assignment) context*))))
 
 (define (print-definition definition context)
   (*print-with-brackets 'definition definition context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-definition-name definition) context*))))
 
 (define (print-lambda lambda-object context)
   (*print-with-brackets 'lambda lambda-object context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-lambda-name lambda-object) context*))))
 
 (define (print-variable variable context)
   (*print-with-brackets 'variable variable context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-variable-name variable) context*))))
 
 (define (print-number object context)
@@ -866,7 +908,8 @@ USA.
                      (if limit
                          (min length limit)
                          length))))
-               (print-flonum ((ucode-primitive floating-vector-ref) v 0)
+               (*print-char #\space context*)
+              (print-flonum ((ucode-primitive floating-vector-ref) v 0)
                               context*)
                (do ((i 1 (+ i 1)))
                    ((>= i limit))
@@ -884,7 +927,8 @@ USA.
   (define (named-arity-dispatched-procedure name)
     (*print-with-brackets 'arity-dispatched-procedure entity context
       (lambda (context*)
-        (*print-string name context*))))
+        (*print-char #\space context*)
+       (*print-string name context*))))
 
   (cond ((continuation? entity)
          (plain 'continuation))
@@ -905,10 +949,10 @@ USA.
   (*print-with-brackets 'promise promise context
     (if (promise-forced? promise)
        (lambda (context*)
-         (*print-string "(evaluated) " context*)
+         (*print-string " (evaluated) " context*)
          (print-object (promise-value promise) context*))
        (lambda (context*)
-         (*print-string "(unevaluated)" context*)
+         (*print-string " (unevaluated)" context*)
          (if (get-param:print-with-datum?)
              (begin
                (*print-char #\space context*)
@@ -917,10 +961,11 @@ USA.
 (define (print-tagged-object object context)
   (*print-with-brackets 'tagged-object object context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (let ((tag (%tagged-object-tag object)))
                       (if (dispatch-tag? tag)
                           (dispatch-tag-name tag)
                           tag))
                     context*)
-      (*print-string " " context*)
-      (print-object (%tagged-object-datum object) context*))))
\ No newline at end of file
+      (*print-char #\space context*)
+      (print-object (%tagged-object-datum object) context*))))

diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm
index 43f46e5fa5a4c28d8245209a332f0e684d6f87a3..24a2301e3b308da4d52c1d94d53cae43142b6ea2 100644 (file)
--- a/src/runtime/prop1d.scm
+++ b/src/runtime/prop1d.scm
@@ -35,7 +35,7 @@ USA.
 
 (define (initialize-unparser!)
   (unparser/set-tagged-pair-method! 1d-table-tag
-                                   (standard-unparser-method '1d-table #f)))
+                                   (standard-print-method '1d-table)))
 
 (define population-of-1d-tables)
 

diff --git a/src/runtime/random.scm b/src/runtime/random.scm
index e5f1f3e671298f6671512d19caf034995e1a9234..53eaa71be8813afa4d667f49100fa8a0117f894d 100644 (file)
--- a/src/runtime/random.scm
+++ b/src/runtime/random.scm
@@ -416,6 +416,6 @@ USA.
                                '#(index borrow vector)
                                '#(1 2 3)
                                (make-vector 3 (lambda () #f))
-                               (standard-unparser-method 'random-state #f)
+                               (standard-print-method 'random-state)
                                random-state-tag
                                4)))
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 78bc709227fde53d62a126f26a3047d9a6af81df..537a00388e23272e892097da63fe179fe80d3ddb 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -113,7 +113,7 @@ USA.
           #f)))
     (if (and unparser-method
             (not (default-object? unparser-method)))
-       (define-unparser-method (record-predicate type) unparser-method))
+       (define-print-method (record-predicate type) unparser-method))
     type))
 
 (define (list-of-unique-symbols? object)
@@ -543,20 +543,19 @@ USA.
 \f
 ;;;; Printing
 
-(define-unparser-method %record?
-  (standard-unparser-method '%record #f))
+(define-print-method %record?
+  (standard-print-method '%record))
 
-(define-unparser-method record?
-  (standard-unparser-method
+(define-print-method record?
+  (standard-print-method
    (lambda (record)
      (strip-angle-brackets
-      (dispatch-tag-name (record-type-descriptor record))))
-   #f))
+      (dispatch-tag-name (record-type-descriptor record))))))
 
 (add-boot-init!
  (lambda ()
-   (define-unparser-method record-type?
-     (simple-unparser-method 'record-type
+   (define-print-method record-type?
+     (standard-print-method 'record-type
        (lambda (type)
         (list (dispatch-tag-name type)))))))
 
@@ -578,7 +577,7 @@ USA.
 
 ;;; For backwards compatibility:
 (define (set-record-type-unparser-method! record-type method)
-  (define-unparser-method (record-predicate record-type)
+  (define-print-method (record-predicate record-type)
     method))
 \f
 ;;;; Runtime support for DEFINE-STRUCTURE
@@ -596,7 +595,7 @@ USA.
 (define structure-type/length)
 (add-boot-init!
  (lambda ()
-   ;; unparser-method arg should be removed after 9.3 is released.
+   ;; unparser-method field should be removed after 9.3 is released.
    (set! rtd:structure-type
         (make-record-type "structure-type"
                           '(physical-type name field-names field-indexes

diff --git a/src/runtime/reference-trap.scm b/src/runtime/reference-trap.scm
index b830ef75a433c5c035d08709e77737f9c300c648..a34527e86eb9c7fc307042fc355f6fd2797b37b4 100644 (file)
--- a/src/runtime/reference-trap.scm
+++ b/src/runtime/reference-trap.scm
@@ -33,7 +33,7 @@ USA.
                   (type vector)
                   (named '|#[(runtime reference-trap)reference-trap]|)
                   (print-procedure
-                   (simple-unparser-method 'reference-trap
+                   (standard-print-method 'reference-trap
                      (lambda (trap)
                        (list (let ((kind (reference-trap-kind trap)))
                                 (or (reference-trap-kind-name kind)

diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm
index f37f4ed02dd5bdc5e5171d9cad53b67fcc6c54ab..1192fac82cff9f8f19a405dd131fdd5ee4d47a2e 100644 (file)
--- a/src/runtime/rfc2822-headers.scm
+++ b/src/runtime/rfc2822-headers.scm
@@ -42,8 +42,8 @@ USA.
 
 (define-guarantee rfc2822-header "RFC 2822 header field")
 
-(define-unparser-method rfc2822-header?
-  (simple-unparser-method 'rfc2822-header
+(define-print-method rfc2822-header?
+  (standard-print-method 'rfc2822-header
     (lambda (header)
       (list (rfc2822-header-name header)))))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a2eb95de4b8541d0985a72bf6caf747dcd7db3bb..d4baa674f23e45d05bb3f243841f506d4bcd9251 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -134,6 +134,10 @@ USA.
 (define-package (runtime boot-definitions)
   (files "boot")
   (parent (runtime))
+  (export () deprecated:boot-definitions
+         (define-unparser-method define-print-method)
+         (simple-unparser-method standard-print-method)
+         (standard-unparser-method bracketed-print-method))
   (export ()
          %false->weak-false
          %make-record
@@ -151,16 +155,15 @@ USA.
          %weak-false->false
          %weak-false?
          %weak-set-car!
-         bracketed-unparser-method
+         bracketed-print-method
          bytes-per-object
          default-object
          default-object?
          define-pp-describer
-         define-unparser-method
+         define-print-method
          error:not-a
          error:not-a-list-of
          gc-space-status
-         general-unparser-method
          guarantee
          guarantee-list-of
          interrupt-bit/after-gc
@@ -184,9 +187,7 @@ USA.
          set-dispatch-tag<=!
          set-predicate<=!
          simple-parser-method
-         simple-unparser-method
-         standard-unparser-method
-         unparser-method?
+         standard-print-method
          weak-car
          weak-cdr
          weak-cons
@@ -211,6 +212,10 @@ USA.
          %weak-car)
   (export (runtime predicate)
          set-predicate-tag!)
+  (export (runtime printer)
+         standard-print-method-name
+         standard-print-method-parts
+         standard-print-method?)
   (export (runtime rep)
          finished-booting!)
   (export (runtime tagged-dispatch)
@@ -5784,4 +5789,4 @@ USA.
   (import (runtime save/restore)
          time-world-restored)
   (export ()
-         world-report))
\ No newline at end of file
+         world-report))

diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 60e8618e4a6cbe5923640e74442cf678f84ece81..98422f8cf6d58a4f7c1e704ec575f1f4ffaad027 100644 (file)
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -327,11 +327,10 @@ USA.
 (define top-level-mime-types
   '#(text image audio video application multipart message))
 
-(define-unparser-method mime-type?
-  (standard-unparser-method 'mime-type
-    (lambda (mime-type port)
-      (write-char #\space port)
-      (write-string (mime-type->string mime-type) port))))
+(define-print-method mime-type?
+  (standard-print-method 'mime-type
+    (lambda (mime-type)
+      (list (mime-type->string mime-type)))))
 
 (define interned-mime-types)
 (define unusual-interned-mime-types)

diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 54ac0ab939f97bce5beda9d419c8a9fba36cbb97..1570865194bd6a770f456f1b7e535fa844bc8e4b 100644 (file)
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -84,8 +84,8 @@ USA.
   (rename senv-rename)
   (describe senv-describe))
 
-(define-unparser-method syntactic-environment?
-  (simple-unparser-method 'syntactic-environment
+(define-print-method syntactic-environment?
+  (standard-print-method 'syntactic-environment
     (lambda (senv)
       (list ((senv-get-type senv))))))
 

diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 72ad5548c98222528759f0ef6368dc7e65faebf3..9ada1d14879e90b3190292b77225afc44a1d45ec 100644 (file)
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -41,8 +41,8 @@ USA.
     var-item?
   (id var-item-id))
 
-(define-unparser-method var-item?
-  (simple-unparser-method 'var-item
+(define-print-method var-item?
+  (standard-print-method 'var-item
     (lambda (item)
       (list (var-item-id item)))))
 
@@ -83,8 +83,8 @@ USA.
   (value defn-item-value)
   (syntax? defn-item-syntax?))
 
-(define-unparser-method defn-item?
-  (simple-unparser-method 'defn-item
+(define-print-method defn-item?
+  (standard-print-method 'defn-item
     (lambda (item)
       (list (defn-item-id item)
            (defn-item-value item)))))

diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm
index e853b51237e6a5ab87f87f62c0acd2c832769d1e..7843e0bb8c386f24fa1b56533dea21b49757422f 100644 (file)
--- a/src/runtime/textual-port.scm
+++ b/src/runtime/textual-port.scm
@@ -60,8 +60,8 @@ USA.
   (flush-output port-type-operation:flush-output)
   (discretionary-flush-output port-type-operation:discretionary-flush-output))
 
-(define-unparser-method textual-port-type?
-  (standard-unparser-method
+(define-print-method textual-port-type?
+  (standard-print-method
    (lambda (type)
      (if (port-type-supports-input? type)
        (if (port-type-supports-output? type)
@@ -69,8 +69,7 @@ USA.
            'textual-input-port-type)
        (if (port-type-supports-output? type)
            'textual-output-port-type
-           'textual-port-type)))
-   #f))
+           'textual-port-type)))))
 
 (define (port-type-supports-input? type)
   (port-type-operation:read-char type))
@@ -416,8 +415,8 @@ USA.
 (register-predicate! textual-i/o-port? 'textual-i/o-port
                     '<= textual-port?)
 
-(define-unparser-method textual-port?
-  (standard-unparser-method
+(define-print-method textual-port?
+  (bracketed-print-method
    (lambda (port)
      (cond ((textual-i/o-port? port) 'textual-i/o-port)
           ((textual-input-port? port) 'textual-input-port)

diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm
index 03e6f113008d4ce5244e77dff199216b9b4a836e..5aeea23db621ebaa101192b6b5fe06172e4bdf6b 100644 (file)
--- a/src/runtime/thread-queue.scm
+++ b/src/runtime/thread-queue.scm
@@ -45,7 +45,7 @@ USA.
 (define-structure (thread-queue (constructor %make-thread-queue)
                                (conc-name %thread-queue/)
                                (print-procedure
-                                (standard-unparser-method
+                                (bracketed-print-method
                                  'thread-queue
                                  (lambda (queue port)
                                    (print-thread-queue queue port)))))

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 1f034636ee45edf38b97f70ce60a7d6dadd937f6..6f0297ca0a5218307274cbc750b1646cea319ca0 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -136,7 +136,7 @@ USA.
                                '#(waiting-threads owner)
                                '#(1 2)
                                (vector 2 (lambda () #f))
-                               (standard-unparser-method 'thread-mutex #f)
+                               (standard-print-method 'thread-mutex)
                                thread-mutex-tag
                                3))
   (named-structure/set-tag-description! link-tag
@@ -145,7 +145,7 @@ USA.
                                '#(prev next item)
                                '#(1 2 3)
                                (vector 3 (lambda () #f))
-                               (standard-unparser-method 'link #f)
+                               (standard-print-method 'link)
                                link-tag
                                4)))
 

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index de9207574d7730db07cf0ccf7aa2897ec79c6cfb..34dfc08ae24784c4f4dd668a4213dfd25434529c 100644 (file)
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -117,8 +117,8 @@ USA.
   (host uri-authority-host)
   (port uri-authority-port))
 
-(define-unparser-method uri-authority?
-  (simple-unparser-method 'uri-authority
+(define-print-method uri-authority?
+  (standard-print-method 'uri-authority
     (lambda (authority)
       (list (call-with-output-string
              (lambda (port)
@@ -953,8 +953,8 @@ USA.
   (fragment partial-uri-fragment set-partial-uri-fragment!)
   (extra partial-uri-extra set-partial-uri-extra!))
 
-(define-unparser-method partial-uri?
-  (standard-unparser-method 'partial-uri
+(define-print-method partial-uri?
+  (bracketed-print-method 'partial-uri
     (lambda (puri port)
       (write-char #\space port)
       (write-partial-uri puri port))))

diff --git a/src/runtime/win32-registry.scm b/src/runtime/win32-registry.scm
index ebfd4926948bf2942a59f02355ff56eb037ab383..5404946ccb9e495c07a183e93c107fe509dedffe 100644 (file)
--- a/src/runtime/win32-registry.scm
+++ b/src/runtime/win32-registry.scm
@@ -139,7 +139,7 @@ USA.
                   (constructor %make-registry-key (parent name handle))
                   (predicate win32-registry/key?)
                   (print-procedure
-                   (simple-unparser-method 'registry-key
+                   (standard-print-method 'registry-key
                      (lambda (key)
                        (list (registry-key-name key))))))
   (name #f read-only #t)
@@ -163,7 +163,7 @@ USA.
 
 (define-structure (registry-value
                   (print-procedure
-                   (simple-unparser-method 'registry-value
+                   (standard-print-method 'registry-value
                      (lambda (key)
                        (list (registry-value-name key))))))
   (name #f read-only #t)

diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm
index 2e554011a3c420a62582d930babd166b0cd597af..c6c6f4b95448bc9f07eb0300c7d57a715e8d85f0 100644 (file)
--- a/src/runtime/x11graph.scm
+++ b/src/runtime/x11graph.scm
@@ -223,7 +223,7 @@ USA.
                   (conc-name x-display/)
                   (constructor make-x-display (name xd))
                   (print-procedure
-                   (simple-unparser-method 'x-display
+                   (standard-print-method 'x-display
                      (lambda (display)
                        (list (x-display/name display))))))
   (name #f read-only #t)

diff --git a/src/sf/object.scm b/src/sf/object.scm
index ef6129bfc29afbbeaf0637c42ab128edf344baa8..a60c5323ee16b90192862d05a66a0e864c672d90 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -190,7 +190,7 @@ USA.
                    (conc-name variable/)
                    (constructor variable/make (block name flags))
                    (print-procedure
-                    (simple-unparser-method 'variable
+                    (standard-print-method 'variable
                      (lambda (var)
                        (list (variable/name var))))))
   block
@@ -606,7 +606,7 @@ USA.
                    (conc-name reference/)
                    (constructor reference/make)
                    (print-procedure
-                    (simple-unparser-method 'reference
+                    (standard-print-method 'reference
                      (lambda (ref)
                        (list (variable/name (reference/variable ref)))))))
   (scode #f read-only #t)

diff --git a/src/sf/pthmap.scm b/src/sf/pthmap.scm
index ececfdd0b884e10b9e4f259d82a21b64b08088f1..15aa9e15cd6862a0a3009c2ddceb1e56de4b0de5 100644 (file)
--- a/src/sf/pthmap.scm
+++ b/src/sf/pthmap.scm
@@ -41,7 +41,7 @@ USA.
 
 (unparser/set-tagged-pair-method!
  pathname-map/tag
- (standard-unparser-method "PATHNAME-MAP" #f))
+ (standard-print-method "PATHNAME-MAP"))
 
 (declare (integrate-operator node/make))
 

diff --git a/src/sos/class.scm b/src/sos/class.scm
index 76cbd11795ecd3ffff32035d65983de34cc83b6a..74ca40f8c6b491399a8f5a88591ec56888d6a83c 100644 (file)
--- a/src/sos/class.scm
+++ b/src/sos/class.scm
@@ -33,7 +33,7 @@ USA.
                         (constructor %make-class
                                      (name direct-superclasses direct-slots))
                         (print-procedure
-                         (simple-unparser-method 'CLASS
+                         (standard-print-method 'CLASS
                            (lambda (class)
                              (let ((name (class-name class)))
                                (if name

diff --git a/src/sos/printer.scm b/src/sos/printer.scm
index 07a01af14dbdfc18ed1649e72a652f34528519c9..ce6e6cc9c78fb263716721f3d43baaf375c8eb6b 100644 (file)
--- a/src/sos/printer.scm
+++ b/src/sos/printer.scm
@@ -92,8 +92,8 @@ USA.
       (thunk))
   (write-char #\] port))
 \f
-(define-unparser-method instance?
-  (general-unparser-method write-instance))
+(define-print-method instance?
+  write-instance)
 
 (define (instance-description instance)
   (map (lambda (slot)

diff --git a/src/win32/module.scm b/src/win32/module.scm
index ec93601d96b45b96259a41e834c3b6c35e0a4acf..275055d0776b8f2349c4085257c6e45165b8bcc6 100644 (file)
--- a/src/win32/module.scm
+++ b/src/win32/module.scm
@@ -44,7 +44,7 @@ USA.
     (conc-name module/)
     (constructor %make-module)
     (print-procedure
-     (simple-unparser-method 'MODULE
+     (standard-print-method 'MODULE
        (lambda (module)
         (list (module/load-name module))))))
   load-name

diff --git a/src/x11/x11-device.scm b/src/x11/x11-device.scm
index 69c5745014e173925dd351235ae19a4a2b5d7eee..ba6e29975e6e01a8b48b2b3f584573ef137b3842 100644 (file)
--- a/src/x11/x11-device.scm
+++ b/src/x11/x11-device.scm
@@ -127,7 +127,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                   (conc-name x-display/)
                   (constructor make-x-display (name xd))
                   (print-procedure
-                   (simple-unparser-method 'X-DISPLAY
+                   (standard-print-method 'X-DISPLAY
                      (lambda (display)
                        (list (x-display/name display))))))
   (name #f read-only #t)

diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm
index a5a5b3958d29a11df91f719534898918c02642f5..a4bea2ce33efd4dd668147968c8262df01812f71 100644 (file)
--- a/src/xml/rdf-struct.scm
+++ b/src/xml/rdf-struct.scm
@@ -151,11 +151,10 @@ USA.
 
 (define-guarantee rdf-bnode "RDF bnode")
 
-(define-unparser-method rdf-bnode?
-  (standard-unparser-method 'RDF-BNODE
-    (lambda (bnode port)
-      (write-char #\space port)
-      (write-string (rdf-bnode-name bnode) port))))
+(define-print-method rdf-bnode?
+  (standard-print-method 'rdf-bnode
+    (lambda (bnode)
+      (list (rdf-bnode-name bnode)))))
 
 (define (make-rdf-bnode #!optional name)
   (if (default-object? name)
@@ -225,8 +224,8 @@ USA.
     (and (not (absolute-uri? type))
         type)))
 
-(define-unparser-method rdf-literal?
-  (standard-unparser-method 'RDF-LITERAL
+(define-print-method rdf-literal?
+  (bracketed-print-method 'RDF-LITERAL
     (lambda (literal port)
       (write-char #\space port)
       (write-rdf/nt-literal literal port))))

diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index af5df75c676b557a7b4522fd38fd963491da9cd5..b6f80f6e312d90e1b58b8bf311e7d7467a605fff 100644 (file)
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -89,8 +89,8 @@ USA.
   (qname combo-name-qname)
   (expanded combo-name-expanded))
 
-(define-unparser-method combo-name?
-  (simple-unparser-method 'XML-NAME
+(define-print-method combo-name?
+  (standard-print-method 'XML-NAME
     (lambda (name)
       (list (combo-name-qname name)))))
 

diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm
index 0512be4705089fe05fe3f1176575b562c75cd76c..33004b11f2354934555f8c38188bd2f12925134a 100644 (file)
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -90,8 +90,8 @@ USA.
   (indent-attributes? ctx-indent-attributes?)
   (indent-dtd? ctx-indent-dtd?))
 
-(define-unparser-method ctx?
-  (standard-unparser-method 'xml-output-context #f))
+(define-print-method ctx?
+  (standard-print-method 'xml-output-context))
 
 (define (emit-char char ctx)
   (let ((port (ctx-port ctx)))

diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index de1654a3401889b2ebfacc2057f2eed1669d6813..2321bca8ca8ad716842f7bbf2f38afdae0707777 100644 (file)
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -427,9 +427,9 @@ USA.
         (let ((name (cadr form))
               (accessor (caddr form)))
           (let ((root (symbol 'XML- name)))
-            `(define-unparser-method
+            `(define-print-method
               ,(close-syntax (symbol root '?) environment)
-              (SIMPLE-UNPARSER-METHOD ',root
+              (standard-print-method ',root
                 (LAMBDA (,name)
                   (LIST (,(close-syntax accessor environment) ,name)))))))
         (ill-formed-syntax form)))))