(FILECREATED " 4-Nov-85 17:59:23" {ERIS}<LISPCORE>SOURCES>AINTERRUPT.;32
 26299  

      changes to:  (FNS \DOSTACKFULLINTERRUPT)
		   (VARS AINTERRUPTCOMS)

      previous date: "15-Oct-85 00:09:47" {ERIS}<LISPCORE>SOURCES>AINTERRUPT.;31)


(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT AINTERRUPTCOMS)

(RPAQQ AINTERRUPTCOMS
 ((COMS (* handling interrupts)
			       (FNS INTCHAR INTERRUPTCHAR INTERRUPTED LISPINTERRUPTS \DOHELPINTERRUPT 
				    \DOHELPINTERRUPT1 \DOINTERRUPTHERE \PROC.FINDREALFRAME 
				    \SETPRINTLEVEL \SETRECLAIMMIN GETINTERRUPT CURRENTINTERRUPTS 
				    SETINTERRUPT RESET.INTERRUPTS INTERRUPTABLE))
	(COMS (* ^T)
	      (FNS CONTROL-T \CONTROL-T.PRINTRATIO)
	      (INITVARS (\CONTROL-T.DEPTH 3)
			(\CONTROL-T.BACKSLASH)
			(LAST^TTIMEBOX (CLOCK 0))
			(LAST^TSWAPTIME)
			(LAST^TDISKIOTIME 0)
			(LAST^TGCTIME 0)
			(LAST^TNETIOTIME 0))
	      (GLOBALVARS \CONTROL-T.DEPTH \CONTROL-T.BACKSLASH LAST^TTIMEBOX LAST^TSWAPTIME 
			  LAST^TDISKIOTIME LAST^TNETIOTIME LAST^TGCTIME \MISCSTATS)
	      (ADDVARS (\SYSTEMCACHEVARS LAST^TSWAPTIME)))
	[INITVARS (\CURRENTINTERRUPTS)
		  (\INTERRUPTABLE)
		  (INTERRUPTMENUFONT (QUOTE (GACHA 10]
	(VARS \SYSTEMINTERRUPTS)
	(DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (NOFIXFNSLST CONTROL-T))
		  (LOCALVARS . T)
		  (GLOBALVARS \CURRENTINTERRUPTS \SYSTEMINTERRUPTS INTERRUPTMENUFONT))
	(DECLARE: EVAL@COMPILE (EXPORT (ADDVARS (SYSSPECVARS \INTERRUPTABLE))
				       (PROP INFO UNINTERRUPTABLY)
				       (PROP DMACRO UNINTERRUPTABLY)
				       (ALISTS (PRETTYPRINTMACROS UNINTERRUPTABLY)))
		  DONTCOPY
		  (EXPORT (RECORDS INTERRUPTSTATE)
			  (PROP DMACRO \TAKEINTERRUPT))
		  (MACROS \SYSTEMINTERRUPTP))))



(* handling interrupts)


(DEFINEQ

(INTCHAR

  [LAMBDA (CHAR TYP/FORM HARDFLG TABLE)                      (* bvm: " 1-Aug-85 16:03")

                                                             (* this function is the non-undoable version of 

							     INTERRUPTCHAR; INTERRUPTCHAR calls it)

    (
PROG
 (VAL SYSDEF OLDINT)
          (
SELECTQ
 CHAR
		   (NIL                                      (* this is illegal, so don't do anything about it)

			(
RETURN
))
		   (T                                        (* (INTCHAR T) means restore interrupts to the 
"standard" setting)

		      (UNINTERRUPTABLY
                          (for
 CHAR in
 (GETINTERRUPT
 NIL TABLE)
			     do
 (
SETQ
 VAL (
NCONC
 (INTCHAR
 CHAR NIL NIL TABLE)
						 VAL)))      (* turn off all user interrupts -

							     (GETINTERRUPT) returns list of user interrupts)

			  [
MAPC
 (LISPINTERRUPTS
)
				(
FUNCTION
 (LAMBDA (LST)
				    (
SETQ
 VAL (
NCONC
 (INTCHAR
 (
CAR
 LST)
							      (
CADR
 LST)
							      (
CADDR
 LST)
							      TABLE)
						     VAL]    (* and reset all SYSTEM interrupts to default -

							     (LISPINTERRUPTS) returns a list of argument lists for 

							     INTCHAR)

                                                             (* and VAL has been set to a valid arg list for 

							     INTCHAR)

			  (
RETURN
 VAL)))
		   NIL)
          (
COND

	    ((
LISTP
 CHAR)                                    (* Call from undoing or resetform.

							     CHAR is a list of characters followed by typ/form 

							     arguments.)

	      (while
 CHAR do
 (
SETQ
 VAL (
NCONC
 (INTCHAR
 (pop
 CHAR)
						       (pop
 CHAR)
						       (pop
 CHAR)
						       TABLE)
					      VAL)))
	      (
RETURN
 VAL)))
          [
COND

	    ((
NOT
 (
FIXP
 CHAR))
	      (
COND

		[(\SYSTEMINTERRUPTP CHAR)

          (* CHAR can be an interrupt character class, meaning the character which is currently assigned to that interrupt -

	  this is most useful in, say, (INTCHAR (QUOTE HELP)) which says turn off the character whose class is HELP)



		  (
SETQ
 CHAR (
OR
 (GETINTERRUPT
 CHAR TABLE)
				 (
ERRORX
 (
LIST
 27 CHAR]
		(T                                           (* turn single character into character code)

		   (
SETQ
 CHAR (
APPLY*
 (
QUOTE
 CHARCODE)
				      CHAR]
          [
SETQ
 VAL (
AND
 (
SETQ
 OLDINT (GETINTERRUPT
 CHAR TABLE))
			 (
LIST
 CHAR (
CAR
 OLDINT)
			       (
CADR
 OLDINT]
          [
COND

	    ((
EQ
 TYP/FORM T)                                 (* just return value indicating what it was.)

	      (
RETURN
 VAL))
	    ((
AND
 TYP/FORM (
LITATOM
 TYP/FORM)
		  (
SETQ
 SYSDEF (
ASSOC
 TYP/FORM \SYSTEMINTERRUPTS)))
                                                             (* System interrupt -- get its default HARDFLG)

	      (
OR
 HARDFLG (
SETQ
 HARDFLG (
CADR
 SYSDEF]
          (
COND

	    ((
AND
 (
EQ
 (
CAR
 OLDINT)
		      TYP/FORM)
		  (
EQ
 (
CADR
 OLDINT)
		      HARDFLG))                              (* if the character is already set up, just return)

	      (
RETURN
)))
          (
COND

	    (OLDINT (SETINTERRUPT
 CHAR NIL TABLE)))
          (
COND

	    ((
NULL
 TYP/FORM)                                 (* just leave character disabled)

	      )
	    (T                                               (* make a user interrupt)

	       (
COND

		 ((
AND
 SYSDEF (
SETQ
 OLDINT (GETINTERRUPT
 TYP/FORM TABLE)))
                                                             (* if a system interrupt and there is another character

							     assigned to that channel, turn that character off)

		   (SETINTERRUPT
 OLDINT NIL TABLE)
		   (push
 VAL OLDINT TYP/FORM NIL)))
	       (SETINTERRUPT
 CHAR TYP/FORM TABLE HARDFLG)
	       (push
 VAL CHAR NIL NIL)))
          (
RETURN
 VAL])

(INTERRUPTCHAR

  [LAMBDA (CHAR TYP/FORM HARDFLG TABLE)                      (* lmm "14-May-85 16:56")

    (
PROG
 ((VAL (INTCHAR
 CHAR TYP/FORM HARDFLG TABLE)))
          (
AND
 LISPXHIST (
UNDOSAVE
 (
LIST
 (
QUOTE
 INTERRUPTCHAR)
					 VAL NIL NIL TABLE)))
          (
RETURN
 VAL])

(INTERRUPTED

  [LAMBDA NIL                                                (* bvm: " 3-Sep-85 21:33")

    (DECLARE
 (
GLOBALVARS
 \INTERRUPTSTATE)
	     (
USEDFREE
 \MOUSEBUSY \INTERRUPTABLE))
    (
COND

      ((
NULL
 \INTERRUPTABLE)
	(
SETQ
 \PENDINGINTERRUPT T))
      ((fetch
 STORAGEFULL of
 \INTERRUPTSTATE)
	(
\DOSTORAGEFULLINTERRUPT
))
      ((fetch
 STACKOVERFLOW of
 \INTERRUPTSTATE)
	(\DOSTACKFULLINTERRUPT
))
      ((fetch
 VMEMFULL of
 \INTERRUPTSTATE)
	(
\DOVMEMFULLINTERRUPT
))
      ((fetch
 GCDISABLED of
 \INTERRUPTSTATE)
	(\DOGCDISABLEDINTERRUPT))
      (T (LET* [(CH (fetch
 INTCHARCODE of
 \INTERRUPTSTATE))
		(
INTERRUPT
 (
CDR
 (
ASSOC
 CH (fetch
 (
KEYACTION
 INTERRUPTLIST) of
 \CURRENTKEYACTION]
	       (
COND

		 (
INTERRUPT
 (LET* [(CLASS (
CAR
 INTERRUPT))
				   (HARDFLG (
CADR
 INTERRUPT))
				   (THISPROC (
THIS.PROCESS
))
				   (INTERRUPTED.PROC (
COND

						       ((
OR
 (
NULL
 THISPROC)
							    (
EQ
 HARDFLG T))
							 THISPROC)
						       [(
EQ
 HARDFLG (
QUOTE
 MOUSE))
							 (LET ((MP THISPROC))
                                                             (* Interrupt MOUSE proc if it's busy, else the tty 

							     process)

							      (
COND

								([
COND

								    ((
EQ
 (
PROCESSPROP
 MP
										      (
QUOTE
 NAME))
									 (
QUOTE
 MOUSE))
								      \MOUSEBUSY)
								    ((
SETQ
 MP (
FIND.PROCESS

									  (
QUOTE
 MOUSE)))
								      (
PROCESS.EVALV
 MP (
QUOTE
 
										       \MOUSEBUSY]
								  MP)
								(T (
TTY.PROCESS
]
						       [(
EQ
 HARDFLG (
QUOTE
 WHICHW))
                                                             (* Interrupt the process that owns the window the mouse

							     is in)

							 (
AND
 (
GETD
 (
QUOTE
 WHICHW))
							      (LET ((W (
WHICHW
)))
							           (
AND
 W (
WINDOWPROP
 W (
QUOTE
 
											  PROCESS]
						       (T (
TTY.PROCESS
]
			          (
COND

				    ((
EQ
 THISPROC INTERRUPTED.PROC)
				      (\DOINTERRUPTHERE
 CLASS))
				    ((
NULL
 INTERRUPTED.PROC)
                                                             (* Nobody qualified, so dismiss interrupt)

				      NIL)
				    ((
\PROCESS.MAKEFRAME
 INTERRUPTED.PROC (
FUNCTION
 \DOINTERRUPTHERE)
							 (
LIST
 CLASS CH HARDFLG)))
				    (T                       (* Couldn't build frame, so leave interrupt pending)

				       (
SETQ
 \PENDINGINTERRUPT T])

(LISPINTERRUPTS

  [LAMBDA NIL                                                (* jds "30-Sep-85 12:35")


          (* * Returns a list of the "standard" interrupt-character settings for Interlisp-D. These are used, e.g., in INTCHAR

	  to reset things to the default state.)



    (
QUOTE
 ((2 BREAK MOUSE)
	     (4 RESET MOUSE)
	     (5 ERROR MOUSE)
	     (7 HELP T)
	     (16 PRINTLEVEL)
	     (20 (CONTROL-T
))
	     (127 RUBOUT T])

(\DOHELPINTERRUPT

  [LAMBDA NIL                                                (* bvm: "27-JUL-83 18:37")

    (PROG (PROC)
          (COND
	    ((NULL (THIS.PROCESS))
	      (FLASHWINDOW)
	      (\DOHELPINTERRUPT1
))
	    ([NULL (SETQ PROC (PROGN (FLASHWINDOW)
				     (\SELECTPROCESS "Interrupt which process?"]
                                                             (* Interrupt declined)

	      NIL)
	    ((EQ PROC (THIS.PROCESS))
	      (\DOHELPINTERRUPT1
))
	    ((\PROCESS.MAKEFRAME PROC (FUNCTION \DOHELPINTERRUPT1)))
	    (T                                               (* Couldn't build frame, so leave interrupt pending)

	       (SETQ \PENDINGINTERRUPT T])

(\DOHELPINTERRUPT1

  [LAMBDA NIL                                                (* bvm: "11-AUG-83 11:56")


          (* Does HELP/BREAK interrupt in the current process. We treat ^B same as ^H, except that former always occurs in 

	  tty process. BREAK interrupt used to just do a (ERRORX (LIST 22Q NIL)) instead of calling INTERRUPT)



    (COND
      ((NULL \INTERRUPTABLE)                                 (* Unlikely, but could occur if someone blocked while 

							     uninterruptable)

	(FLASHWINDOW))
      (T (PROG (OLDTTY)
	       [OR (TTY.PROCESSP)
		   (SETQ OLDTTY (TTY.PROCESS (THIS.PROCESS]
	       [COND
		 ((EQ (fetch
 PROCNAME of
 (THIS.PROCESS))
		      (QUOTE MOUSE))
		   (SPAWN.MOUSE (THIS.PROCESS]
	       (CLEARBUF T T)                                (* Find name of a real frame before INTERRUPTED, so 

							     break message can be nice.)

	       (INTERRUPT (\PROC.FINDREALFRAME
)
			  NIL 2)
	       (COND
		 (OLDTTY (TTY.PROCESS OLDTTY])

(\DOINTERRUPTHERE

  [LAMBDA (CLASS)
    (DECLARE
 (
USEDFREE
 \INTERRUPTABLE))                      (* bvm: "18-Jul-85 12:37")


          (* * Perform the CLASS interrupt in the currently running process)



    (
COND

      ((
NOT
 \INTERRUPTABLE)
	(
SETQ
 \PENDINGINTERRUPT T))
      (T (
SELECTQ
 CLASS
		  (
RESET
 (
\CLEARSYSBUF
 T)
			 (
RESET
))
		  (
ERROR
 (
\CLEARSYSBUF
 T)
			 (
SETERRORN
 47)
			 (
ERROR!
))
		  (
HELP
                                      (* Does a ^B in process selected by user)

			(\DOHELPINTERRUPT
))
		  (
BREAK
 (\DOHELPINTERRUPT1
))
		  (CONTROL-T
 (CONTROL-T
))
		  (
STORAGE
 (\SETRECLAIMMIN
))
		  (
PRINTLEVEL
 (\SETPRINTLEVEL
))
		  (RUBOUT (
FLASHWINDOW
)
			  (
\CLEARSYSBUF
 T))
		  (
RAID
 (
RAID
))
		  (
COND

		    ((
LITATOM
 CLASS)
		      (
SET
 CLASS T))
		    (T (
\EVAL
 CLASS])

(\PROC.FINDREALFRAME

  [LAMBDA (POS)                                              (* bvm: "18-Jul-85 13:00")

                                                             (* Returns the name of the first interesting frame 

							     before POS, or the caller if POS = NIL)

    (for
 I from
 (
COND

		  (POS 0)
		  (T -2))
       by
 -1 do
 (
SELECTQ
 (
SETQ
 $$VAL (
STKNTHNAME
 I POS))
			 ((INTERRUPTED
 \INTERRUPTFRAME \INTERRUPTED \DOHELPINTERRUPT 
				       \DOHELPINTERRUPT1 \DOBUFFEREDTRANSITIONS \DOINTERRUPTHERE 
				       \PROCESS.GO.TO.SLEEP BLOCK AWAIT.EVENT MONITOR.AWAIT.EVENT 
				       GETMOUSESTATE)
			   NIL)
			 (
RETURN
 $$VAL])

(\SETPRINTLEVEL

  [LAMBDA NIL                                                (* rrb "22-JUL-83 10:19")

    (DECLARE
 (GLOBALVARS \TCARPRINTLEVEL \TCDRPRINTLEVEL))
    (PROG (BUF OLB OSB CARN)
          (\BOUT \TERM.OFD (CHARCODE BELL))
          (SETQ OLB (LINBUF T))
          (SETQ OSB (SYSBUF T))
          (CLEARBUF T T)
          (DSPSOUT "set printlevel to: ")
          (PROG ((N 0)
		 CH)
	    LP  (SELCHARQ (SETQ CH (\GETCHAR))
			  ((0 1 2 3 4 5 6 7 8 9)
			    [SETQ N (IPLUS (ITIMES N 10)
					   (IDIFFERENCE CH (CHARCODE 0]
			    (GO LP))
			  [(%. !)                            (* CARN is set if we've already seen a comma)

			    (COND
			      (CARN (SETQ \TCARPRINTLEVEL CARN)
				    (SETQ \TCDRPRINTLEVEL N))
			      (T (SETQ \TCARPRINTLEVEL N)))
			    (COND
			      ((EQ CH (CHARCODE !))          (* Make it permanent)

				(PRINTLEVEL \TCARPRINTLEVEL \TCDRPRINTLEVEL]
			  [, (COND
			       ((NOT CARN)
				 (SETQ CARN N)               (* This is the first comma)

				 (SETQ N 0)
				 (GO LP]
			  NIL)                               (* Restore buffers cleared with CLEARBUF)

	    )
          (COND
	    ((SETQ BUF (SYSBUF T))
	      (BKSYSBUF BUF)))
          (SETQ \SYSBUF OSB)
          (AND (SETQ BUF (LINBUF T))
	       (LINBUF))
          (SETQ \LINBUF OLB])

(\SETRECLAIMMIN

  [LAMBDA NIL                                                (* rrb "22-JUL-83 10:19")

    (PROG (BUF OLB OSB CH)
          (\BOUT \TERM.OFD (CHARCODE BELL))
          (SETQ OLB (LINBUF T))
          (SETQ OSB (SYSBUF T))
          (CLEARBUF T T)
          (DSPSOUT "set RECLAIMMIN to: ")
          (PROG ((N 0))
	    LP  (SELCHARQ (SETQ CH (\GETCHAR))
			  ((0 1 2 3 4 5 6 7 8 9)
			    [SETQ N (IPLUS (ITIMES N 10)
					   (IDIFFERENCE CH (CHARCODE 0]
			    (GO LP))
			  (%. (RECLAIMMIN N))
			  NIL))
          (COND
	    ((SETQ BUF (SYSBUF T))
	      (BKSYSBUF BUF)))
          (SETQ \SYSBUF OSB)
          (AND (SETQ BUF (LINBUF T))
	       (LINBUF))
          (SETQ \LINBUF OLB])

(GETINTERRUPT

  [LAMBDA (CHAR TABLE)                                       (* bvm: " 1-Aug-85 15:55")

    (
OR
 TABLE (
SETQ
 TABLE \CURRENTKEYACTION))
    (
SELECTQ
 CHAR
	     (NIL                                            (* Non-system interrupts)

		  (for
 X in
 (fetch
 (
KEYACTION
 INTERRUPTLIST)
				   TABLE)
		     unless
 (\SYSTEMINTERRUPTP (
CADR
 X)) collect
 (
CAR
 X)))
	     (T                                              (* All system interrupts)

		(for
 X in
 (fetch
 (
KEYACTION
 INTERRUPTLIST)
				 TABLE)
		   collect
 (
CAR
 X)))
	     (
COND

	       [(
NUMBERP
 CHAR)
		 (
CDR
 (
FASSOC
 CHAR (fetch
 (
KEYACTION
 INTERRUPTLIST)
					  TABLE]
	       (T (for
 X in
 (fetch
 (
KEYACTION
 INTERRUPTLIST)
				   TABLE)
		     when
 (
EQ
 CHAR (
CADR
 X))
		     do
                                      (* Find CHAR in system class.)

			(
RETURN
 (
CAR
 X])

(CURRENTINTERRUPTS

  [LAMBDA (TABLE)                                            (* bvm: "18-Jul-85 12:37")

    (
APPEND
 (fetch
 (
KEYACTION
 INTERRUPTLIST) of
 (
OR
 TABLE \CURRENTKEYACTION])

(SETINTERRUPT

  [LAMBDA (CHAR CLASS TABLE HARDFLG)                         (* bvm: " 1-Aug-85 16:09")

    (
OR
 TABLE (
SETQ
 TABLE \CURRENTKEYACTION))
    (LET (TEM)                                               (* This code assumes that the variable 

							     (FETCH (KEYACTION INTERRUPTLIST) TABLE) is an alist of 

							     the form ((CHAR CLASS) ...))

         (
COND

	   ((
NULL
 CHAR)                                      (* some mistake)

	     NIL)
	   ((\SYSTEMINTERRUPTP CHAR)                         (* If this is a system interrupt, then this is turning 

							     it off)

	     (SETINTERRUPT
 (GETINTERRUPT
 CHAR TABLE)
			   NIL TABLE))
	   [(
SETQ
 TEM (
FASSOC
 CHAR (fetch
 (
KEYACTION
 INTERRUPTLIST)
					  TABLE)))           (* CHAR is currently an interrupt)

	     (
COND

	       ((
AND
 (
EQ
 (
CADR
 TEM)
			 CLASS)
		     (
EQ
 (
CADDR
 TEM)
			 HARDFLG))                           (* No change)

		 )
	       ((
NULL
 CLASS)                                 (* REMOVE FROM INTERRUPT CHARACTER SET)

		 (change
 (fetch
 (
KEYACTION
 INTERRUPTLIST)
				TABLE)
			 (
DREMOVE
 TEM DATUM)))
	       (T                                            (* Assign new interrupt to CHAR)

		  (change
 (
CDR
 TEM)
			  (
LIST
 CLASS HARDFLG]
	   ((
NULL
 CLASS))
	   (T                                                (* Brand new interrupt)

	      (push
 (fetch
 (
KEYACTION
 INTERRUPTLIST)
			   TABLE)
		    (
LIST
 CHAR CLASS HARDFLG])

(RESET.INTERRUPTS

  [LAMBDA (PermittedInterrupts SaveCurrent?)
    (DECLARE
 (
GLOBALVARS
 \DEFAULTKEYACTION))             (* gbn "14-Oct-85 21:17")


          (* Returns list of previous settings, for use by RESETFORM but only when 2nd arg is non-NIL.

	  That way, there is no consing on the exit from the RESETLST * Note that is a list of 2-lists, and the first element

	  of each 2-list is the charcode of the character determined.)



    (
OR
 (
NULL
 PermittedInterrupts)
	  [
AND
 (
LISTP
 PermittedInterrupts)
		 (
NOT
 (thereis
 X in
 PermittedInterrupts
			   suchthat
 (
NOT
 (
AND
 (
LISTP
 X)
						    (
CHARCODEP
 (
CAR
 X]
	  (
\ILLEGAL.ARG
 PermittedInterrupts))              (* Do the validity checking first, so that we don't 

							     get an error under the UNINTERRUPTABLY)

    (UNINTERRUPTABLY                                         (* MAPC (fetch (KEYACTION INTERRUPTLIST) of 

							     \DEFAULTKEYACTION) (FUNCTION 

							     (LAMBDA (CHAR) (\INTCHAR (CAR CHAR)))))

                                                             (* First, dis-arm all the current interrupts)

	[
COND

	  (SaveCurrent? (
SETQ
 SaveCurrent? (
APPEND
 (fetch
 (
KEYACTION
 INTERRUPTLIST)
							  of
 \DEFAULTKEYACTION)
						       NIL]
	(change
 (fetch
 (
KEYACTION
 INTERRUPTLIST) of
 \DEFAULTKEYACTION)
		  (
APPEND
 PermittedInterrupts))            (* Finally, "arm" and install the desired interrupts)

	SaveCurrent?)])

(INTERRUPTABLE

  [LAMBDA (FLAG)                   (* lmm "18-APR-82 13:52")

    (PROG1 \INTERRUPTABLE (SETQ \INTERRUPTABLE FLAG])
)



(* ^T)


(DEFINEQ

(CONTROL-T

  [LAMBDA (POS)                                              (* bvm: "31-Jul-85 19:20")


          (* * better definition: 

	  
"(PROG ((NONKEYBOARDTIME (STKNTHNAME -1 (QUOTE INTERRUPTED)))
       (POS (POSITION T)))
      (printout T T (COND
		  ((EQ NONKEYBOARDTIME (QUOTE \GETCHAR))
		    %"IO WAIT IN %")
		  (T %"RUNNING IN %"))
		.P2 NONKEYBOARDTIME %" IN %" .P2 (STKNTHNAME -2 (QUOTE INTERRUPTED))
		%" IN %"
		(STKNTHNAME -3 (QUOTE INTERRUPTED))
		%", %" .I2
	       (IQUOTIENT (ITIMES [IDIFFERENCE [SETQ NONKEYBOARDTIME
						 (IPLUS (IMINUS LAST^TTIMEBOX)
							(SETQ LAST^TTIMEBOX
							  (IDIFFERENCE (CLOCK0 LAST^TTIMEBOX)
								       (fetch KEYBOARDWAITTIME 										  of \MISCSTATS]
					       (IPLUS (IMINUS LAST^TDISKTIME)
						      (SETQ LAST^TDISKTIME (fetch DISKTRANSFERTIME 										   of \MISCSTATS]
				  144Q)
			  NONKEYBOARDTIME)
		%"%%%% UTIL%" T)
      (POSITION T POS))")



    (UNINTERRUPTABLY                                         (* UNINTERRUPTABLY only so you can't type ^T during ^T)

	(
PROG
 ((STKI (
COND

		       ((
STACKP
 POS)
			 0)
		       (T (
SETQ
 POS)
			  -3)))
	       TEMP SWAPDELTA NETIODELTA DISKIODELTA GCDELTA KEYBOARDDELTA TOTALDELTA)
	      (
SETQ
 TEMP (
STKNTHNAME
 STKI POS))
	      [printout T (do
 (
SELECTQ
 TEMP
				       ((
\INTERRUPTFRAME
 \INTERRUPTED INTERRUPTED \DOINTERRUPTHERE)
                                                             (* Skip over these)

					 (
SETQ
 TEMP (
STKNTHNAME
 (add
 STKI -1)
								POS)))
				       ((
\GETCHAR
 \GETKEY \TTYBACKGROUND)
					 (
SETQ
 TEMP (
STKNTHNAME
 (add
 STKI -1)
								POS))
					 (
SETQ
 $$VAL "IO wait in "))
				       ((
BLOCK
 \BACKGROUND AWAIT.EVENT MONITOR.AWAIT.EVENT 
					       \PROCESS.GO.TO.SLEEP)
                                                             (* Forms of blocking)

					 (
SETQ
 TEMP (
STKNTHNAME
 (add
 STKI -1)
								POS))
					 (
SETQ
 $$VAL "Waiting in "))
				       (
RETURN
 (
OR
 $$VAL "Running in "]
	      (bind
 (CNT _ 0)
		 do
 [
COND

		      ([
AND
 (
LITATOM
 TEMP)
			    (
OR
 \CONTROL-T.BACKSLASH (
NEQ
 (
NTHCHARCODE
 TEMP 1)
							  (
CHARCODE
 \]
			(
PRIN2
 TEMP T T)
			(
COND

			  ((
EQ
 (add
 CNT 1)
			       \CONTROL-T.DEPTH)
			    (
RETURN
))
			  (T (printout T " in "]
		    (
SETQ
 TEMP (
STKNTHNAME
 (add
 STKI -1)
					   POS)))
	      (
COND

		((
NULL
 LAST^TSWAPTIME)                       (* Just initialize the first time)

		  (
SETQ
 LAST^TTIMEBOX (
CLOCK0
 LAST^TTIMEBOX))
		  (
SETQ
 LAST^TSWAPTIME (fetch
 SWAPWAITTIME of
 \MISCSTATS))
		  (
SETQ
 LAST^TDISKIOTIME (fetch
 DISKIOTIME of
 \MISCSTATS))
		  (
SETQ
 LAST^TNETIOTIME (fetch
 NETIOTIME of
 \MISCSTATS))
		  (
SETQ
 LAST^TGCTIME (fetch
 GCTIME of
 \MISCSTATS)))
		(T (printout T ", ")                         (* calculates the amount of time spent not in disk wait

							     since the last control-T. Considers only time outside 

							     of key board wait.)

		   [
SETQ
 TOTALDELTA (
IPLUS
 (
IMINUS
 LAST^TTIMEBOX)
					   (
SETQ
 LAST^TTIMEBOX (
CLOCK0
 LAST^TTIMEBOX]
		   (\CONTROL-T.PRINTRATIO
 [
IDIFFERENCE
 TOTALDELTA
						       (
IPLUS
 [
SETQ
 SWAPDELTA
								(
IPLUS
 (
IMINUS
 LAST^TSWAPTIME)
								       (
SETQ
 LAST^TSWAPTIME
									 (fetch
 SWAPWAITTIME
									    of
 \MISCSTATS]
							      [
SETQ
 DISKIODELTA
								(
IPLUS
 (
IMINUS
 LAST^TDISKIOTIME)
								       (
SETQ
 LAST^TDISKIOTIME
									 (fetch
 DISKIOTIME
									    of
 \MISCSTATS]
							      [
SETQ
 NETIODELTA
								(
IPLUS
 (
IMINUS
 LAST^TNETIOTIME)
								       (
SETQ
 LAST^TNETIOTIME
									 (fetch
 NETIOTIME
									    of
 \MISCSTATS]
							      (
SETQ
 GCDELTA
								(
IPLUS
 (
IMINUS
 LAST^TGCTIME)
								       (
SETQ
 LAST^TGCTIME
									 (fetch
 GCTIME of
 \MISCSTATS]
					  TOTALDELTA "%% Util" T)
		   (\CONTROL-T.PRINTRATIO
 SWAPDELTA TOTALDELTA "%% Swap")
		   (\CONTROL-T.PRINTRATIO
 DISKIODELTA TOTALDELTA "%% DskIO")
		   (\CONTROL-T.PRINTRATIO
 NETIODELTA TOTALDELTA "%% Network")
		   (\CONTROL-T.PRINTRATIO
 GCDELTA TOTALDELTA "%% GC")))
	      (
TERPRI
 T)))])

(\CONTROL-T.PRINTRATIO

  [LAMBDA (N TOTAL LABEL NEWLINE)                            (* bvm: "31-Jul-85 19:04")

    (
COND

      ((
NEQ
 N 0)
	(
COND

	  (NEWLINE (
TERPRI
 T))
	  (T (printout T ", ")))
	[
COND

	  ((
OR
 (
IGREATERP
 N TOTAL)
	       (
ILESSP
 N 0))
	    (printout T "??"))
	  (T (printout T .I2 (
IQUOTIENT
 (
ITIMES
 N 100)
					TOTAL]
	(printout T LABEL])
)

(RPAQ? \CONTROL-T.DEPTH
 3)

(RPAQ? \CONTROL-T.BACKSLASH
 )

(RPAQ? LAST^TTIMEBOX
 (CLOCK 0))

(RPAQ? LAST^TSWAPTIME
 )

(RPAQ? LAST^TDISKIOTIME
 0)

(RPAQ? LAST^TGCTIME
 0)

(RPAQ? LAST^TNETIOTIME
 0)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \CONTROL-T.DEPTH \CONTROL-T.BACKSLASH LAST^TTIMEBOX LAST^TSWAPTIME LAST^TDISKIOTIME 
	    LAST^TNETIOTIME LAST^TGCTIME \MISCSTATS)
)

(ADDTOVAR \SYSTEMCACHEVARS
 LAST^TSWAPTIME)

(RPAQ? \CURRENTINTERRUPTS
 )

(RPAQ? \INTERRUPTABLE
 )

(RPAQ? INTERRUPTMENUFONT
 (QUOTE (GACHA 10)))

(RPAQQ \SYSTEMINTERRUPTS
 ((BREAK MOUSE)
			    (CONTROL-T)
			    (ERROR MOUSE)
			    (ERRORX)
			    (HELP T)
			    (OUTPUTBUFFER T)
			    (PRINTLEVEL)
			    (RAID T)
			    (RESET MOUSE)
			    (RUBOUT T)
			    (STORAGE)))
(DECLARE: EVAL@COMPILE DONTCOPY 

(ADDTOVAR NOFIXFNSLST
 CONTROL-T)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \CURRENTINTERRUPTS \SYSTEMINTERRUPTS INTERRUPTMENUFONT)
)
)
(DECLARE: EVAL@COMPILE 
(* FOLLOWING DEFINITIONS EXPORTED)



(ADDTOVAR SYSSPECVARS
 \INTERRUPTABLE)

(PUTPROPS UNINTERRUPTABLY INFO
 EVAL)

(PUTPROPS UNINTERRUPTABLY DMACRO
 ((X . Y)
				    ([LAMBDA (\INTERRUPTABLE)
					     (PROGN X . Y]
				     NIL)))

(ADDTOVAR PRETTYPRINTMACROS
 (UNINTERRUPTABLY
                                  LAMBDA (FORM)
				  (
PROG
 [(POS (
IPLUS
 4 (
POSITION
]
				          (
PRIN1
 "(")
				          (
PRIN2
 (
CAR
 FORM))
				          (
OR
 [
EQ
 COMMENTFLG (
CAAR
 (
SETQ
 FORM (
CDR
 FORM]
						(
TAB
 POS 0))
				          (
PRINTDEF
 FORM POS T T FNSLST)
				          (
PRIN1
 ")"))))


(* END EXPORTED DEFINITIONS)

DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


[DECLARE: EVAL@COMPILE 

(BLOCKRECORD INTERRUPTSTATE
 ((NIL BITS 3)
			       (GCDISABLED FLAG)
			       (VMEMFULL FLAG)
			       (STACKOVERFLOW FLAG)
			       (STORAGEFULL FLAG)
			       (WAITINGINTERRUPT FLAG)
			       (NIL BITS 8)
			       (INTCHARCODE WORD)))
]

(PUTPROPS \TAKEINTERRUPT DMACRO
 ((PREFORM POSTFORM)
				   (DECLARE (GLOBALVARS \PENDINGINTERRUPT))
				   (COND ((AND \PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK))
					  PREFORM
					  ([LAMBDA (\INTERRUPTABLE)
						   (\CALLINTERRUPTED]
					   T)
					  POSTFORM))))


(* END EXPORTED DEFINITIONS)


(DECLARE: EVAL@COMPILE 
(PUTPROPS \SYSTEMINTERRUPTP MACRO ((KEY)
	   (ASSOC KEY \SYSTEMINTERRUPTS)))
)
)
(PUTPROPS AINTERRUPT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1773 18933 (INTCHAR 1783 . 5786) (INTERRUPTCHAR 5788 . 6095) (INTERRUPTED 6097 . 8662) 
(LISPINTERRUPTS 8664 . 9118) (\DOHELPINTERRUPT 9120 . 9816) (\DOHELPINTERRUPT1 9818 . 10827) (
\DOINTERRUPTHERE 10829 . 11749) (\PROC.FINDREALFRAME 11751 . 12446) (\SETPRINTLEVEL 12448 . 13764) (
\SETRECLAIMMIN 13766 . 14477) (GETINTERRUPT 14479 . 15459) (CURRENTINTERRUPTS 15461 . 15673) (
SETINTERRUPT 15675 . 17246) (RESET.INTERRUPTS 17248 . 18792) (INTERRUPTABLE 18794 . 18931)) (18949 
23726 (CONTROL-T 18959 . 23318) (\CONTROL-T.PRINTRATIO 23320 . 23724)))))
STOP