205 lines
7.7 KiB
Scheme
205 lines
7.7 KiB
Scheme
;;;
|
||
;;; Copyright (c) 1985 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.
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;;
|
||
;;; Modified by Texas Instruments Inc 8/15/85
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;; File IO
|
||
|
||
(define read-buffer
|
||
(lambda (buffer filename)
|
||
(region-delete! (buffer-region buffer))
|
||
(if (file-exists? filename)
|
||
(begin
|
||
(let ((region (file->region-interactive filename)))
|
||
(vector-set! (current-window) window:point
|
||
(mark-right-inserting (buffer-start buffer)))
|
||
(region-insert! (buffer-start buffer) region))
|
||
(set-current-point! (buffer-start buffer)))
|
||
(temporary-message "(New File)"))
|
||
(set-buffer-truename! buffer filename)
|
||
(set-buffer-pathname! buffer filename)
|
||
(buffer-not-modified! buffer)))
|
||
|
||
(define insert-file
|
||
(lambda (mark filename)
|
||
(if (file-exists? filename)
|
||
(region-insert! mark (file->region-interactive filename))
|
||
(editor-error (string-append "File " filename " not found")))))
|
||
|
||
(define file->region-interactive
|
||
(lambda (filename)
|
||
(temporary-message (string-append "Reading file " filename))
|
||
(let ((region (file->region filename)))
|
||
(append-message " -- done")
|
||
region)))
|
||
|
||
(define file->region
|
||
(lambda (filename)
|
||
(let ((port '()))
|
||
(dynamic-wind
|
||
(lambda () (set! port (open-input-file filename)))
|
||
(lambda () (file-stream->region port))
|
||
(lambda () (close-input-port port))))))
|
||
|
||
(define (file-stream->region stream)
|
||
(let ((first-line (read-line stream)))
|
||
(if (not (eof-object? first-line))
|
||
(let ((first-line (make-line first-line))
|
||
(group (make-group #!FALSE)))
|
||
(define (%connect-lines previous-line this-line n)
|
||
(connect-lines! previous-line this-line)
|
||
(set-line-group! this-line group)
|
||
(set-line-number! this-line n))
|
||
(define (loop previous-line n this-line)
|
||
(if (not (eof-object? this-line))
|
||
(let ((this-line (make-line this-line)))
|
||
(%connect-lines previous-line this-line n)
|
||
(loop this-line (+ n line-number-increment)
|
||
(read-line stream)))
|
||
(let ((this-line (make-line "")))
|
||
(%connect-lines previous-line this-line n)
|
||
(let ((region
|
||
(components->region first-line 0 this-line
|
||
(line-length this-line))))
|
||
(%set-group-region! group region)
|
||
region))))
|
||
(set-line-group! first-line group)
|
||
(set-line-number! first-line 0)
|
||
(loop first-line line-number-increment (read-line stream)))
|
||
(let ((line (make-line "")))
|
||
(lines->region line line)))))
|
||
|
||
|
||
;;;; Output
|
||
(define write-buffer
|
||
(lambda (buffer filename)
|
||
(if (or (not (file-exists? filename))
|
||
(prompt-for-confirmation?
|
||
(string-append "File " filename
|
||
" exists. Write anyway (Y or N)?")))
|
||
(begin
|
||
(temporary-message (string-append "Writing file " filename))
|
||
(region->file (buffer-region buffer) filename)
|
||
(append-message " -- done")
|
||
(set-buffer-pathname! buffer filename)
|
||
(set-buffer-truename! buffer filename)
|
||
(buffer-not-modified! buffer)))))
|
||
|
||
(define write-region
|
||
(lambda (region filename)
|
||
(if (or (not (file-exists? filename))
|
||
(prompt-for-confirmation?
|
||
(string-append "File " filename
|
||
" exists. Write anyway (Y or N)?")))
|
||
(begin
|
||
(temporary-message (string-append "Writing file " filename))
|
||
(region->file region filename)
|
||
(append-message " -- done")))))
|
||
|
||
(define (region->file region filename)
|
||
(let ((port '()))
|
||
(dynamic-wind
|
||
(lambda () (set! port (open-output-file filename)))
|
||
(lambda () (region->filestream region port))
|
||
(lambda () (close-output-port port)))))
|
||
|
||
(define (region->filestream region stream)
|
||
(region-components region
|
||
(lambda (start-line start-position end-line end-position)
|
||
(if (eq? start-line end-line)
|
||
(princ (substring (line-string start-line)
|
||
start-position
|
||
end-position)
|
||
stream)
|
||
(begin
|
||
(princ (substring (line-string start-line)
|
||
start-position
|
||
(line-length start-line))
|
||
stream)
|
||
(let loop ((this-line (line-next start-line)))
|
||
(princ #\newline stream)
|
||
(if (eq? this-line end-line)
|
||
(princ (substring (line-string end-line)
|
||
0
|
||
end-position)
|
||
stream)
|
||
(begin (princ (line-string this-line) stream)
|
||
(loop (line-next this-line))))))))))
|
||
|
||
(define (save-buffer-changes buffer)
|
||
(if (and (buffer-pathname buffer)
|
||
(buffer-modified? buffer)
|
||
(buffer-writeable? buffer)
|
||
(prompt-for-confirmation?
|
||
(string-append "Buffer "
|
||
(buffer-name buffer)
|
||
" contains changes. Write them out (Y or N)?")))
|
||
(write-buffer buffer (buffer-pathname buffer))))
|
||
|
||
(define (%save-buffer-changes buffer)
|
||
(if (and (buffer-modified? buffer)
|
||
(buffer-writeable? buffer)
|
||
(prompt-for-confirmation?
|
||
(string-append "Buffer "
|
||
(buffer-name buffer)
|
||
" contains changes. Write them out (Y or N)?")))
|
||
(save-file buffer)))
|
||
|
||
(define (setup-current-buffer-read-only! argument)
|
||
((cond ((or (not argument) (zero? argument)) set-buffer-writeable!)
|
||
((negative? argument) set-buffer-read-only!)
|
||
(else set-buffer-file-read-only!))
|
||
(current-buffer)))
|
||
|
||
(define (save-file buffer)
|
||
(if (buffer-modified? buffer)
|
||
(if (or (buffer-writeable? buffer)
|
||
(prompt-for-confirmation?
|
||
(string-append "Buffer " (buffer-name buffer)
|
||
" is read only. Save anyway (Y or N)?")))
|
||
(write-buffer buffer
|
||
(let ((pathname (buffer-pathname buffer)))
|
||
(if (not pathname)
|
||
(prompt-for-pathname
|
||
"Write buffer to file : ")
|
||
pathname))))
|
||
(temporary-message "(No changes need to be written)")))
|
||
|
||
|
||
|