⟦1cd8b8d49⟧

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

;;;; File Package

(declare (usual-integrations))
\f


(define directory)
(define enumerate-file-names)
(define enumerate-files)

(define initialize-floppy)
(define backup-floppy)

(define set-prefix!)
(define get-current-prefix)

(define get-unit-name)
(define list-file)
(define crunch)

(define file-package
  (make-package file-package
     ((open-catalog (make-primitive-procedure 'OPEN-CATALOG))
      (close-catalog (make-primitive-procedure 'CLOSE-CATALOG))
      (next-file (make-primitive-procedure 'NEXT-FILE))
      (cat-name (make-primitive-procedure 'CAT-NAME))
      (cat-kind (make-primitive-procedure 'CAT-KIND))
      (cat-psize (make-primitive-procedure 'CAT-PSIZE))
      (cat-lsize (make-primitive-procedure 'CAT-LSIZE))
      (cat-info (make-primitive-procedure 'CAT-INFO))
      (cat-block (make-primitive-procedure 'CAT-BLOCK))
      (cat-create-date (make-primitive-procedure 'CAT-CREATE-DATE))
      (cat-create-time (make-primitive-procedure 'CAT-CREATE-TIME))
      (cat-last-date (make-primitive-procedure 'CAT-LAST-DATE))
      (cat-last-time (make-primitive-procedure 'CAT-LAST-TIME))
      (translate-file (make-primitive-procedure 'TRANSLATE-FILE))
      (link-file (make-primitive-procedure 'LINK-FILE))
      (volume-name (make-primitive-procedure 'VOLUME-NAME))
      (prefix-volume (make-primitive-procedure 'PREFIX-VOLUME))
      (init-floppy (make-primitive-procedure 'INIT-FLOPPY))
      (zero-floppy (make-primitive-procedure 'ZERO-FLOPPY))
      (make-directory (make-primitive-procedure 'MAKE-DIRECTORY))
      (error-message (make-primitive-procedure 'ERROR-MESSAGE))
      (crunch-directory (make-primitive-procedure 'PACK-VOLUME))
      (name-source "RAM:MACHINE.NAME")
      (machine-id '())
      (printer-name "#5:/LPT/")
      (list-file-count 0)
      (EXECUTE-KEY 254))
\f


;;;; Directory Enumeration

(define (full-directory name)
  (let loop ((stream (enumerate-files name)))
    (if (empty-stream? stream)
	'()
	(sequence (print ((head stream) 'EVERYTHING))
		  (loop (tail stream))))))

(define (copy-directory from to)
  (let loop ((stream (enumerate-file-names from)))
    (if (empty-stream? stream)
	'()
	(sequence
	 (let ((From-File (make-file-name from (head stream)))
	       (To-File   (make-file-name to   (head stream))))
	   (print (list 'COPYING 'FROM From-File 'TO To-File))
	   (copy-file From-File To-File))
	 (loop (tail stream))))))

(define (make-file-name directory file)
  (if (eq? #/: (string-ref directory (-1+ (string-size directory))))
      (string-append (canonicalize-filename directory) file)
      (string-append (canonicalize-filename directory) "/" file)))

(set! directory
(named-lambda (directory . name)
  (if (not name) (set! name ":"))
  (let loop ((stream (enumerate-file-names name)))
    (if (empty-stream? stream)
	'()
	(sequence (format "~%~s" (head stream))
		  (loop (tail stream)))))))

(set! enumerate-file-names
(named-lambda (enumerate-file-names name)
  (open-catalog (canonicalize-filename name))
  (let loop ()
    (if (next-file)
	(cons-stream (let ((str (make-empty-string 80)))
		       (cat-name str)
		       (string-append "" str))
		     (loop))
	(sequence (close-catalog)
		  the-empty-stream)))))

(set! enumerate-files
(named-lambda (enumerate-files name)
  (open-catalog (canonicalize-filename name))
  (let loop ()
    (if (next-file)
	(cons-stream (current-catalog-file) (loop))
	(sequence (close-catalog)
		  the-empty-stream)))))
\f


(define (current-catalog-file)
  (let ((name-string (make-empty-string 80))
	(create-date (make-empty-string 80))
	(create-time (make-empty-string 80))
	(last-date   (make-empty-string 80))
	(last-time   (make-empty-string 80))
	(info        (make-empty-string 80))
	(data `((KIND  . ,(cat-kind))
		(PSIZE . ,(cat-psize))
		(LSIZE . ,(cat-lsize))
		(BLOCK . ,(cat-block)))))
    (cat-name name-string)
    (cat-info info)
    (cat-last-date last-date)
    (cat-last-time last-time)
    (set! data 
	  (cons* `(NAME        . ,(string-copy name-string))
		 `(INFO        . ,(string-copy info))
		 `(LAST-DATE   . ,(string-copy last-date))
		 `(LAST-TIME   . ,(string-copy last-time))
		 data))
    (if (string-equal? info "WS1.0")
	(sequence
	 (set! create-date '())
	 (set! create-time '()))
	(sequence
	 (cat-create-date create-date)
	 (cat-create-time create-time)
	 (set! data 
	       (cons* `(CREATE-DATE . ,(string-copy create-date))
		      `(CREATE-TIME . ,(string-copy create-time))
		      data))))
    (set! name-string '())
    (set! last-date '())
    (set! last-time '())
    (set! info '())
    (lambda (message)
      (if (eq? message 'EVERYTHING)
	  data
	  (cdr (assq message data))))))
\f


(set! list-file
(named-lambda (list-file file)
  (let ((f (canonicalize-filename file)))
    (if (file-exists? f)
	(let ((p (printer-destination)))
	  (format "~%Processing %s ..." f)
	  (if (zero? (translate-file f p))
	      (format "~%~s has been queued for printing as ~s" f p)
	      (format "LIST-FILE aborted because of translation error.")))
	(format "~%LIST-FILE aborted because ~s doesn't exist." f)))))

(define (printer-destination)
  (set! list-file-count (1+ list-file-count))
  (if (= list-file-count 100)
      (set! list-file-count 0))
  (string-append printer-name
		 (access *machine-name* system-global-environment)
		 "-"
		 (prin1-to-string list-file-count)
		 ".ASC"))
\f


;;;; Awful Hairy Floppy Stuff for kiddies...

(set! backup-floppy
(named-lambda (backup-floppy from to)
  (define (inform-user direction from to)
    (define (arrow)
      (clear-screen)
      (define (place-right obj)
	(let ((n (string-size obj)))
	  (move-cursor (- 66 (round (/ n 2))) 23)
	  (format "~s" obj)))
      (define (place-left obj)
	(let ((n (string-size obj)))
	  (move-cursor (- 16 (round (/ n 2))) 23)
	  (format "~s" obj)))
      (define (base)
	(position-pen -150 -50)
	(draw-line-to 150 -50))
      (define (head x)
	(position-pen x -50)
	(draw-line-to x -150)
	(draw-line-to (- x 50) -100)
	(position-pen x -150)
	(draw-line-to (+ x 50) -100))
      (define (tail x)
	(position-pen x -50)
	(draw-line-to x -150))
      (if (eq? direction 'LEFT)
	  (sequence (tail 150)
		    (place-right from)
		    (base)
		    (head -150)
		    (place-left to))
	  (sequence (tail -150)
		    (place-left from)
		    (base)
		    (head 150)
		    (place-right to)))
      (move-cursor 0 0))
    (arrow)
    (format "Type EXECUTE to proceed. ")
    (if (character-equal? (tyi) EXECUTE-KEY)
	direction
	'ABORTED))
  (let ((left (get-unit-name 4))
	(right (get-unit-name 3))
	(from-name (canonicalize-filename from))
	(to-name (canonicalize-filename to)))
    (if (disjunction (number? left) (number? right))
	(format "~%Please load both floppies, then try again.")
	(unwind-protect
	 (lambda()
	   (init-graphics)
	   (clear-graphics)
	   (let ((operation
		  (disjunction
		   (conjunction
		    (string-equal? left from-name)
		    (string-equal? right to-name)
		    (inform-user 'RIGHT from-name to-name))
		   (conjunction
		    (string-equal? left to-name)
		    (string-equal? right from-name)
		    (inform-user 'LEFT from-name to-name))
		   'ERROR)))
	     (cond ((memq operation '(LEFT RIGHT))
		    (sequence
		     (zero-floppy 
		      (if (eq? operation 'RIGHT) 0 1)
		      (truncate-string!
		       to-name
		       (-1+ (string-size to-name))))
		     (copy-directory from to)))
		   ((eq? operation 'ERROR)
		    (format "~%Backup aborted, floppy not found.")))))
	 (lambda () (clear-graphics)))))))
\f


(set! initialize-floppy
(named-lambda (initialize-floppy which user-supplied-name)
  (let ((name (canonicalize-filename user-supplied-name))
	(last-char (-1+ (string-size user-supplied-name))))
    (cond
     ((not (<= 1 (string-size name) 6))
      (format "~%The name must be 1 to 6 characters long, followed by ':'")
      'BAD-NAME)
     ((not (eq? #/: (string-ref name last-char)))
      (format "~%Directory names must end in ':'")
      'BAD-NAME)
     ((let loop ((nth 0)
		 (char (string-ref name 0)))
	(cond ((eq? nth last-char) '())
	      ((disjunction (memq char '(#/- #/_ #/+))
			    (<= #/0 char #/9)
			    (<= #/A char #/Z))
	       (loop (1+ nth) (string-ref name (1+ nth))))
	      (else #!TRUE)))
      (format "~%Directory names must consist of letters, digits, and")
      (format "~%the special characters '-', '_', and '+'")
      'BAD-NAME)
     ((memq which '(LEFT RIGHT))
      (clear-screen)
      (format "Type EXECUTE if you are sure you want to destroy")
      (format "~%all data on the ~s floppy drive." which)
      (if (character-equal? (tyi) EXECUTE-KEY)
	  (sequence
	   (clear-screen)
	   (format "INITIALIZING ~s ... " name)
	   ;; Inverse video, blinking
	   (tyo 131)
	   (format "DO NOT DISTURB!")
	   (tyo 128)
	   (if (zero? (init-floppy (if (eq? which 'RIGHT) 0 1)))
	       (sequence (zero-floppy (if (eq? which 'RIGHT) 0 1)
				      (truncate-string! name last-char))
			 (clear-screen)
			 #!TRUE)
	       (sequence
		(clear-screen)
		(format "Initialization has failed.  Reinsert floppy")
		(format "~%into drive and press EXECUTE to try again.")
		(if (character-equal? (tyi) EXECUTE-KEY)
		    (initialize-floppy which user-supplied-name)
		    'FAILED))))
	  'ABORTED))
     (else
      (format "Type either (Initialize-floppy 'left name) or")
      (format "~%           (Initialize-floppy 'right name)")
      'BAD-CALL)))))

(define (clear-screen)
  (tyo 12))
\f


;;;; Random Pascal Workstation Specifics

(set! set-prefix!
(named-lambda (set-prefix! name)
  (set! name (canonicalize-filename name))
  (if (eq? 0 (prefix-volume name))
      (format "~%File names will default to directory ~s~%" name)
      (format "~%Can't use that name.  File names still default to ~s~%"
	      (get-current-prefix)))))

(set! get-current-prefix
(named-lambda (get-current-prefix)
  (let ((s (make-empty-string 80)))
    (prefix-volume s)
    (string-append s ":"))))

(set! get-unit-name
(named-lambda (get-unit-name n)
  (let ((ans (make-empty-string 80)))
    (let ((errcode (volume-name n ans)))
      (if (= errcode 0)
	  (string-append ans ":")
	  errcode)))))

(set! crunch
(named-lambda (crunch dir-name)
  (let ((error-code (crunch-directory dir-name)))
    (if (zero? error-code) 
	'CRUNCHED
	(error "File System Error" 'CRUNCH dir-name error-code)))))
\f


(define (make-file-name-filter pattern)
  (let ((pattern-chars (filename->list pattern)))
    (define (loop pat-chars f-chars)
      (cond ((null? pat-chars)
	     (null? f-chars))
	    ((eq? (car pat-chars) #/*)
	     (disjunction
	      (null? (cdr pat-chars))
	      (conjunction (not (null? f-chars))
			   (disjunction (loop (cdr pat-chars) f-chars)
					(loop pat-chars (cdr f-chars))))))
	    ((null? f-chars) #!FALSE)
	    ((eq? (car pat-chars) #/%)
	     (loop (cdr pat-chars) (cdr f-chars)))
	    ((eq? (car pat-chars) (car f-chars))
	     (loop (cdr pat-chars) (cdr f-chars)))
	    (else #!FALSE)))
    (lambda (filename)
      (loop pattern-chars
	    (filename->list filename)))))

(define (filename->list pattern)
  (string->list
   (canonicalize-filename
    (if (string? pattern)
	pattern
	(prin1-to-string pattern)))))
\f


;;; end FILE-PACKAGE.
))
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦1cd8b8d49⟧ TextFile

Derivation

TextFile
