Eliminate unparser/standard-method.

* Allow name arg of simple-unparser-method and standard-unparser-method to be a
  procedure that computes the name.
* Favor the use of simple-unparser-method where possible.
* Implement general-unparser-method and bracketed-unparser-method.

diff --git a/src/compiler/base/blocks.scm b/src/compiler/base/blocks.scm
index 4a8de7ed94a583314a19879f9e31706d28631b01..3cf00c4174a163460ef04eaf9a89740957efac79 100644 (file)
--- a/src/compiler/base/blocks.scm
+++ b/src/compiler/base/blocks.scm
@@ -113,19 +113,13 @@ from the continuation, and then "glued" into place afterwards.
     block))
 \f
 (define-vector-tag-unparser block-tag
-  (lambda (state block)
-    ((standard-unparser
-      (symbol->string 'BLOCK)
-      (lambda (state block)
-       (unparse-object state
-                       (enumeration/index->name block-types
-                                                (block-type block)))
-       (let ((procedure (block-procedure block)))
-         (if (and procedure (rvalue/procedure? procedure))
-             (begin
-               (unparse-string state " ")
-               (unparse-label state (procedure-label procedure)))))))
-     state block)))
+  (simple-unparser-method "LIAR:block"
+    (lambda (block)
+      (cons (enumeration/index->name block-types (block-type block))
+           (let ((procedure (block-procedure block)))
+             (if (and procedure (rvalue/procedure? procedure))
+                 (list (procedure-label procedure))
+                       '()))))))
 
 (define-integrable (rvalue/block? rvalue)
   (eq? (tagged-vector/tag rvalue) block-tag))

diff --git a/src/compiler/base/ctypes.scm b/src/compiler/base/ctypes.scm
index 52f2e2ff2b2a6afc6e378773ff0e9883b6fea4e0..5137f516ae194502badaa00f8f221a35f4d16d76 100644 (file)
--- a/src/compiler/base/ctypes.scm
+++ b/src/compiler/base/ctypes.scm
@@ -59,19 +59,17 @@ USA.
     (make-scfg application '())))
 
 (define-vector-tag-unparser application-tag
-  (lambda (state application)
-    ((case (application-type application)
-       ((COMBINATION)
-       (standard-unparser (symbol->string 'COMBINATION) false))
-       ((RETURN)
-       (standard-unparser (symbol->string 'RETURN)
-         (lambda (state return)
-           (unparse-object state (return/operand return)))))
-       (else
-       (standard-unparser (symbol->string 'APPLICATION)
-         (lambda (state application)
-           (unparse-object state (application-type application))))))
-     state application)))
+  (simple-unparser-method
+   (lambda (application)
+     (case (application-type application)
+       ((COMBINATION) "LIAR:combination")
+       ((RETURN) "LIAR:return")
+       (else "LIAR:application")))
+   (lambda (application)
+     (case (application-type application)
+       ((COMBINATION) '())
+       ((RETURN) (list (return/operand return)))
+       (else (list (application-type application)))))))
 
 (define-integrable (application-block application)
   (reference-context/block (application-context application)))

diff --git a/src/compiler/base/enumer.scm b/src/compiler/base/enumer.scm
index fe00fc2c0fe71a6705738b83dea4508b0baef40b..844ea5ee777dcd596de81c56a6c2a24002bb4920 100644 (file)
--- a/src/compiler/base/enumer.scm
+++ b/src/compiler/base/enumer.scm
@@ -38,9 +38,9 @@ USA.
 (define-structure (enumerand
                   (conc-name enumerand/)
                   (print-procedure
-                   (standard-unparser (symbol->string 'ENUMERAND)
-                     (lambda (state enumerand)
-                       (unparse-object state (enumerand/name enumerand))))))
+                   (simple-unparser-method "LIAR:enumerand"
+                     (lambda (enumerand)
+                       (list (enumerand/name enumerand))))))
   (enumeration false read-only true)
   (name false read-only true)
   (index false read-only true))

diff --git a/src/compiler/base/lvalue.scm b/src/compiler/base/lvalue.scm
index 4ee0f93f85f6178bbdd95db76ea4dbd514304679..dac9b4f7acdb8225732dcebfcaa605c5f13b1ea2 100644 (file)
--- a/src/compiler/base/lvalue.scm
+++ b/src/compiler/base/lvalue.scm
@@ -98,9 +98,9 @@ USA.
       (variable-normal-offset variable)))
 
 (define-vector-tag-unparser variable-tag
-  (standard-unparser (symbol->string 'VARIABLE)
-    (lambda (state variable)
-      (unparse-object state (variable-name variable)))))
+  (simple-unparser-method "LIAR:variable"
+    (lambda (variable)
+      (list (variable-name variable)))))
 
 (define-integrable (lvalue/variable? lvalue)
   (eq? (tagged-vector/tag lvalue) variable-tag))

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index dbb581758aefb15fa3c70d658c8fa7f2360188ac..f7181730e527b22b7fd02683199025e0d81a35a8 100644 (file)
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -46,11 +46,10 @@ USA.
   (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
     (set-vector-tag-%unparser!
      root-tag
-     (lambda (state object)
-       ((standard-unparser
-        (symbol->string (vector-tag-name (tagged-vector/tag object)))
-        false)
-       state object)))
+     (simple-unparser-method
+      (lambda (object)
+       (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))
+      #f))
     (named-lambda (make-vector-tag parent name enumeration)
       (let ((tag
             (%make-vector-tag (or parent root-tag)
@@ -149,12 +148,6 @@ USA.
        (else
         (error "Not a tagged vector" object))))
 
-(define (standard-unparser name unparser)
-  (let ((name (string-append (symbol->string 'LIAR) ":" name)))
-    (if unparser
-       (unparser/standard-method name unparser)
-       (unparser/standard-method name))))
-
 (define (tagged-vector/unparse state vector)
   (parameterize* (list (cons param:unparser-radix 16))
     (lambda ()

diff --git a/src/compiler/base/proced.scm b/src/compiler/base/proced.scm
index 71e00471b9ca1b1c005a51dfb16fd88f9829018f..41fd8f7b473f37c0e8582345d13d4f6e3bfbdc99 100644 (file)
--- a/src/compiler/base/proced.scm
+++ b/src/compiler/base/proced.scm
@@ -104,19 +104,20 @@ USA.
     procedure))
 
 (define-vector-tag-unparser procedure-tag
-  (lambda (state procedure)
-    ((let ((type
-           (enumeration/index->name continuation-types
-                                    (procedure-type procedure))))
-       (if (eq? type 'PROCEDURE)
-          (standard-unparser (symbol->string 'PROCEDURE)
-            (lambda (state procedure)
-              (unparse-label state (procedure-label procedure))))
-          (standard-unparser (symbol->string (procedure-label procedure))
-            (lambda (state procedure)
-              procedure
-              (unparse-object state type)))))
-     state procedure)))
+  (let ((get-type
+        (lambda (procedure)
+          (enumeration/index->name continuation-types
+                                   (procedure-type procedure)))))
+    (simple-unparser-method
+     (lambda (procedure)
+       (if (eq? (get-type procedure) 'PROCEDURE)
+          "LIAR:procedure"
+          (string "LIAR:" (procedure-label procedure))))
+     (lambda (procedure)
+       (let ((type (get-type procedure)))
+        (if (eq? type 'PROCEDURE)
+            (list (procedure-label procedure))
+            (list type)))))))
 
 (define-integrable (unparse-label state label)
   (unparse-string state (symbol->string label)))

diff --git a/src/compiler/base/rvalue.scm b/src/compiler/base/rvalue.scm
index 673ddaccda014edb98347d242ae6bf08c646e7f4..c068f55b89f3fc9b90d762a4d184890ad6c15267 100644 (file)
--- a/src/compiler/base/rvalue.scm
+++ b/src/compiler/base/rvalue.scm
@@ -96,9 +96,9 @@ USA.
          constant))))
 
 (define-vector-tag-unparser constant-tag
-  (standard-unparser (symbol->string 'CONSTANT)
-    (lambda (state constant)
-      (unparse-object state (constant-value constant)))))
+  (simple-unparser-method "LIAR:constant"
+    (lambda (constant)
+      (list (constant-value constant)))))
 
 (define-integrable (rvalue/constant? rvalue)
   (eq? (tagged-vector/tag rvalue) constant-tag))
@@ -114,9 +114,9 @@ USA.
   (make-rvalue reference-tag block lvalue safe?))
 
 (define-vector-tag-unparser reference-tag
-  (standard-unparser (symbol->string 'REFERENCE)
-    (lambda (state reference)
-      (unparse-object state (variable-name (reference-lvalue reference))))))
+  (simple-unparser-method "LIAR:reference"
+    (lambda (reference)
+      (list (variable-name (reference-lvalue reference))))))
 
 (define-integrable (rvalue/reference? rvalue)
   (eq? (tagged-vector/tag rvalue) reference-tag))
@@ -150,9 +150,9 @@ USA.
   (make-rvalue unassigned-test-tag block lvalue))
 
 (define-vector-tag-unparser unassigned-test-tag
-  (standard-unparser (symbol->string 'UNASSIGNED-TEST)
-    (lambda (state unassigned-test)
-      (unparse-object state (unassigned-test-lvalue unassigned-test)))))
+  (simple-unparser-method "LIAR:unassigned-test"
+    (lambda (unassigned-test)
+      (list (unassigned-test-lvalue unassigned-test)))))
 
 (define-integrable (rvalue/unassigned-test? rvalue)
   (eq? (tagged-vector/tag rvalue) unassigned-test-tag))

diff --git a/src/compiler/base/subprb.scm b/src/compiler/base/subprb.scm
index c2533673b7908203c61a650261b01a4039e49c8e..313587b97183a6683764e074fb3c5b38a1d9c4bc 100644 (file)
--- a/src/compiler/base/subprb.scm
+++ b/src/compiler/base/subprb.scm
@@ -114,14 +114,13 @@ known that the continuation need not be used.
                   (constructor virtual-continuation/%make)
                   (conc-name virtual-continuation/)
                   (print-procedure
-                   (standard-unparser (symbol->string 'VIRTUAL-CONTINUATION)
-                     (lambda (state continuation)
+                   (simple-unparser-method "LIAR:virtual-continuation"
+                     (lambda (continuation)
                        (let ((type (virtual-continuation/type continuation)))
                          (if type
-                             (unparse-object
-                              state
-                              (enumeration/index->name continuation-types
-                                                       type))))))))
+                             (list (enumeration/index->name continuation-types
+                                                            type))
+                             '()))))))
   context
   parent
   type

diff --git a/src/compiler/rtlbase/rtlobj.scm b/src/compiler/rtlbase/rtlobj.scm
index f258bbe994f89e9538351811520c3003b72f1882..dd2f339e0141e2eb18cc960a7829de4d8ae14be8 100644 (file)
--- a/src/compiler/rtlbase/rtlobj.scm
+++ b/src/compiler/rtlbase/rtlobj.scm
@@ -33,9 +33,9 @@ USA.
                   (constructor make-rtl-expr
                                (rgraph label entry-edge debugging-info))
                   (print-procedure
-                   (standard-unparser (symbol->string 'RTL-EXPR)
-                     (lambda (state expression)
-                       (unparse-object state (rtl-expr/label expression))))))
+                   (simple-unparser-method "LIAR:rtl-expr"
+                     (lambda (expression)
+                       (list (rtl-expr/label expression))))))
   (rgraph false read-only true)
   (label false read-only true)
   (entry-edge false read-only true)
@@ -53,10 +53,9 @@ USA.
                                        debugging-info
                                        next-continuation-offset stack-leaf?))
                   (print-procedure
-                   (standard-unparser (symbol->string 'RTL-PROCEDURE)
-                     (lambda (state procedure)
-                       (unparse-object state
-                                       (rtl-procedure/label procedure))))))
+                   (simple-unparser-method "LIAR:rtl-procedure"
+                     (lambda (procedure)
+                       (list (rtl-procedure/label procedure))))))
   (rgraph false read-only true)
   (label false read-only true)
   (entry-edge false read-only true)
@@ -88,11 +87,9 @@ USA.
                                        next-continuation-offset
                                        debugging-info))
                   (print-procedure
-                   (standard-unparser (symbol->string 'RTL-CONTINUATION)
-                     (lambda (state continuation)
-                       (unparse-object
-                        state
-                        (rtl-continuation/label continuation))))))
+                   (simple-unparser-method "LIAR:rtl-continuation"
+                     (lambda (continuation)
+                       (list (rtl-continuation/label continuation))))))
   (rgraph false read-only true)
   (label false read-only true)
   (entry-edge false read-only true)

diff --git a/src/compiler/rtlbase/valclass.scm b/src/compiler/rtlbase/valclass.scm
index 6a7e045eeda32c01d93f100dcdfced4f152d9e1c..cbad13a8ddbeddc76524d78c096db764271e3daa 100644 (file)
--- a/src/compiler/rtlbase/valclass.scm
+++ b/src/compiler/rtlbase/valclass.scm
@@ -32,9 +32,9 @@ USA.
                   (conc-name value-class/)
                   (constructor %make-value-class (name parent))
                   (print-procedure
-                   (unparser/standard-method 'VALUE-CLASS
-                     (lambda (state class)
-                       (unparse-object state (value-class/name class))))))
+                   (simple-unparser-method 'VALUE-CLASS
+                     (lambda (class)
+                       (list (value-class/name class))))))
   (name false read-only true)
   (parent false read-only true)
   (children '())

diff --git a/src/compiler/rtlopt/rcseht.scm b/src/compiler/rtlopt/rcseht.scm
index e832a1a2550b0ca4896c687e072a78b76f80a901..f405ca52de767dc5c36c6512908467e782e0c162 100644 (file)
--- a/src/compiler/rtlopt/rcseht.scm
+++ b/src/compiler/rtlopt/rcseht.scm
@@ -47,8 +47,7 @@ USA.
 (define-structure (element
                   (constructor %make-element)
                   (constructor make-element (expression))
-                  (print-procedure
-                   (standard-unparser (symbol->string 'ELEMENT) false)))
+                  (print-procedure (simple-unparser-method "LIAR:element" #f)))
   (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 280379d07e60622681c295bf7132b600c7ee5635..f58b3aff88640e59fae1f3afebac3dcf63c67145 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
-                   (standard-unparser (symbol->string 'QUANTITY) false)))
+                   (simple-unparser-method "LIAR:quantity" #f)))
   (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 592265b1d9725f769e47ae7b0ef57926ab83094b..fc067b6d51bb1c0bc62cb364cfae86131be42fc7 100644 (file)
--- a/src/compiler/rtlopt/rdflow.scm
+++ b/src/compiler/rtlopt/rdflow.scm
@@ -72,9 +72,9 @@ USA.
                   (conc-name rnode/)
                   (constructor make-rnode (register))
                   (print-procedure
-                   (unparser/standard-method 'RNODE
-                     (lambda (state rnode)
-                       (unparse-object state (rnode/register rnode))))))
+                   (simple-unparser-method 'RNODE
+                     (lambda (rnode)
+                       (list (rnode/register rnode))))))
   (register false read-only true)
   (forward-links '())
   (backward-links '())

diff --git a/src/cref/object.scm b/src/cref/object.scm
index 8cc588a1e684e77ba3969ae7c061e4a638487eca..2f593a50e4149a38dbadfbe6b0842d3c4b4b0b13 100644 (file)
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -51,10 +51,9 @@ USA.
                   (constructor make-package (name parent))
                   (conc-name package/)
                   (print-procedure
-                   (standard-unparser-method 'PACKAGE
-                     (lambda (package port)
-                       (write-char #\space port)
-                       (write (package/name package) port)))))
+                   (simple-unparser-method 'PACKAGE
+                     (lambda (package)
+                       (list (package/name package))))))
   (name #f read-only #t)
   (files '())
   parent
@@ -108,13 +107,10 @@ USA.
                   (constructor %make-binding (package name value-cell new?))
                   (conc-name binding/)
                   (print-procedure
-                   (standard-unparser-method 'BINDING
-                     (lambda (binding port)
-                       (write-char #\space port)
-                       (write (binding/name binding) port)
-                       (write-char #\space port)
-                       (write (package/name (binding/package binding))
-                              port)))))
+                   (simple-unparser-method 'BINDING
+                     (lambda (binding)
+                       (list (binding/name binding)
+                             (package/name (binding/package binding)))))))
   (package #f read-only #t)
   (name #f read-only #t)
   (value-cell #f read-only #t)
@@ -173,13 +169,10 @@ USA.
                   (constructor %make-reference (package name))
                   (conc-name reference/)
                   (print-procedure
-                   (standard-unparser-method 'REFERENCE
-                     (lambda (reference port)
-                       (write-char #\space port)
-                       (write (reference/name reference) port)
-                       (write-char #\space port)
-                       (write (package/name (reference/package reference))
-                              port)))))
+                   (simple-unparser-method 'REFERENCE
+                     (lambda (reference)
+                       (list (reference/name reference)
+                             (package/name (reference/package reference)))))))
   (package #f read-only #t)
   (name #f read-only #t)
   (expressions '())

diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm
index d40f154efb1384e69a93e4f309c514791630db73..db969626817e818ff8ea36b16f842c7bda9492ad 100644 (file)
--- a/src/edwin/bufwin.scm
+++ b/src/edwin/bufwin.scm
@@ -501,12 +501,12 @@ USA.
 (define-structure (outline
                   (constructor %make-outline)
                   (print-procedure
-                   (unparser/standard-method 'OUTLINE
-                     (lambda (state outline)
-                       (unparse-string state "index: ")
-                       (unparse-object state (outline-index-length outline))
-                       (unparse-string state " y: ")
-                       (unparse-object state (outline-y-size outline))))))
+                   (standard-unparser-method 'OUTLINE
+                     (lambda (outline port)
+                       (write-string "index: " port)
+                       (write (outline-index-length outline) port)
+                       (write-string " y: " port)
+                       (write (outline-y-size outline) port)))))
   ;; The number of characters in the text line.  This is exclusive of
   ;; the newlines at the line's beginning and end, if any.
   index-length
@@ -569,16 +569,16 @@ USA.
 (define-structure (o3
                   (constructor %make-o3)
                   (print-procedure
-                   (unparser/standard-method 'O3
-                     (lambda (state o3)
-                       (unparse-string state "index: ")
-                       (unparse-object state (o3-index o3))
-                       (unparse-string state " y: ")
-                       (unparse-object state (o3-y o3))
+                   (standard-unparser-method 'O3
+                     (lambda (o3 port)
+                       (write-string "index: " port)
+                       (write (o3-index o3) port)
+                       (write-string " y: " port)
+                       (write (o3-y o3) port)
                        (if (outline? (o3-outline o3))
                            (begin
-                             (unparse-string state " ")
-                             (unparse-object state (o3-outline o3))))))))
+                             (write-string " " port)
+                             (write (o3-outline o3) port)))))))
   outline
   index
   y)

diff --git a/src/edwin/comman.scm b/src/edwin/comman.scm
index 2c7fef75254ce86ecb5d06f910b63dc6c953509f..8efa08794d4f48929a780fae667b09319a7fe9f6 100644 (file)
--- a/src/edwin/comman.scm
+++ b/src/edwin/comman.scm
@@ -31,9 +31,9 @@ USA.
 (define-structure (command
                   (constructor %make-command ())
                   (print-procedure
-                   (unparser/standard-method 'COMMAND
-                     (lambda (state command)
-                       (unparse-object state (command-name command))))))
+                   (simple-unparser-method 'COMMAND
+                     (lambda (command)
+                       (list (command-name command))))))
   name
   %description
   interactive-specification
@@ -103,9 +103,9 @@ USA.
 (define-structure (variable
                   (constructor %make-variable ())
                   (print-procedure
-                   (unparser/standard-method 'VARIABLE
-                     (lambda (state variable)
-                       (unparse-object state (variable-name variable))))))
+                   (simple-unparser-method 'VARIABLE
+                     (lambda (variable)
+                       (list (variable-name variable))))))
   name
   %description
   %value

diff --git a/src/edwin/display.scm b/src/edwin/display.scm
index d35828b4899534dfddeb21b4799cc4639cc5dade..8026735b2f385509191aad7cc84edaa5d487d3c7 100644 (file)
--- a/src/edwin/display.scm
+++ b/src/edwin/display.scm
@@ -33,10 +33,9 @@ USA.
                   (conc-name display-type/)
                   (constructor %make-display-type)
                   (print-procedure
-                   (unparser/standard-method 'DISPLAY-TYPE
-                     (lambda (state display-type)
-                       (unparse-object state
-                                       (display-type/name display-type))))))
+                   (simple-unparser-method 'DISPLAY-TYPE
+                     (lambda (display-type)
+                       (list (display-type/name display-type))))))
   (name false read-only true)
   (multiple-screens? false read-only true)
   (operation/available? false read-only true)

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

diff --git a/src/edwin/modes.scm b/src/edwin/modes.scm
index e44b69c8abdbe774a866bef1ad3ef9013b69632f..29e0e58f9dc8c149ac8c05366e2563854a60fa2a 100644 (file)
--- a/src/edwin/modes.scm
+++ b/src/edwin/modes.scm
@@ -33,11 +33,12 @@ USA.
                                (name major? display-name super-mode
                                      %description initialization comtabs))
                   (print-procedure
-                   (unparser/standard-method 'MODE
-                     (lambda (state mode)
-                       (unparse-object state (mode-name mode))
-                       (if (not (mode-major? mode))
-                           (unparse-string state " (minor)"))))))
+                   (simple-unparser-method 'MODE
+                     (lambda (mode)
+                       (cons (mode-name mode)
+                             (if (mode-major? mode)
+                                 '()
+                                 (list '(minor))))))))
   (name #f read-only #t)
   major?
   display-name

diff --git a/src/edwin/struct.scm b/src/edwin/struct.scm
index 332d10bc78f1cb3adea7b58b8879263fd4f667e1..ae4dbcf3583515a936292819c7f0d133d870a05c 100644 (file)
--- a/src/edwin/struct.scm
+++ b/src/edwin/struct.scm
@@ -306,17 +306,14 @@ USA.
 (define-structure (mark
                   (constructor make-temporary-mark)
                   (print-procedure
-                   (unparser/standard-method 'MARK
-                     (lambda (state mark)
-                       (unparse-object state
-                                       (or (mark-buffer mark)
-                                           (mark-group mark)))
-                       (unparse-string state " ")
-                       (unparse-object state (mark-index mark))
-                       (unparse-string state
-                                       (if (mark-left-inserting? mark)
-                                           " left"
-                                           " right"))))))
+                   (simple-unparser-method 'MARK
+                     (lambda (mark)
+                       (list (or (mark-buffer mark)
+                                 (mark-group mark))
+                             (mark-index mark)
+                             (if (mark-left-inserting? mark)
+                                 'left
+                                 'right))))))
   ;; The microcode file "edwin.h" depends on the definition of this
   ;; structure.
   (group #f read-only #t)

diff --git a/src/edwin/window.scm b/src/edwin/window.scm
index c592c2d486aa928435cbbd23d7bfe03d21f6c774..4e546880256039a6ce3caaaa78ad0ca2c892753a 100644 (file)
--- a/src/edwin/window.scm
+++ b/src/edwin/window.scm
@@ -364,16 +364,16 @@ USA.
   (vector-set! inferior 4 redisplay-flags))
 
 (unparser/set-tagged-vector-method! %inferior-tag
-  (unparser/standard-method 'INFERIOR
-    (lambda (state inferior)
-      (unparse-object state (inferior-window inferior))
-      (unparse-string state " x,y=(")
-      (unparse-object state (inferior-x-start inferior))
-      (unparse-string state ",")
-      (unparse-object state (inferior-y-start inferior))
-      (unparse-string state ")")
+  (standard-unparser-method 'INFERIOR
+    (lambda (inferior port)
+      (write (inferior-window inferior) port)
+      (write-string " x,y=(" port)
+      (write (inferior-x-start inferior) port)
+      (write-string "," port)
+      (write (inferior-y-start inferior) port)
+      (write-string ")" port)
       (if (inferior-needs-redisplay? inferior)
-         (unparse-string state " needs-redisplay")))))
+         (write-string " needs-redisplay" port)))))
 
 (define (inferior-copy inferior)
   (%make-inferior (inferior-window inferior)

diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm
index 9a6c5142f3b4b01c5092fb30b879497dfb135d5a..02a68f8ffec5b89b28b27a6d98c7d3482084d3eb 100644 (file)
--- a/src/gdbm/gdbm.scm
+++ b/src/gdbm/gdbm.scm
@@ -234,11 +234,9 @@ USA.
 \f
 (define-structure (gdbf (constructor make-gdbf)
                        (print-procedure
-                        (standard-unparser-method
-                         'GDBF
-                         (lambda (gdbf port)
-                           (write-char #\space port)
-                           (write (gdbf-filename gdbf) port)))))
+                        (simple-unparser-method 'GDBF
+                          (lambda (gdbf)
+                            (list (gdbf-filename gdbf))))))
   ;; Note that communicating through this malloced-per-GDBM_FILE
   ;; helper struct assumes there are no callbacks possible during gdbm
   ;; operations (via which this procedure could be called multiple

diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm
index d8a02c795041c08aa25ec12143c09e950fa80e1c..43c9ff3e45248609a75002232c6cf130656e9abe 100644 (file)
--- a/src/imail/imail-core.scm
+++ b/src/imail/imail-core.scm
@@ -967,10 +967,9 @@ USA.
                   (safe-accessors #t)
                   (constructor #f)
                   (print-procedure
-                   (standard-unparser-method 'HEADER-FIELD
-                     (lambda (header port)
-                       (write-char #\space port)
-                       (write (header-field-name header) port)))))
+                   (simple-unparser-method 'HEADER-FIELD
+                     (lambda (header)
+                       (list (header-field-name header))))))
   (name #f read-only #t)
   (value #f read-only #t))
 

diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm
index 8aabc1392baaf0253b7d7356716618c923d5b6b1..a2bb0172c928fc1034c27a6531e85828e81eb027 100644 (file)
--- a/src/imail/imail-mime.scm
+++ b/src/imail/imail-mime.scm
@@ -752,10 +752,9 @@ USA.
 (define-structure (mime-encoding
                    (conc-name mime-encoding/)
                    (print-procedure
-                    (standard-unparser-method 'MIME-ENCODING
-                      (lambda (encoding output-port)
-                        (write-char #\space output-port)
-                        (write (mime-encoding/name encoding) output-port))))
+                    (simple-unparser-method 'MIME-ENCODING
+                      (lambda (encoding)
+                        (list (mime-encoding/name encoding)))))
                    (constructor %make-mime-encoding))
   (name                          #f read-only #t)
   (identity?                     #f read-only #t)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 80997d75e31b7a0d993d42d7340ec7231dca15d2..495e3523aecc8da3c1996e6832304e88bce1067f 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -30,20 +30,16 @@ USA.
 (declare (usual-integrations))
 \f
 (define (standard-unparser-method name unparser)
-  (make-method name
-              (and unparser
-                   (lambda (state object)
-                     (with-current-unparser-state state
-                       (lambda (port)
-                         (unparser object port)))))))
+  (make-method name unparser))
 
 (define (simple-unparser-method name method)
   (standard-unparser-method name
-    (lambda (object port)
-      (for-each (lambda (object)
-                 (write-char #\space port)
-                 (write object port))
-               (method object)))))
+    (and method
+        (lambda (object port)
+          (for-each (lambda (object)
+                      (write-char #\space port)
+                      (write object port))
+                    (method object))))))
 
 (define (simple-parser-method procedure)
   (lambda (objects lose)
@@ -51,33 +47,37 @@ USA.
             (procedure (cddr objects)))
        (lose))))
 
-(define (unparser/standard-method name #!optional unparser)
-  (make-method name
-              (and (not (default-object? unparser))
-                   unparser
-                   (lambda (state object)
-                     (unparse-char state #\space)
-                     (unparser state object)))))
-
 (define (make-method name unparser)
+  (general-unparser-method
+   (lambda (object port)
+     (let ((hash-string (number->string (hash object))))
+       (if (get-param:unparse-with-maximum-readability?)
+          (begin
+            (write-string "#@" port)
+            (write-string hash-string port))
+          (begin
+            (write-string "#[" port)
+            (let loop ((name name))
+              (cond ((string? name) (write-string name port))
+                    ((procedure? name) (loop (name object)))
+                    (else (write name port))))
+            (write-char #\space port)
+            (write-string hash-string port)
+            (if unparser (unparser object port))
+            (write-char #\] port)))))))
+
+(define (general-unparser-method unparser)
   (lambda (state object)
-    (let ((port (unparser-state/port state))
-         (hash-string (number->string (hash object))))
-      (if (get-param:unparse-with-maximum-readability?)
-         (begin
-           (write-string "#@" port)
-           (write-string hash-string port))
-         (begin
-           (write-string "#[" port)
-           (if (string? name)
-               (write-string name port)
-               (with-current-unparser-state state
-                 (lambda (port)
-                   (write name port))))
-           (write-char #\space port)
-           (write-string hash-string port)
-           (if unparser (unparser state object))
-           (write-char #\] port))))))
+    (with-current-unparser-state state
+      (lambda (port)
+       (unparser object port)))))
+
+(define (bracketed-unparser-method unparser)
+  (general-unparser-method
+   (lambda (object port)
+     (write-string "#[" port)
+     (unparser object port)
+     (write-char #\] port))))
 
 (define (unparser-method? object)
   (and (procedure? object)

diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm
index f3f6453712b3b6219efde5e36cf7dffed43f4632..f9c4723b947ec5f927fb8993f8947a7d6f7d7f9a 100644 (file)
--- a/src/runtime/gdbm.scm
+++ b/src/runtime/gdbm.scm
@@ -118,10 +118,9 @@ USA.
                                    opt val)))
 
 (define-structure (gdbf
-                  (print-procedure (standard-unparser-method 'GDBF
-                                     (lambda (gdbf port)
-                                       (write-char #\space port)
-                                       (write (gdbf-filename gdbf) port)))))
+                  (print-procedure (simple-unparser-method 'GDBF
+                                     (lambda (gdbf)
+                                       (list (gdbf-filename gdbf))))))
   descriptor
   (filename #f read-only #t))
 

diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm
index 0b513b1a8471c8e470836bd065be2fff97c16622..d0dfc93f3689f4b527dedee707493ed811b76d33 100644 (file)
--- a/src/runtime/graphics.scm
+++ b/src/runtime/graphics.scm
@@ -53,10 +53,9 @@ USA.
                     operation/set-line-style
                     custom-operations))
                   (print-procedure
-                   (standard-unparser-method 'GRAPHICS-TYPE
-                     (lambda (type port)
-                       (write-char #\space port)
-                       (write (graphics-device-type/name type) port)))))
+                   (simple-unparser-method 'GRAPHICS-TYPE
+                     (lambda (type)
+                       (list (graphics-device-type/name type))))))
   (name false read-only true)
   (operation/available? false read-only true)
   (operation/clear false read-only true)

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 4c2c73cbecf3147d137f898f2f157cdf50fff78a..94a75dafa465c00f2d750378e06bce4e6391a751 100644 (file)
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -75,10 +75,9 @@ USA.
       (set! package-tag tag)
       (for-each (lambda (p) (%record-set! p 0 tag)) *packages*))
     (set-record-type-unparser-method! rtd
-      (standard-unparser-method 'PACKAGE
-       (lambda (package port)
-         (write-char #\space port)
-         (write (package/name package) port))))))
+      (simple-unparser-method 'PACKAGE
+       (lambda (package)
+         (list (package/name package)))))))
 \f
 (define (name->package name)
   (find-package name #f))

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 853a5ca0b115c4415e7af087d88b427e7e6c51eb..80688081eefa7216a58f98e224f71f6bc5ac27d4 100644 (file)
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -52,18 +52,16 @@ USA.
   (discretionary-flush-output #f read-only #t))
 
 (set-record-type-unparser-method! <port-type>
-  (lambda (state type)
-    ((standard-unparser-method
-      (if (port-type/supports-input? type)
-         (if (port-type/supports-output? type)
-             'I/O-PORT-TYPE
-             'INPUT-PORT-TYPE)
-         (if (port-type/supports-output? type)
-             'OUTPUT-PORT-TYPE
-             'PORT-TYPE))
-      #f)
-     state
-     type)))
+  (standard-unparser-method
+   (lambda (type)
+     (if (port-type/supports-input? type)
+       (if (port-type/supports-output? type)
+           'I/O-PORT-TYPE
+           'INPUT-PORT-TYPE)
+       (if (port-type/supports-output? type)
+           'OUTPUT-PORT-TYPE
+           'PORT-TYPE)))
+   #f))
 
 (define (guarantee-port-type object #!optional caller)
   (if (not (port-type? object))
@@ -497,9 +495,6 @@ USA.
        (cond ((port/operation port 'WRITE-SELF)
              => (lambda (operation)
                   (standard-unparser-method name operation)))
-            ((port/operation port 'PRINT-SELF)
-             => (lambda (operation)
-                  (unparser/standard-method name operation)))
             (else
              (standard-unparser-method name #f))))
      state

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 619c6ba059d7a37eaf501fe24f29837595619759..f123f0aa0cdb40e7dd976c23e6540734f7382f3a 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -103,10 +103,9 @@ USA.
                     (write-char #\space port)
                     (display (%record-type-name type) port))))
                ((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG))
-                (standard-unparser-method 'DISPATCH-TAG
-                  (lambda (tag port)
-                    (write-char #\space port)
-                    (write (dispatch-tag-contents tag) port))))
+                (simple-unparser-method 'DISPATCH-TAG
+                  (lambda (tag)
+                    (list (dispatch-tag-contents tag)))))
                (else record-method))))))
   (set! record-entity-unparser
        (make-generic-procedure 1 'RECORD-ENTITY-UNPARSER))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a79798544681d2a7c1c4fa18a947dacd974b7704..05104d2e3e994e0dc433cbe20ab7988e0f84720e 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -138,10 +138,12 @@ USA.
   (files "boot")
   (parent (runtime))
   (export ()
+         bracketed-unparser-method
          default-object
          default-object?
          error:not-unparser-method
          gc-space-status
+         general-unparser-method
          guarantee-unparser-method
          interrupt-bit/after-gc
          interrupt-bit/gc
@@ -162,7 +164,6 @@ USA.
          simple-unparser-method
          standard-unparser-method
          unparser-method?
-         unparser/standard-method
          with-absolutely-no-interrupts
          with-limited-interrupts
          without-interrupts)
@@ -2147,9 +2148,11 @@ USA.
   (export ()
          (eq-hash-table-type key-weak-eq-hash-table-type)
          (eqv-hash-table-type key-weak-eqv-hash-table-type)
+         (hash-table-clear! hash-table/clear!)
          (hash-table-delete! hash-table/remove!)
          (hash-table-equivalence-function hash-table/key=?)
          (hash-table-hash-function hash-table/key-hash)
+         (hash-table-intern! hash-table/intern!)
          (hash-table-keys hash-table/key-list)
          (hash-table-ref/default hash-table/get)
          (hash-table-set! hash-table/put!)

diff --git a/src/runtime/urtrap.scm b/src/runtime/urtrap.scm
index 025403693a47e9ccd32a60b1a96dac4c26c0ecbf..7a60cef8fcf96cb727b6959d23f5842288eff286 100644 (file)
--- a/src/runtime/urtrap.scm
+++ b/src/runtime/urtrap.scm
@@ -33,13 +33,11 @@ USA.
                   (type vector)
                   (named '|#[(runtime reference-trap)reference-trap]|)
                   (print-procedure
-                   (standard-unparser-method 'REFERENCE-TRAP
-                     (lambda (trap port)
-                       (write-char #\space port)
-                       (write (let ((kind (reference-trap-kind trap)))
+                   (simple-unparser-method 'REFERENCE-TRAP
+                     (lambda (trap)
+                       (list (let ((kind (reference-trap-kind trap)))
                                 (or (reference-trap-kind-name kind)
-                                    kind))
-                              port)))))
+                                    kind)))))))
   (kind #f read-only #t)
   (extra #f read-only #t))
 

diff --git a/src/runtime/win32-registry.scm b/src/runtime/win32-registry.scm
index 8dfca62e8d86669661dce194f60cb89c14fc7c3b..b6408ccb6f9bd469d9970685844de8cdd61c3f87 100644 (file)
--- a/src/runtime/win32-registry.scm
+++ b/src/runtime/win32-registry.scm
@@ -138,10 +138,9 @@ USA.
                   (constructor %make-registry-key (parent name handle))
                   (predicate win32-registry/key?)
                   (print-procedure
-                   (standard-unparser-method 'REGISTRY-KEY
-                     (lambda (key port)
-                       (write-char #\space port)
-                       (write (registry-key-name key) port)))))
+                   (simple-unparser-method 'REGISTRY-KEY
+                     (lambda (key)
+                       (list (registry-key-name key))))))
   (name #f read-only #t)
   (parent #f read-only #t)
   (handle #f)
@@ -163,10 +162,9 @@ USA.
 
 (define-structure (registry-value
                   (print-procedure
-                   (standard-unparser-method 'REGISTRY-VALUE
-                     (lambda (key port)
-                       (write-char #\space port)
-                       (write (registry-value-name key) port)))))
+                   (simple-unparser-method 'REGISTRY-VALUE
+                     (lambda (key)
+                       (list (registry-value-name key))))))
   (name #f read-only #t)
   (type #f))
 \f

diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm
index 543862422fb42d02a910c05859a73efff5722108..cdf9985bf6699f4b4c2c668bc24e08505f2cd07e 100644 (file)
--- a/src/runtime/x11graph.scm
+++ b/src/runtime/x11graph.scm
@@ -221,10 +221,9 @@ USA.
                   (conc-name x-display/)
                   (constructor make-x-display (name xd))
                   (print-procedure
-                   (standard-unparser-method 'X-DISPLAY
-                     (lambda (display port)
-                       (write-char #\space port)
-                       (write (x-display/name display) port)))))
+                   (simple-unparser-method 'X-DISPLAY
+                     (lambda (display)
+                       (list (x-display/name display))))))
   (name #f read-only #t)
   xd
   (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1)

diff --git a/src/sf/object.scm b/src/sf/object.scm
index 76e84d2a2ef05a403108f0157bcdd81060a9e68d..254c9d91c42ccc392db92ec5621775730f8be9c6 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -190,11 +190,9 @@ USA.
                    (conc-name variable/)
                    (constructor variable/make (block name flags))
                    (print-procedure
-                    (standard-unparser-method
-                     'variable
-                     (lambda (var port)
-                       (write-string " " port)
-                       (write (variable/name var) port)))))
+                    (simple-unparser-method 'variable
+                     (lambda (var)
+                       (list (variable/name var))))))
   block
   name
   flags)
@@ -601,11 +599,9 @@ USA.
                    (conc-name reference/)
                    (constructor reference/make)
                    (print-procedure
-                    (standard-unparser-method
-                     'reference
-                     (lambda (ref port)
-                       (write-string " to " port)
-                       (write (variable/name (reference/variable ref)) port)))))
+                    (simple-unparser-method 'reference
+                     (lambda (ref)
+                       (list (variable/name (reference/variable ref)))))))
   (scode #f read-only #t)
   block
   variable)

diff --git a/src/sf/pthmap.scm b/src/sf/pthmap.scm
index 396c36ab0afd4b4dfcbda69c6d7dcb5a67092c00..c099bc51245f81c0adf9e5e62b0677b2ef4b672d 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
- (unparser/standard-method "PATHNAME-MAP"))
+ (standard-unparser-method "PATHNAME-MAP" #f))
 
 (declare (integrate-operator node/make))
 

diff --git a/src/sos/class.scm b/src/sos/class.scm
index f817aaf86409e75fac863f7db8a1373bd469aee2..25ca74e7e346b7a637b96322f8e01c8f69033e14 100644 (file)
--- a/src/sos/class.scm
+++ b/src/sos/class.scm
@@ -33,13 +33,12 @@ USA.
                         (constructor %make-class
                                      (name direct-superclasses direct-slots))
                         (print-procedure
-                         (standard-unparser-method 'CLASS
-                           (lambda (class port)
+                         (simple-unparser-method 'CLASS
+                           (lambda (class)
                              (let ((name (class-name class)))
                                (if name
-                                   (begin
-                                     (write-char #\space port)
-                                     (write name port))))))))
+                                   (list name)
+                                   '()))))))
   (name #f read-only #t)
   (direct-superclasses #f read-only #t)
   (direct-slots #f read-only #t)

diff --git a/src/sos/printer.scm b/src/sos/printer.scm
index 33e3365a7c7ccccf97fd475c1a4e9f0ecbd62d01..9668973107dd6af0cd2f096aa1e9d7b8ce7375f1 100644 (file)
--- a/src/sos/printer.scm
+++ b/src/sos/printer.scm
@@ -107,10 +107,7 @@ USA.
     (and (let ((class (dispatch-tag-contents (cadr tags))))
           (and (class? class)
                (subclass? class <instance>)))
-        (lambda (state instance)
-          (with-current-unparser-state state
-            (lambda (port)
-              (write-instance instance port)))))))
+        (general-unparser-method write-instance))))
 
 (add-generic-procedure-generator pp-description
   (lambda (generic tags)

diff --git a/src/win32/module.scm b/src/win32/module.scm
index 7964d31ba43f82a45f9e35b2efbfa3e551f007f7..c53b98c478a5b30275e47eb426c36b447db9fe0c 100644 (file)
--- a/src/win32/module.scm
+++ b/src/win32/module.scm
@@ -44,9 +44,9 @@ USA.
     (conc-name module/)
     (constructor %make-module)
     (print-procedure
-     (unparser/standard-method 'MODULE
-       (lambda (state module)
-        (unparse-object state (module/load-name module))))))
+     (simple-unparser-method 'MODULE
+       (lambda (module)
+        (list (module/load-name module))))))
   load-name
   handle
   entries      ;; a protection list of all the functions from this module

diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index e1864872775ecd7dd778f23a34facc606836cd53..24e8d1539272e538a5ac4404930a650cec97c671 100644 (file)
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -92,10 +92,9 @@ USA.
   (expanded combo-name-expanded))
 
 (set-record-type-unparser-method! <combo-name>
-  (standard-unparser-method 'XML-NAME
-    (lambda (name port)
-      (write-char #\space port)
-      (write (combo-name-qname name) port))))
+  (simple-unparser-method 'XML-NAME
+    (lambda (name)
+      (list (combo-name-qname name)))))
 
 (define-record-type <expanded-name>
     (make-expanded-name uri local combos)

diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index c160307b46f5be38b44ba835c2ff6bce25069e1f..6e310987985c42fb9e24dd06af843d2bdb42c3c7 100644 (file)
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -461,11 +461,9 @@ USA.
           (let ((root (symbol-append 'XML- name)))
             `(SET-RECORD-TYPE-UNPARSER-METHOD!
               ,(close-syntax (symbol-append '< root '>) environment)
-              (STANDARD-UNPARSER-METHOD ',root
-                (LAMBDA (,name PORT)
-                  (WRITE-CHAR #\SPACE PORT)
-                  (WRITE (,(close-syntax accessor environment) ,name)
-                         PORT))))))
+              (SIMPLE-UNPARSER-METHOD ',root
+                (LAMBDA (,name)
+                  (LIST (,(close-syntax accessor environment) ,name)))))))
         (ill-formed-syntax form)))))
 
 (define-xml-printer processing-instructions xml-processing-instructions-name)