DataMuseum.dk

top - download

    Length: 8812 (0x226c)
    Types: TextFile
    Names: »io.scm.30«

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

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

;;;; Input/output utilities

(declare (usual-integrations))
\f


(define close-all-open-files)

(define primitive-io
  (make-package primitive-io
		((open-files-slot (fixed-objects-vector-slot 'OPEN-FILES))
		 (header-size 2)
		 (counter-slot 0)
		 (file-vector-slot 1)
		 (default-size 10)
		 (buffer-size 10)
		 (closed-direction 0)

		 (make-physical-channel (make-primitive-procedure 'HUNK3-CONS))
		 (channel-number system-hunk3-cxr0)
		 (set-channel-direction! system-hunk3-set-cxr2!)
		 (non-marked-vector-cons
		  (make-primitive-procedure 'NON-MARKED-VECTOR-CONS))
		 (insert-non-marked-vector!
		  (make-primitive-procedure 'INSERT-NON-MARKED-VECTOR!))
		 (put-character-to-output-channel
		  (make-primitive-procedure 'PUT-CHARACTER-TO-OUTPUT-CHANNEL))
		 (print-string (make-primitive-procedure 'PRINT-STRING))
		 (get-character-from-input-channel
		  (make-primitive-procedure 'GET-CHARACTER-FROM-INPUT-CHANNEL))
		 (get-character-from-input-channel-immediate
		  (make-primitive-procedure
		   'GET-CHARACTER-FROM-INPUT-CHANNEL-IMMEDIATE))
		 )

(define channel-name
  system-hunk3-cxr1)

(declare (compilable-primitive-functions
	  (make-physical-channel hunk3-cons)
	  (channel-number system-hunk3-cxr0)
	  (channel-name system-hunk3-cxr1)
	  (set-channel-direction! system-hunk3-set-cxr2!)
	  non-marked-vector-cons
	  insert-non-marked-vector!))
\f


;;;; Open/Close Files

;;;  Direction is one of the following:
;;;     - true:   output channel
;;;	- false:  input channel
;;;	- 0:	  closed channel

(define open-channel-wrapper
  (let ((open-channel (make-primitive-procedure 'OPEN-CHANNEL)))
    (named-lambda ((open-channel-wrapper direction) filename)
      (let ((open-files-vector
	     (vector-ref (get-fixed-objects-vector) open-files-slot))
	    (file-info
	     (make-physical-channel
	      (open-channel (canonicalize-filename filename) direction)
	      filename
	      direction)))
	(add-file! file-info
		   (if (= (vector-ref open-files-vector counter-slot)
			  (- (vector-size open-files-vector) header-size))
		       (grow-files-vector! open-files-vector)
		       open-files-vector))
	file-info))))

(define open-input-channel (open-channel-wrapper #!FALSE))
(define open-output-channel (open-channel-wrapper #!TRUE))

(define close-physical-channel
  (let ((primitive (make-primitive-procedure 'CLOSE-PHYSICAL-CHANNEL)))
    (named-lambda (close-physical-channel channel)
      (if (eq? closed-direction
	       (set-channel-direction! channel closed-direction))
	  #!TRUE					;Already closed!
	  (sequence
	   (primitive (channel-number channel))
	   (remove-from-files-vector! channel)
	   (channel-name channel))))))

(set! close-all-open-files
      (named-lambda (close-all-open-files)
	(without-interrupts
	 (lambda ()
	   (mapc close-physical-channel (all-open-channels))))))

;;; This is a crock -- it will have to be redesigned if we ever have
;;; more than one terminal connected to this system.  Right now if one
;;; just opens these channels (using "CONSOLE:" and "KEYBOARD:" on the
;;; 9836), a regular file channel is opened which is both slower and
;;; will not work when restoring the band.

(define console-output-channel (make-physical-channel 0 "CONSOLE:" #!TRUE))
(define console-input-channel (make-physical-channel 0 "KEYBOARD:" #!FALSE))
(define (get-console-output-channel) console-output-channel)
(define (get-console-input-channel) console-input-channel)

(define (console-channel? channel)
  (zero? (channel-number channel)))
\f


;;;; Files Vector Operations

(define (grow-files-vector! old)
  (without-interrupts
   (lambda ()
     (let ((new (vector-cons (+ buffer-size (vector-size old)) '()))
	   (nm (non-marked-vector-cons
		(+ buffer-size (- (vector-size old) header-size)))))
       (lock-vector! old)
       (let ((num (+ header-size (vector-ref old counter-slot))))
	 (vector-set! new counter-slot (vector-ref old counter-slot))
	 (insert-non-marked-vector! new file-vector-slot nm)
	 (lock-vector! new)		;If GC occurs it will be alright
	 (let loop ((current header-size))
	      (if (= current num)
		  (sequence
		   (clear-vector! new current
				  (+ buffer-size (vector-size old)))
		   (vector-set! (get-fixed-objects-vector) open-files-slot new)
		   (unlock-vector! old)
		   (unlock-vector! new)		;Must be done when installed!
		   (sequence
		    (vector-set! new current (vector-ref old current))
		    (loop (1+ current))))))
	 new)))))

(define (add-file! file open-files)
  (without-interrupts
   (lambda ()
     (lock-vector! open-files)
     (vector-set! open-files
		  (+ header-size
		     (vector-set! open-files
				  counter-slot
				  (1+ (vector-ref open-files counter-slot))))
		  file)
     (unlock-vector! open-files))))
      
(define (remove-from-files-vector! file)
  (without-interrupts
   (lambda ()
     (let ((open-files (vector-ref (get-fixed-objects-vector)
				   open-files-slot)))
       (lock-vector! open-files)
       (let ((max (+ header-size (vector-ref open-files counter-slot))))
	 (let loop ((count header-size))
	      (cond ((= count max)
		     (unlock-vector! open-files)
		     (error "Not an i/o channel" 'CLOSE-CHANNEL file))
		    ((eq? file (vector-ref open-files count))
		     (let inner ((count (1+ count)))
			  (if (= count max)
			      (sequence
			       (vector-set! open-files
					    counter-slot
					    (-1+
					     (vector-ref open-files
							 counter-slot)))
			       (vector-set! open-files (-1+ count) '()))
			      (sequence
			       (vector-set! open-files
					    (-1+ count)
					    (vector-ref open-files count))
			       (inner (1+ count))))))
		    (else (loop (1+ count)))))
	 (unlock-vector! open-files))))))
\f


(define (clear-vector! v start end)
  (without-interrupts
   (lambda ()
     (let loop ((n start))
	  (if (= n end)
	      'DONE
	      (sequence
	       (vector-set! v n '())
	       (loop (1+ n))))))))

(define (all-open-channels)
  (let ((files-vector (vector-ref (get-fixed-objects-vector) open-files-slot)))
    (without-interrupts
     (lambda ()
       (lock-vector! files-vector)
       (let ((result
	      (subvector->list
	       files-vector
	       header-size
	       (+ header-size (vector-ref files-vector counter-slot)))))
	 (unlock-vector! files-vector)
	 result)))))
  
(define ((locker flag) v)
  (with-interrupt-mask INTERRUPT-MASK-NONE
   (lambda (old-mask)
     (vector-set! v
		  file-vector-slot
		  (primitive-set-type flag
				      (vector-ref v file-vector-slot)))
     #!true)))				; Gurantee a good value returned

(define lock-vector!
  (locker (microcode-type 'NULL)))

(define unlock-vector!
  (locker (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR)))

(define (setup-files-vector)
  (let ((base-vector (vector-cons (+ default-size header-size) '())))
    (vector-set! base-vector counter-slot 0)
    (insert-non-marked-vector! base-vector file-vector-slot
			       (non-marked-vector-cons default-size))
;   (lock-vector! base-vector)
    (clear-vector! base-vector header-size (+ default-size header-size))
    (vector-set! (get-fixed-objects-vector) open-files-slot base-vector)
    (unlock-vector! base-vector)))
\f


;;; end PRIMITIVE-IO package.
))

((access setup-files-vector primitive-io))
(add-gc-daemon! (make-primitive-procedure 'close-lost-open-files))