From b8588b93a5001b6eda7dea455f507e8762877454 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 Jun 1987 20:11:29 +0000
Subject: [PATCH] Add new objects to set of things that do not print.  Change
 `unparse-object' (in `unparser-package') to require its third argument.

---
 v7/src/runtime/format.scm | 48 +++++++++++------------
 v7/src/runtime/output.scm | 80 +++++++++++++++++++++------------------
 v7/src/runtime/unpars.scm |  6 +--
 3 files changed, 70 insertions(+), 64 deletions(-)

diff --git a/v7/src/runtime/format.scm b/v7/src/runtime/format.scm
index 42536804f..60f147e32 100644
--- a/v7/src/runtime/format.scm
+++ b/v7/src/runtime/format.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 13.42 1987/03/17 18:49:48 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 13.43 1987/06/17 20:10:38 cph Rel $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -52,28 +52,28 @@
 ;;;; Top Level
 
 (set! format
-(named-lambda (format port-or-string . arguments)
-  (cond ((null? port-or-string)
-	 (if (and (not (null? arguments))
-		  (string? (car arguments)))
-	     (with-output-to-string
-	      (lambda ()
-		(format-start (car arguments) (cdr arguments))))
-	     (error "Missing format string" 'FORMAT)))
-	((string? port-or-string)
-	 (format-start port-or-string arguments)
-	 *the-non-printing-object*)
-	((output-port? port-or-string)
-	 (if (and (not (null? arguments))
-		  (string? (car arguments)))
-	     (begin (with-output-to-port port-or-string
-		      (lambda ()
-			(format-start (car arguments) (cdr arguments))))
-		    *the-non-printing-object*)
-	     (error "Missing format string" 'FORMAT)))
-	(else
-	 (error "Unrecognizable first argument" 'FORMAT
-		port-or-string)))))
+  (named-lambda (format port-or-string . arguments)
+    (cond ((null? port-or-string)
+	   (if (and (not (null? arguments))
+		    (string? (car arguments)))
+	       (with-output-to-string
+		(lambda ()
+		  (format-start (car arguments) (cdr arguments))))
+	       (error "Missing format string" 'FORMAT)))
+	  ((string? port-or-string)
+	   (format-start port-or-string arguments)
+	   *the-non-printing-object*)
+	  ((output-port? port-or-string)
+	   (if (and (not (null? arguments))
+		    (string? (car arguments)))
+	       (begin (with-output-to-port port-or-string
+			(lambda ()
+			  (format-start (car arguments) (cdr arguments))))
+		      *the-non-printing-object*)
+	       (error "Missing format string" 'FORMAT)))
+	  (else
+	   (error "Unrecognizable first argument" 'FORMAT
+		  port-or-string)))))
 
 (define (format-start string arguments)
   (format-loop string arguments)
@@ -91,7 +91,7 @@
 
 (define (*unparse-object object)
   (declare (integrate object))
-  ((access unparse-object unparser-package) object *current-output-port*))
+  ((access unparse-object unparser-package) object *current-output-port* true))
 
 (define (format-loop string arguments)
   (let ((index (string-find-next-char string #\~)))
diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index d9e27dc67..f1b945e33 100644
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.43 1987/04/25 09:44:31 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.44 1987/06/17 20:11:29 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -273,13 +273,6 @@
 
 ;;;; Output Procedures
 
-(define (non-printing-object? object)
-  (and (not (future? object))
-       (eq? object *the-non-printing-object*)))
-
-(define (unparse-with-brackets thunk)
-  ((access unparse-with-brackets unparser-package) thunk))
-
 (define (newline #!optional port)
   (cond ((unassigned? port) (set! port *current-output-port*))
 	((not (output-port? port)) (error "Bad output port" port)))
@@ -301,32 +294,47 @@
   ((access :flush-output port))
   *the-non-printing-object*)
 
-(define (make-unparser handler)
-  (lambda (object #!optional port)
-    (if (not (non-printing-object? object))
-	(if (unassigned? port)
-	    (handler object *current-output-port*)
-	    (with-output-to-port port (lambda () (handler object port)))))
-    *the-non-printing-object*))
-	   
-(define display
-  (make-unparser
-   (lambda (object port)
-     (if (and (not (future? object)) (string? object))
-	 ((access :write-string port) object)
-	 ((access unparse-object unparser-package) object port false))
-     ((access :flush-output port)))))
-
-(define write
-  (make-unparser
-   (lambda (object port)
-     ((access unparse-object unparser-package) object port)
-     ((access :flush-output port)))))
-
-(define write-line
-  (make-unparser
-   (lambda (object port)
-      ((access :write-char port) char:newline)
-      ((access unparse-object unparser-package) object port)
-      ((access :flush-output port)))))
+(define (unparse-with-brackets thunk)
+  ((access unparse-with-brackets unparser-package) thunk))
+
+(define non-printing-object?
+  (let ((objects
+	 (list *the-non-printing-object*
+	       undefined-conditional-branch
+	       (vector-ref (get-fixed-objects-vector)
+			   (fixed-objects-vector-slot 'NON-OBJECT)))))
+    (named-lambda (non-printing-object? object)
+      (and (not (future? object))
+	   (memq object objects)))))
+
+(define display)
+(define write)
+(define write-line)
+
+(let ((make-unparser
+       (lambda (handler)
+	 (lambda (object #!optional port)
+	   (if (not (non-printing-object? object))
+	       (begin (if (unassigned? port)
+			  (handler object *current-output-port*)
+			  (with-output-to-port port
+			    (lambda ()
+			      (handler object port))))
+		      ((access :flush-output port))))
+	   *the-non-printing-object*))))
+  (set! display
+    (make-unparser
+     (lambda (object port)
+       (if (and (not (future? object))
+		(string? object))
+	   ((access :write-string port) object)
+	   ((access unparse-object unparser-package) object port false)))))
+  (set! write
+    (make-unparser
+     (lambda (object port)
+       ((access unparse-object unparser-package) object port true))))
+  (set! write-line
+    (make-unparser
+     (lambda (object port)
+	((access :write-char port) char:newline)
 	((access :flush-output port))))))
\ No newline at end of file
diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 61c675428..2646d441a 100644
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.46 1987/06/15 23:42:12 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.47 1987/06/17 20:09:58 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -60,8 +60,7 @@
   (thunk)
   (*unparse-char #\]))
 
-(define (unparse-object object port #!optional slashify)
-  (if (unassigned? slashify) (set! slashify true))
+(define (unparse-object object port slashify)
   (fluid-let ((*unparse-char (access :write-char port))
 	      (*unparse-string (access :write-string port))
 	      (*unparser-list-depth* 0)
@@ -331,5 +330,4 @@
 (define-type 'COMPLEX unparse-number)
 
 ;;; end UNPARSER-PACKAGE.
-))
 ))
\ No newline at end of file
-- 
2.25.1