From: Chris Hanson Date: Tue, 16 Dec 1986 02:57:15 +0000 (+0000) Subject: initial X-Git-Tag: 20090517-FFI~13814 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=672cc042191770b427e4b0dd3e745fe7bfe10538;p=mit-scheme.git initial --- diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm new file mode 100644 index 000000000..fcac0b1cb --- /dev/null +++ b/v7/src/runtime/intrpt.scm @@ -0,0 +1,254 @@ +;;; -*-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 '())) + +;;;; 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))) + +(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")) + +(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)) + +(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 diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm new file mode 100644 index 000000000..f401a1dcb --- /dev/null +++ b/v7/src/runtime/io.scm @@ -0,0 +1,253 @@ +;;; -*-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)) + +(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!)) + +;;;; 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))) + +;;;; 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)))))) + +(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