* Implement new procedure STANDARD-UNPARSER-METHOD. This has a

  less-idiosyncratic interface than UNPARSER/STANDARD-METHOD.  Uses of
  the latter should be replaced with the former.

* Implement new procedure WITH-CURRENT-UNPARSER-STATE which calls its
  second argument with the port from its first.  The other components
  of the state are fluid-bound so that they become the defaults for
  calls to WRITE and DISPLAY.

* GUARANTEE-UNPARSER-STATE and GUARANTEE-UNPARSER-TABLE now take an
  addition argument, the name of the procedure testing its argument.

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index eab1d47a29015e5141c39435f02c5ffd85b14fce..d7d825568e429aa73e8b966196694e82d815cc77 100644 (file)
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: boot.scm,v 14.9 1993/08/31 08:42:34 cph Exp $
+$Id: boot.scm,v 14.10 1993/10/21 13:57:29 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -37,31 +37,49 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 \f
-(define (unparser/standard-method name #!optional unparser)
-  (lambda (state object)
-    (if (not (unparser-state? state)) (error "Bad unparser state" state))
-    (let ((port (unparser-state/port state))
-         (hash-string (number->string (hash object))))
-      (if *unparse-with-maximum-readability?*
-         (begin
-           (write-string "#@" port)
-           (write-string hash-string port))
-         (begin
-           (write-string "#[" port)
-           (if (string? name)
-               (write-string name port)
-               (unparse-object state name))
-           (write-char #\space port)
-           (write-string hash-string port)
-           (if (and (not (default-object? unparser)) unparser)
-               (begin (write-char #\Space port)
-                      (unparser state object)))
-           (write-char #\] port))))))
+(define standard-unparser-method)
+(define unparser/standard-method)
+(let ((make-method
+       (lambda (name unparser)
+        (lambda (state object)
+          (let ((port (unparser-state/port state))
+                (hash-string (number->string (hash object))))
+            (if *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))))))))
+  (set! standard-unparser-method
+       (lambda (name unparser)
+         (make-method name
+                      (and unparser
+                           (lambda (state object)
+                             (with-current-unparser-state state
+                               (lambda (port)
+                                 (unparser object port))))))))
+  (set! unparser/standard-method
+       (lambda (name #!optional unparser)
+         (make-method name
+                      (and (not (default-object? unparser))
+                           unparser
+                           (lambda (state object)
+                             (unparse-char state #\space)
+                             (unparser state object)))))))
 
 (define (unparser-method? object)
   (and (procedure? object)
        (procedure-arity-valid? object 2)))
-
+\f
 (define-integrable interrupt-bit/stack     #x0001)
 (define-integrable interrupt-bit/global-gc #x0002)
 (define-integrable interrupt-bit/gc        #x0004)

diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index 14e8661bc666dc7167b800677682e7f0281eb6be..d87793d04275360ffcfc57d04b3552f8430ee9be 100644 (file)
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: output.scm,v 14.15 1993/10/21 11:49:47 cph Exp $
+$Id: output.scm,v 14.16 1993/10/21 13:57:30 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -49,7 +49,7 @@ MIT in each case. |#
   ((output-port/operation/write-substring port) port string start end))
 
 (define (output-port/write-object port object)
-  (unparse-object/internal object port 0 true (current-unparser-table)))
+  (unparse-object/top-level object port #t (current-unparser-table)))
 
 (define (output-port/flush-output port)
   ((output-port/operation/flush-output port) port))
@@ -131,10 +131,10 @@ MIT in each case. |#
        (unparser-table
         (if (default-object? unparser-table)
             (current-unparser-table)
-            (guarantee-unparser-table unparser-table))))
+            (guarantee-unparser-table unparser-table 'DISPLAY))))
     (if (string? object)
        (output-port/write-string port object)
-       (unparse-object/internal object port 0 false unparser-table))
+       (unparse-object/top-level object port #f unparser-table))
     (output-port/discretionary-flush port)))
 
 (define (write object #!optional port unparser-table)
@@ -145,8 +145,8 @@ MIT in each case. |#
        (unparser-table
         (if (default-object? unparser-table)
             (current-unparser-table)
-            (guarantee-unparser-table unparser-table))))
-    (unparse-object/internal object port 0 true unparser-table)
+            (guarantee-unparser-table unparser-table 'WRITE))))
+    (unparse-object/top-level object port #t unparser-table)
     (output-port/discretionary-flush port)))
 
 (define (write-line object #!optional port unparser-table)
@@ -157,9 +157,9 @@ MIT in each case. |#
        (unparser-table
         (if (default-object? unparser-table)
             (current-unparser-table)
-            (guarantee-unparser-table unparser-table))))
+            (guarantee-unparser-table unparser-table 'WRITE-LINE))))
     (output-port/write-char port #\Newline)
-    (unparse-object/internal object port 0 true unparser-table)
+    (unparse-object/top-level object port #t unparser-table)
     (output-port/discretionary-flush port)))
 
 (define (flush-output #!optional port)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index e139bbbeebc0379f4eae9f7a1bcccc5d58c5ca6e..6f054a3e8984b56a2cdba36e0e00f4697c92eeae 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.208 1993/10/21 12:14:20 cph Exp $
+$Id: runtime.pkg,v 14.209 1993/10/21 13:57:31 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -2465,9 +2465,10 @@ MIT in each case. |#
          unparser-table/entry
          unparser-table/set-entry!
          unparser-table?
-         user-object-type)
+         user-object-type
+         with-current-unparser-state)
   (export (runtime output-port)
-         unparse-object/internal)
+         unparse-object/top-level)
   (export (runtime pretty-printer)
          unparse-list/prefix-pair?
          unparse-list/unparser

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 3a42552de3463255ce45dd29bbafcb86fc7926c7..bb8eb809155b0d4666bc9fdb1070837490ea16e8 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unpars.scm,v 14.31 1993/06/18 02:45:33 gjr Exp $
+$Id: unpars.scm,v 14.32 1993/10/21 13:57:33 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -54,6 +54,7 @@ MIT in each case. |#
   (set! *unparse-disambiguate-null-lambda-list?* false)
   (set! *unparse-compound-procedure-names?* true)
   (set! system-global-unparser-table (make-system-global-unparser-table))
+  (set! *default-list-depth* 0)
   (set-current-unparser-table! system-global-unparser-table))
 
 (define *unparser-radix*)
@@ -67,13 +68,14 @@ MIT in each case. |#
 (define *unparse-disambiguate-null-lambda-list?*)
 (define *unparse-compound-procedure-names?*)
 (define system-global-unparser-table)
+(define *default-list-depth*)
 (define *current-unparser-table*)
 
 (define (current-unparser-table)
   *current-unparser-table*)
 
 (define (set-current-unparser-table! table)
-  (guarantee-unparser-table table)
+  (guarantee-unparser-table table 'SET-CURRENT-UNPARSER-TABLE!)
   (set! *current-unparser-table* table)
   unspecific)
 
@@ -114,8 +116,9 @@ MIT in each case. |#
                                  (conc-name unparser-table/))
   (dispatch-vector false read-only true))
 
-(define (guarantee-unparser-table table)
-  (if (not (unparser-table? table)) (error "Bad unparser table" table))
+(define (guarantee-unparser-table table procedure)
+  (if (not (unparser-table? table))
+      (error:wrong-type-argument table "unparser table" procedure))
   table)
 
 (define (make-unparser-table default-method)
@@ -140,28 +143,39 @@ MIT in each case. |#
   (slashify? false read-only true)
   (unparser-table false read-only true))
 
-(define (guarantee-unparser-state state)
-  (if (not (unparser-state? state)) (error "Bad unparser state" state))
+(define (guarantee-unparser-state state procedure)
+  (if (not (unparser-state? state))
+      (error:wrong-type-argument table state "unparser state" procedure))
   state)
+
+(define (with-current-unparser-state state procedure)
+  (guarantee-unparser-state state 'WITH-CURRENT-UNPARSER-STATE)
+  (fluid-let
+      ((*default-list-depth* (unparser-state/list-depth state))
+       (*current-unparser-table* (unparser-state/list-unparser-table state)))
+    (procedure (unparser-state/port state))))
 \f
 ;;;; Top Level
 
 (define (unparse-char state char)
-  (guarantee-unparser-state state)
+  (guarantee-unparser-state state 'UNPARSE-CHAR)
   (write-char char (unparser-state/port state)))
 
 (define (unparse-string state string)
-  (guarantee-unparser-state state)
+  (guarantee-unparser-state state 'UNPARSE-STRING)
   (write-string string (unparser-state/port state)))
 
 (define (unparse-object state object)
-  (guarantee-unparser-state state)
+  (guarantee-unparser-state state 'UNPARSE-OBJECT)
   (unparse-object/internal object
                           (unparser-state/port state)
                           (unparser-state/list-depth state)
                           (unparser-state/slashify? state)
                           (unparser-state/unparser-table state)))
 
+(define (unparse-object/top-level object port slashify? table)
+  (unparse-object/internal object port *default-list-depth* slashify? table))
+
 (define (unparse-object/internal object port list-depth slashify? table)
   (fluid-let ((*output-port* port)
              (*list-depth* list-depth)

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index e139bbbeebc0379f4eae9f7a1bcccc5d58c5ca6e..6f054a3e8984b56a2cdba36e0e00f4697c92eeae 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.208 1993/10/21 12:14:20 cph Exp $
+$Id: runtime.pkg,v 14.209 1993/10/21 13:57:31 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -2465,9 +2465,10 @@ MIT in each case. |#
          unparser-table/entry
          unparser-table/set-entry!
          unparser-table?
-         user-object-type)
+         user-object-type
+         with-current-unparser-state)
   (export (runtime output-port)
-         unparse-object/internal)
+         unparse-object/top-level)
   (export (runtime pretty-printer)
          unparse-list/prefix-pair?
          unparse-list/unparser