From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 21 Oct 1993 13:57:33 +0000 (+0000)
Subject: * Implement new procedure STANDARD-UNPARSER-METHOD.  This has a
X-Git-Tag: 20090517-FFI~7714
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3ec3cc6303768fca05466a3deb251469af1dcb0c;p=mit-scheme.git

* 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 eab1d47a2..d7d825568 100644
--- 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))
 
-(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)))
-
+
 (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 14e8661bc..d87793d04 100644
--- 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 e139bbbee..6f054a3e8 100644
--- 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 3a42552de..bb8eb8091 100644
--- 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))))
 
 ;;;; 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 e139bbbee..6f054a3e8 100644
--- 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