home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / EDWINIO.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  7.7 KB  |  205 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;; File IO
  43.  
  44. (define read-buffer
  45.   (lambda (buffer filename)
  46.     (region-delete! (buffer-region buffer))
  47.     (if (file-exists? filename)
  48.         (begin
  49.           (let ((region (file->region-interactive filename)))
  50.             (vector-set! (current-window) window:point
  51.                          (mark-right-inserting (buffer-start buffer)))
  52.             (region-insert! (buffer-start buffer) region))
  53.       (set-current-point! (buffer-start buffer)))
  54.         (temporary-message "(New File)"))
  55.     (set-buffer-truename! buffer filename)
  56.     (set-buffer-pathname! buffer filename)
  57.     (buffer-not-modified! buffer)))
  58.  
  59. (define insert-file
  60.   (lambda (mark filename)
  61.     (if (file-exists? filename)
  62.         (region-insert! mark (file->region-interactive filename))
  63.         (editor-error (string-append "File " filename " not found")))))
  64.  
  65. (define file->region-interactive
  66.   (lambda (filename)
  67.     (temporary-message (string-append "Reading file " filename))
  68.     (let ((region (file->region filename)))
  69.       (append-message " -- done")
  70.       region)))
  71.  
  72. (define file->region
  73.   (lambda (filename)
  74.     (let ((port '()))
  75.       (dynamic-wind
  76.         (lambda () (set! port (open-input-file filename)))
  77.         (lambda () (file-stream->region port))
  78.         (lambda () (close-input-port port))))))
  79.  
  80. (define (file-stream->region stream)
  81.   (let ((first-line (read-line stream)))
  82.     (if (not (eof-object? first-line))
  83.     (let ((first-line (make-line first-line))
  84.           (group (make-group #F)))
  85.           (define (%connect-lines previous-line this-line n)
  86.         (connect-lines! previous-line this-line)
  87.         (set-line-group! this-line group)
  88.         (set-line-number! this-line n))
  89.       (define (loop previous-line n this-line)
  90.             (if (not (eof-object? this-line))
  91.         (let ((this-line (make-line this-line)))
  92.                   (%connect-lines previous-line this-line n)
  93.           (loop this-line (+ n line-number-increment)
  94.             (read-line stream)))
  95.         (let ((this-line (make-line "")))
  96.                   (%connect-lines previous-line this-line n)
  97.           (let ((region
  98.               (components->region first-line 0 this-line
  99.                         (line-length this-line))))
  100.             (%set-group-region! group region)
  101.             region))))
  102.       (set-line-group! first-line group)
  103.       (set-line-number! first-line 0)
  104.       (loop first-line line-number-increment (read-line stream)))
  105.     (let ((line (make-line "")))
  106.           (lines->region line line)))))
  107.  
  108.  
  109. ;;;; Output
  110. (define write-buffer
  111.   (lambda (buffer filename)
  112.     (if (or (not (file-exists? filename))
  113.             (prompt-for-confirmation?
  114.            (string-append "File " filename
  115.                               " exists.  Write anyway (Y or N)?")))
  116.         (begin
  117.           (temporary-message (string-append "Writing file " filename))
  118.           (region->file (buffer-region buffer) filename)
  119.           (append-message " -- done")
  120.           (set-buffer-pathname! buffer filename)
  121.           (set-buffer-truename! buffer filename)
  122.           (buffer-not-modified! buffer)))))
  123.  
  124. (define write-region
  125.   (lambda (region filename)
  126.     (if (or (not (file-exists? filename))
  127.             (prompt-for-confirmation?
  128.            (string-append "File " filename
  129.                               " exists.  Write anyway (Y or N)?")))
  130.         (begin
  131.           (temporary-message (string-append "Writing file " filename))
  132.           (region->file region filename)
  133.           (append-message " -- done")))))
  134.  
  135. (define (region->file region filename)
  136.   (let ((port '()))
  137.     (dynamic-wind
  138.       (lambda () (set! port (open-output-file filename)))
  139.       (lambda () (region->filestream region port))
  140.       (lambda () (close-output-port port)))))
  141.  
  142. (define (region->filestream region stream)
  143.   (region-components region
  144.     (lambda (start-line start-position end-line end-position)
  145.       (if (eq? start-line end-line)
  146.       (princ (substring (line-string start-line)
  147.                       start-position
  148.                       end-position)
  149.                  stream)
  150.       (begin
  151.        (princ (substring (line-string start-line)
  152.                        start-position
  153.                        (line-length start-line))
  154.                   stream)
  155.        (let loop ((this-line (line-next start-line)))
  156.          (princ #\newline stream)
  157.          (if (eq? this-line end-line)
  158.                  (princ (substring (line-string end-line)
  159.                                    0
  160.                                    end-position)
  161.                         stream)
  162.          (begin (princ (line-string this-line) stream)
  163.                         (loop (line-next this-line))))))))))
  164.  
  165. (define (save-buffer-changes buffer)
  166.   (if (and (buffer-pathname buffer)
  167.        (buffer-modified? buffer)
  168.        (buffer-writeable? buffer)
  169.        (prompt-for-confirmation?
  170.         (string-append "Buffer "
  171.                            (buffer-name buffer)
  172.                            " contains changes.  Write them out (Y or N)?")))
  173.       (write-buffer buffer (buffer-pathname buffer))))
  174.  
  175. (define (%save-buffer-changes buffer)
  176.   (if (and (buffer-modified? buffer)
  177.        (buffer-writeable? buffer)
  178.        (prompt-for-confirmation?
  179.         (string-append "Buffer "
  180.                            (buffer-name buffer)
  181.                            " contains changes.  Write them out (Y or N)?")))
  182.        (save-file buffer)))
  183.  
  184. (define (setup-current-buffer-read-only! argument)
  185.   ((cond ((or (not argument) (zero? argument)) set-buffer-writeable!)
  186.      ((negative? argument) set-buffer-read-only!)
  187.      (else set-buffer-file-read-only!))
  188.    (current-buffer)))
  189.  
  190. (define (save-file buffer)
  191.   (if (buffer-modified? buffer)
  192.       (if (or (buffer-writeable? buffer)
  193.           (prompt-for-confirmation?
  194.            (string-append "Buffer " (buffer-name buffer)
  195.                                " is read only.  Save anyway (Y or N)?")))
  196.       (write-buffer buffer
  197.             (let ((pathname (buffer-pathname buffer)))
  198.                           (if (not pathname)
  199.                               (prompt-for-pathname
  200.                                 "Write buffer to file : ")
  201.                               pathname))))
  202.       (temporary-message "(No changes need to be written)")))
  203.  
  204.  
  205.