DataMuseum.dk

top - download

    Length: 7475 (0x1d33)
    Types: TextFile
    Names: »print.scm.196«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/print.scm.196« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Printer

(declare (usual-integrations))

(define output-stream-tag '(OUTPUT-STREAM))

(define (output-stream? object)
  (conjunction (environment? object)
	       (not (lexical-unreferenceable? object ':TYPE))
	       (eq? (access :type object) output-stream-tag)))
\f


;;;; Output Streams

(define (with-open-output-stream output-specifier receiver)
  (define stream #!FALSE)
  (dynamic-wind (lambda ()
		  '())
		(lambda ()
		  (set! stream (open-output-stream output-specifier))
		  (receiver stream))
		(lambda ()
		  (let ((c (set! stream #!FALSE)))
		    (if c (close-output-stream c))))))

(define current-output-stream)
(define set-current-output-stream!)

(let ((*output-stream* (make-environment (define :list-depth))))
  (set! current-output-stream
	(named-lambda (current-output-stream)
	  (set! (access :list-depth *output-stream*) *unparser-list-depth*)
	  *output-stream*))
  (set! set-current-output-stream!
	(named-lambda (set-current-output-stream! stream)
	  (set! *unparse-character (access :tyo stream))
	  (set! *unparse-string (access :string-out stream))
	  (set! (access :list-depth *output-stream*)
		(set! *unparser-list-depth*
		      (access :list-depth stream)))
	  (set! *output-stream* stream))))

(define (with-output-to-stream stream thunk)
  (define old-stream)
  (dynamic-wind (lambda ()
		  (set! old-stream (set-current-output-stream! stream)))
		thunk
		(lambda ()
		  (set! stream (set-current-output-stream! old-stream)))))

(define (close-output-stream stream)
  ((access :close stream)))

;; Very useful.

(define (with-output-to-file filename thunk)
  (with-open-output-stream filename
    (lambda (stream)
      (with-output-to-stream stream
	thunk))))
\f


;;;; Physical Channels

(define console-output-stream)
(define open-output-stream)

(let ((put-character-to-console
       (access put-character-to-output-channel primitive-io))
      (print-string-to-console (access print-string primitive-io)))

(declare (compilable-primitive-functions put-character-to-output-channel
					 print-string))

(set! console-output-stream
      (make-environment
       (define :type output-stream-tag)

       (define (:print-self)
	 (unparse-with-brackets
	  (lambda ()
	    (*unparse-string "Console output stream"))))

       (define :list-depth 0)

       (define (:tyo c)
	 (put-character-to-console
	  c ((access get-console-output-channel primitive-io))))

       (define (:string-out s)
	 (print-string-to-console
	  s ((access get-console-output-channel primitive-io))))))

(set-current-output-stream! console-output-stream)

(set! open-output-stream
      (named-lambda (open-output-stream output-specifier)
	(open-physical-output-stream
	 ((access open-output-channel primitive-io) output-specifier))))

(define (open-physical-output-stream physical-channel)
  (if ((access console-channel? primitive-io) physical-channel)
      console-output-stream
      (make-environment
       (define :type output-stream-tag)

       (define (:print-self)
	 (unparse-with-brackets
	  (lambda ()
	    (*unparse-string "Output stream for file: ")
	    (*unparse-object
	     ((access channel-name primitive-io) physical-channel)))))

       (define :list-depth 0)

       (define (:tyo c)
	 (put-character-to-output-channel c physical-channel))

       (define (:string-out s)
	 (print-string s physical-channel))

       (define (:close)
	 ((access close-physical-channel primitive-io) physical-channel)))))

;;; end LET.
)
\f


;;;; Printers

(define (tyo character #!optional stream)
  (if (unassigned? stream)
      (*unparse-character character)
      (with-output-to-stream stream
	(lambda ()
	  (*unparse-character character))))
  *the-non-printing-object*)

(define (newline #!optional stream)
  (if (unassigned? stream)
      (*unparse-character #\CR)
      (with-output-to-stream stream
	(lambda ()
	  (*unparse-character #\CR))))
  *the-non-printing-object*)

(define prin1)
(define princ)
(define print)

(let ((make-printer
       (lambda ((printer) object #!optional stream)
	 (if (not (eq? object *the-non-printing-object*))
	     (if (unassigned? stream)
		 (printer object)
		 (with-output-to-stream stream
		   (lambda ()
		     (printer object)))))
	 *the-non-printing-object*)))
  (set! prin1
	(make-printer
	 (lambda (object)
	   (*unparse-object object))))
  (set! princ
	(make-printer
	 (lambda (object)
	   ((if (string? object) *unparse-string *unparse-object)
	    object))))
  (set! print
	(make-printer
	 (lambda (object)
	   (*unparse-character #\CR)
	   (*unparse-object object)
	   (*unparse-character #\SP)))))
\f


;;;; String Output

(define (with-output-to-string thunk)
  (define accumulator '())

  (define stream
    (make-environment
     (define :type output-stream-tag)

     (define (:print-self)
       (unparse-with-brackets
	(lambda ()
	  (*unparse-string "Output stream to string"))))

     (define :list-depth 0)

     (define (:tyo c)
       (set! accumulator (cons (character->string c) accumulator)))

     (define (:string-out s)
       (set! accumulator (cons s accumulator)))))

  (with-output-to-stream stream thunk)
  (apply string-append (reverse! accumulator)))

(define (with-output-to-truncated-string maxsize thunk)
  (catch
   (lambda (return)
     (define accumulator "")

     (define (maybe-truncate)
       (if (> (string-size accumulator) maxsize)
	   (return (cons #!TRUE (truncate-string! accumulator maxsize)))))

     (define stream
       (make-environment
	(define :type output-stream-tag)

	(define (:print-self)
	  (unparse-with-brackets
	   (lambda ()
	     (*unparse-string "Output stream to truncated string"))))

	(define :list-depth 0)

	(define (:tyo c)
	  (set! accumulator
		(string-append accumulator (character->string c)))
	  (maybe-truncate))
	
	(define (:string-out s)
	  (set! accumulator (string-append accumulator s))
	  (maybe-truncate))))

     (with-output-to-stream stream thunk)
     (cons #!FALSE accumulator))))