DataMuseum.dk

top - download

    Length: 7425 (0x1d01)
    Types: TextFile
    Names: »read.scm.181«

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

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.
;;;

;;;; Reader

(declare (usual-integrations))

(define input-stream-tag '(INPUT-STREAM))

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


;;;; Streams

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

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

(let ((*input-stream* (make-environment (define :character-buffer))))
  (set! current-input-stream
	(named-lambda (current-input-stream)
	  (set! (access :character-buffer *input-stream*)
		*get-character-buffer*)
	  *input-stream*))
  (set! set-current-input-stream!
	(named-lambda (set-current-input-stream! input-stream)
	  (set! *get-character
		(access :tyi input-stream))
	  (set! *get-character-immediate
		(access :tyi-immediate input-stream))
	  (set! (access :character-buffer *input-stream*)
		*get-character-buffer*)
	  (set! *get-character-buffer*
		(access :character-buffer input-stream))
	  (set! *input-stream* input-stream))))

(define *get-character-immediate)

(define (*tyi-immediate)
  (disjunction (set! *get-character-buffer* #!FALSE)
	       (*get-character-immediate)))

(define (*tyipeek-immediate)
  (disjunction *get-character-buffer*
	       (sequence (set! *get-character-buffer*
			       (*get-character-immediate))
			 *get-character-buffer*)))

(define (with-input-from-stream stream thunk)
  (define old-stream)
  (dynamic-wind (lambda ()
		  (set! old-stream (set-current-input-stream! stream)))
		thunk
		(lambda ()
		  (set! stream (set-current-input-stream! old-stream)))))

(define (with-eof-action eof-action thunk)
  (define old-eof-action)
  (dynamic-wind (lambda ()
		  (set! old-eof-action (set! *eof-action eof-action)))
		thunk
		(lambda ()
		  (set! eof-action (set! *eof-action (set! old-eof-action))))))

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

;; Very useful.

(define (with-input-from-file filename thunk)
  (with-open-input-stream filename
    (lambda (stream)
      (with-input-from-stream stream
	thunk))))
\f


;;;; Physical Channels

(define console-input-stream)
(define open-input-stream)

(let ((get-character-from-input-channel
       (access GET-CHARACTER-FROM-INPUT-CHANNEL primitive-io))
      (get-character-from-input-channel-immediate
       (access GET-CHARACTER-FROM-INPUT-CHANNEL-IMMEDIATE
	       primitive-io)))

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

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

       (define :character-buffer #!FALSE)

       (define (:tyi)
	 (get-character-from-input-channel
	  ((access get-console-input-channel primitive-io))))

       (define (:tyi-immediate)
	 (get-character-from-input-channel-immediate
	  ((access get-console-input-channel primitive-io))))

       (define (:console-cleanup)
	 (let loop ()
	   (cond (((access input-terminator? character-package) (*tyipeek))
		  (*dismiss-character))
		 (((access whitespace? character-package) (*tyipeek))
		  (*dismiss-character)
		  (loop)))))
       ))

(set-current-input-stream! console-input-stream)
\f


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

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

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

       (define :character-buffer #!FALSE)

       (define (:tyi)
	 (get-character-from-input-channel physical-channel))

       (define (:tyi-immediate)
	 (get-character-from-input-channel-immediate physical-channel))

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

;;; end LET.
)
\f


;;;; Traditional Input Routines

(define tyi)
(define tyipeek)
(define read)

(let ((make-reader
       (lambda ((read) #!optional stream eof-option)
	 (if (unassigned? stream)
	     (read)
	     (with-input-from-stream stream
	       (lambda ()
		 (if (unassigned? eof-option)
		     (read)
		     (with-eof-action (lambda () eof-option)
		       read))))))))
  (set! tyi
	(make-reader
	 (lambda ()
	   (let ((c (*tyi-immediate)))
	     (if (character-equal? c (access end-of-file character-package))
		 (*eof-action)
		 c)))))
  (set! tyipeek
	(make-reader
	 (lambda ()
	   (let ((c (*tyipeek-immediate)))
	     (if (character-equal? c (access end-of-file character-package))
		 (*eof-action)
		 c)))))
  (set! read
	(make-reader
	 (lambda ()
	   (let ((object (*read)))
	     (if (not (lexical-unreferenceable? (current-input-stream)
						':CONSOLE-CLEANUP))
		 ((access :console-cleanup (current-input-stream))))
	     object)))))
\f


;;;; String Input

(define (with-input-from-string string thunk)
  (define stream
    (make-environment
     (define :type input-stream-tag)

     (define (:print-self)
       (unparse-with-brackets
	(lambda ()
	  (*unparse-string "Input stream from string"))))

     (define :character-buffer #!FALSE)
     (define characters (string->list string))

     (define (:tyi)
       (if (null? characters)
	   (access end-of-file character-package)
	   (car (set! characters (cdr characters)))))

     (define :tyi-immediate :tyi)))

  (with-input-from-stream stream thunk))