DataMuseum.dk

top - download

    Length: 8117 (0x1fb5)
    Types: TextFile
    Names: »intrpt.scm.63«

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

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

;;;; 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))
		 (system-interrupts-vector
		  (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
		 (^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-character handler)
  (vector-set! keyboard-interrupts interrupt-character handler))

(define (remove-keyboard-interrupt! interrupt-character)
  (vector-set! keyboard-interrupts interrupt-character
	       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)
;	 (sequence (set-interrupt-enables! interrupt-enables)
;		   (tyo 7)
;		   (catch
;		    (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))
;	 (sequence (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 ^Z-lower-interrupt-handler
;  (flush-typeahead
;   (lambda (interrupt-character interrupt-enables)
;     (abort->top-level edit))))
\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! #/z ^Z-lower-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-interrupt-mask INTERRUPT-MASK-GC-OK
   (lambda (old-mask)
     (let ((old-system-interrupt-vector
	    (vector-ref (get-fixed-objects-vector)
			system-interrupts-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-size old-system-interrupt-vector)
			   default-interrupt-handler)))

	 (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)

	 ;; install the new vector atomically
	 (vector-set! (get-fixed-objects-vector)
		      (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)
		      system-interrupt-vector)
	 (set-fixed-objects-vector! (get-fixed-objects-vector)))))))

(define (default-interrupt-handler interrupt-code interrupt-enables)
  (princ "Anomalous Interrupt: ")
  (prin1 interrupt-code)
  (princ " Mask: ")
  (prin1 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)
		      system-interrupts-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.
))