--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; Interrupt System
+
+(declare (usual-integrations)
+ (compilable-primitive-functions set-fixed-objects-vector!))
+
+(define with-external-interrupts-handler)
+
+(define timer-interrupt
+ (let ((setup-timer-interrupt
+ (make-primitive-procedure 'setup-timer-interrupt #!TRUE)))
+ (named-lambda (timer-interrupt)
+ (setup-timer-interrupt '() '())
+ (error "Unhandled Timer interrupt received"))))
+
+(define interrupt-system
+ (make-package interrupt-system
+ ((get-next-interrupt-character
+ (make-primitive-procedure 'GET-NEXT-INTERRUPT-CHARACTER))
+ (check-and-clean-up-input-channel
+ (make-primitive-procedure 'CHECK-AND-CLEAN-UP-INPUT-CHANNEL))
+ (index:interrupt-vector
+ (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
+ (index:termination-vector
+ (fixed-objects-vector-slot
+ 'MICROCODE-TERMINATIONS-PROCEDURES))
+ (^Q-Hook '()))
+\f
+;;;; Soft interrupts
+
+;;; Timer interrupts
+
+(define (timer-interrupt-handler interrupt-code interrupt-enables)
+ (timer-interrupt))
+
+;;; Keyboard Interrupts
+
+(define (external-interrupt-handler interrupt-code interrupt-enables)
+ (let ((interrupt-character (get-next-interrupt-character)))
+ ((vector-ref keyboard-interrupts interrupt-character) interrupt-character
+ interrupt-enables)))
+
+(define (losing-keyboard-interrupt interrupt-character interrupt-enables)
+ (error "Bad interrupt character" interrupt-character))
+
+(define keyboard-interrupts
+ (vector-cons 256 losing-keyboard-interrupt))
+
+(define (install-keyboard-interrupt! interrupt-char handler)
+ (vector-set! keyboard-interrupts
+ (char->ascii interrupt-char)
+ handler))
+
+(define (remove-keyboard-interrupt! interrupt-char)
+ (vector-set! keyboard-interrupts
+ (char->ascii interrupt-char)
+ losing-keyboard-interrupt))
+
+(define until-most-recent-interrupt-character 0) ;for Pascal, ugh!
+(define multiple-copies-only 1)
+
+(define ((flush-typeahead kernel) interrupt-character interrupt-enables)
+ (if (check-and-clean-up-input-channel until-most-recent-interrupt-character
+ interrupt-character)
+ (kernel interrupt-character interrupt-enables)))
+
+(define ((keep-typeahead kernel) interrupt-character interrupt-enables)
+ (if (check-and-clean-up-input-channel multiple-copies-only
+ interrupt-character)
+ (kernel interrupt-character interrupt-enables)))
+\f
+(define ^B-interrupt-handler
+ (keep-typeahead
+ (lambda (interrupt-character interrupt-enables)
+ (with-standard-proceed-point
+ (lambda ()
+ (breakpoint "^B interrupt" (rep-environment)))))))
+
+; (define ^S-interrupt-handler
+; (keep-typeahead
+; (lambda (interrupt-character interrupt-enables)
+; (if (null? ^Q-Hook)
+; (begin (set-interrupt-enables! interrupt-enables)
+; (beep)
+; (call-with-current-continuation
+; (lambda (stop-^S-wait)
+; (fluid-let ((^Q-Hook Stop-^S-Wait))
+; (let busy-wait () (busy-wait))))))))))
+;
+; (define ^Q-interrupt-handler
+; (keep-typeahead
+; (lambda (interrupt-character interrupt-enables)
+; (if (not (null? ^Q-Hook))
+; (begin (set-interrupt-enables! interrupt-enables)
+; (^Q-Hook 'GO-ON))))))
+;
+; (define ^P-interrupt-handler
+; (flush-typeahead
+; (lambda (interrupt-character interrupt-enables)
+; (set-interrupt-enables! interrupt-enables)
+; (proceed))))
+;
+; (define ^Z-interrupt-handler
+; (flush-typeahead
+; (lambda (interrupt-character interrupt-enables)
+; (set-interrupt-enables! interrupt-enables)
+; (edit))))
+
+(define ^G-interrupt-handler
+ (flush-typeahead
+ (lambda (interrupt-character interrupt-enables)
+ (abort-to-top-level-driver "Quit!"))))
+
+(define ^U-interrupt-handler
+ (flush-typeahead
+ (lambda (interrupt-character interrupt-enables)
+ (abort-to-previous-driver "Up!"))))
+
+(define ^X-interrupt-handler
+ (flush-typeahead
+ (lambda (interrupt-character interrupt-enables)
+ (abort-to-nearest-driver "Abort!"))))
+
+(define (gc-out-of-space-handler . args)
+ (abort-to-nearest-driver "Aborting! Out of memory"))
+\f
+(install-keyboard-interrupt! #\G ^G-interrupt-handler)
+(install-keyboard-interrupt! #\B ^B-interrupt-handler)
+; (install-keyboard-interrupt! #\P ^P-interrupt-handler)
+(install-keyboard-interrupt! #\U ^U-interrupt-handler)
+(install-keyboard-interrupt! #\X ^X-interrupt-handler)
+; (install-keyboard-interrupt! #\Z ^Z-interrupt-handler)
+; (install-keyboard-interrupt! #\S ^S-interrupt-handler)
+; (install-keyboard-interrupt! #\Q ^Q-interrupt-handler)
+
+(define STACK-OVERFLOW-SLOT 0)
+(define GC-SLOT 2)
+(define CHARACTER-SLOT 4)
+(define TIMER-SLOT 6)
+
+(define (install)
+ (with-interrupts-reduced INTERRUPT-MASK-GC-OK
+ (lambda (old-mask)
+ (let ((old-system-interrupt-vector
+ (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
+ (old-termination-vector
+ (vector-ref (get-fixed-objects-vector) index:termination-vector)))
+ (let ((previous-gc-interrupt
+ (vector-ref old-system-interrupt-vector GC-SLOT))
+ (previous-stack-interrupt
+ (vector-ref old-system-interrupt-vector STACK-OVERFLOW-SLOT))
+ (system-interrupt-vector
+ (vector-cons (vector-length old-system-interrupt-vector)
+ default-interrupt-handler))
+ (termination-vector
+ (if old-termination-vector
+ (if (> number-of-microcode-terminations
+ (vector-length old-termination-vector))
+ (vector-grow old-termination-vector
+ number-of-microcode-terminations)
+ old-termination-vector)
+ (vector-cons number-of-microcode-terminations #F))))
+
+ (vector-set! system-interrupt-vector GC-SLOT previous-gc-interrupt)
+ (vector-set! system-interrupt-vector STACK-OVERFLOW-SLOT
+ previous-stack-interrupt)
+ (vector-set! system-interrupt-vector CHARACTER-SLOT
+ external-interrupt-handler)
+ (vector-set! system-interrupt-vector TIMER-SLOT
+ timer-interrupt-handler)
+
+ ;; slots 4-15 unused.
+
+ ;; install the new vector atomically
+ (vector-set! (get-fixed-objects-vector)
+ index:interrupt-vector
+ system-interrupt-vector)
+
+ (vector-set! termination-vector
+ (microcode-termination 'GC-OUT-OF-SPACE)
+ gc-out-of-space-handler)
+
+ (vector-set! (get-fixed-objects-vector)
+ index:termination-vector
+ termination-vector)
+
+ (set-fixed-objects-vector! (get-fixed-objects-vector)))))))
+
+(define (default-interrupt-handler interrupt-code interrupt-enables)
+ (write-string "Anomalous Interrupt: ") (write interrupt-code)
+ (write-string " Mask: ") (write interrupt-enables))
+\f
+(set! with-external-interrupts-handler
+(named-lambda (with-external-interrupts-handler handler code)
+ (define (interrupt-routine interrupt-code interrupt-enables)
+ (let ((character (get-next-interrupt-character)))
+ (check-and-clean-up-input-channel
+ until-most-recent-interrupt-character
+ character)
+ (handler character interrupt-enables)))
+
+ (define old-handler interrupt-routine)
+
+ (define interrupt-vector
+ (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
+
+ (dynamic-wind
+ (lambda ()
+ (set! old-handler
+ (vector-set! interrupt-vector CHARACTER-SLOT old-handler)))
+ code
+ (lambda ()
+ (vector-set! interrupt-vector CHARACTER-SLOT
+ (set! old-handler
+ (vector-ref interrupt-vector CHARACTER-SLOT)))))))
+
+;;; end INTERRUPT-SYSTEM package.
+(the-environment)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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)
+ (compilable-primitive-functions &make-object))
+\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)
+ (channel-name system-hunk3-cxr1)
+ (channel-direction system-hunk3-cxr2)
+ (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!))
+ )
+
+(declare (compilable-primitive-functions
+ (make-physical-channel hunk3-cons)
+ (channel-number system-hunk3-cxr0)
+ (channel-name system-hunk3-cxr1)
+ (channel-direction system-hunk3-cxr2)
+ (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 'FILE-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 filename direction)
+ filename
+ direction)))
+ (add-file! file-info
+ (if (= (vector-ref open-files-vector counter-slot)
+ (- (vector-length 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 'FILE-CLOSE-CHANNEL)))
+ (named-lambda (close-physical-channel channel)
+ (if (eq? closed-direction
+ (set-channel-direction! channel closed-direction))
+ #!TRUE ;Already closed!
+ (begin (primitive channel)
+ (remove-from-files-vector! channel)
+ (channel-name channel))))))
+
+(define physical-channel-eof?
+ (let ((primitive (make-primitive-procedure 'FILE-EOF?)))
+ (named-lambda (physical-channel-eof? channel)
+ (or (eq? (channel-direction channel) closed-direction)
+ (primitive (primitive (channel-number channel)))))))
+
+(set! close-all-open-files
+(named-lambda (close-all-open-files)
+ (without-interrupts
+ (lambda ()
+ (for-each 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-length old)) '()))
+ (nm (non-marked-vector-cons
+ (+ buffer-size (- (vector-length old) header-size)))))
+ (lock-vector! old)
+ (let ((num (+ header-size (vector-ref old counter-slot))))
+ (define (loop current)
+ (if (= current num)
+ (begin (clear-vector! new current
+ (+ buffer-size (vector-length old)))
+ (vector-set! (get-fixed-objects-vector) open-files-slot
+ new)
+ (unlock-vector! old)
+ (unlock-vector! new)) ;Must be done when installed!
+ (begin (vector-set! new current (vector-ref old current))
+ (loop (1+ current)))))
+ (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
+ (loop header-size)
+ 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))))
+ (define (loop count)
+ (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)
+ (begin
+ (vector-set! open-files
+ counter-slot
+ (-1+
+ (vector-ref open-files
+ counter-slot)))
+ (vector-set! open-files (-1+ count) '()))
+ (begin
+ (vector-set! open-files
+ (-1+ count)
+ (vector-ref open-files count))
+ (inner (1+ count))))))
+ (else (loop (1+ count)))))
+ (loop header-size)
+ (unlock-vector! open-files))))))
+\f
+(define (clear-vector! v start end)
+ (without-interrupts
+ (lambda ()
+ (subvector-fill! v start end '()))))
+
+(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-interrupts-reduced INTERRUPT-MASK-NONE
+ (lambda (old-mask)
+ (vector-set! v
+ file-vector-slot
+ (&make-object flag
+ (vector-ref v file-vector-slot)))
+ #!TRUE))) ; Guarantee 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)))
+
+;;; end PRIMITIVE-IO package.
+))
+
+((access setup-files-vector primitive-io))
+(add-gc-daemon! (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES))
+(add-gc-daemon! (access close-lost-open-files-daemon primitive-io))
\ No newline at end of file
projects / mit-scheme.git / commitdiff