(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "17-Sep-92 10:42:38" "{Pele:mv:envos}Sources>AINTERRUPT.;4" 41128 |changes| |to:| (FNS INTCHAR GETINTERRUPT) |previous| |date:| "28-Jun-90 18:45:07" "{Pele:mv:envos}Sources>AINTERRUPT.;3") ; Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1989, 1990, 1992 by Venue & 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)) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (INTCHAR T))) (COMS (* |;;| "^T this is actually not very useful any more, and the percentages are wrong") (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)) (ADDVARS (FONTVARS (INTERUPTMENUFONT DEFAULTFONT T))) (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) (* \; "Edited 17-Sep-92 10:41 by jds") (* |;;| "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* '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 'interruptchar val nil nil table))) (return val)))) (INTERRUPTED (LAMBDA NIL (* \; "Edited 28-Jun-90 18:43 by jds") (* |;;| "This function gets control whenever an \"interrupt\" of some sort is signalled to Lisp, apart from the timer and keyboard-I/O handling interrupts. It dispatches to the proper handler routine for the \"hard-wired\" interrupt types, and signals the appropriate soft interrupt for interrupt characters.") (DECLARE (GLOBALVARS \\INTERRUPTSTATE) (USEDFREE \\MOUSEBUSY \\INTERRUPTABLE)) (COND ((NULL \\INTERRUPTABLE) (SETQ \\PENDINGINTERRUPT T) (|replace| (INTERRUPTSTATE IN-PROGRESS) |of| \\INTERRUPTSTATE |with| 0)) (T (COND ((|fetch| (INTERRUPTSTATE ETHERINTERRUPT) |of| \\INTERRUPTSTATE) (\\MAIKO.ETHER-INTERRUPT) (|replace| (INTERRUPTSTATE P-ETHERINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL))) (COND ((|fetch| (INTERRUPTSTATE LOGMSGSPENDING) |of| \\INTERRUPTSTATE) (\\MAIKO.CONSOLE-LOG-PRINT) (|replace| (INTERRUPTSTATE P-LOGMSGSPENDING) |of| \\INTERRUPTSTATE |with| NIL))) (COND ((|fetch| (INTERRUPTSTATE IOINTERRUPT) |of| \\INTERRUPTSTATE) (\\MAIKO.IO-INTERRUPT) (|replace| (INTERRUPTSTATE P-IOINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL))) (COND ((|fetch| (INTERRUPTSTATE STORAGEFULL) |of| \\INTERRUPTSTATE) (\\DOSTORAGEFULLINTERRUPT) (|replace| (INTERRUPTSTATE P-STORAGEFULL) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE STACKOVERFLOW) |of| \\INTERRUPTSTATE) (\\DOSTACKFULLINTERRUPT) (|replace| (INTERRUPTSTATE P-STACKOVERFLOW) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE VMEMFULL) |of| \\INTERRUPTSTATE) (\\DOVMEMFULLINTERRUPT) (|replace| (INTERRUPTSTATE P-VMEMFULL) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE GCDISABLED) |of| \\INTERRUPTSTATE) (\\DOGCDISABLEDINTERRUPT) (|replace| (INTERRUPTSTATE P-GCDISABLED) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE) (LET* ((CH (|fetch| (INTERRUPTSTATE INTCHARCODE) |of| \\INTERRUPTSTATE)) (INTERRUPT (CDR (ASSOC CH (|fetch| (KEYACTION INTERRUPTLIST) |of| \\CURRENTKEYACTION ))))) (|replace| (INTERRUPTSTATE INTCHARCODE) |of| \\INTERRUPTSTATE |with| 0) (COND (INTERRUPT (LET* ((CLASS (CAR INTERRUPT)) (HARDFLG (CADR INTERRUPT)) (THISPROC (THIS.PROCESS)) (INTERRUPTED.PROC (COND ((OR (NULL THISPROC) (EQ HARDFLG T)) THISPROC) ((EQ HARDFLG 'MOUSE) (LET ((MP THISPROC)) (* \;  "Interrupt MOUSE proc if it's busy, else the tty process") (COND ((COND ((EQ (PROCESSPROP MP 'NAME) 'MOUSE) \\MOUSEBUSY) ((SETQ MP (FIND.PROCESS 'MOUSE)) (PROCESS.EVALV MP '\\MOUSEBUSY))) MP) (T (TTY.PROCESS))))) ((EQ HARDFLG 'WHICHW) (* \;  "Interrupt the process that owns the window the mouse is in") (AND (GETD 'WHICHW) (LET ((W (WHICHW))) (AND W (WINDOWPROP W 'PROCESS))))) (T (TTY.PROCESS))))) (COND ((EQ THISPROC INTERRUPTED.PROC) (|replace| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (\\DOINTERRUPTHERE CLASS) (|replace| (INTERRUPTSTATE P-WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL)) ((NULL INTERRUPTED.PROC) (* \;  "Nobody qualified, so dismiss interrupt") (|replace| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (|replace| (INTERRUPTSTATE P-WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) NIL) ((\\PROCESS.MAKEFRAME INTERRUPTED.PROC (FUNCTION \\DOINTERRUPTHERE) (LIST CLASS CH HARDFLG)) (|replace| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (|replace| (INTERRUPTSTATE P-WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL)) (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.|) '((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.|  w\e |treat| ^b |same| |as| ^h\, |except| |that| |former| |always| |occurs|  |in| |tty| |process.| break |interrupt| |used| |to| |just| |do| \a  (errorx (list 18 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)) '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 (* |lmm| "30-Dec-85 17:08") (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) (prin3 "set printlevel to: " t) (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 (* |lmm| "30-Dec-85 17:08") (prog (buf olb osb ch) (\\bout \\term.ofd (charcode bell)) (setq olb (linbuf t)) (setq osb (sysbuf t)) (clearbuf t t) (prin3 "set RECLAIMMIN to: " t) (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) (* \; "Edited 17-Sep-92 10:41 by jds") (* |;;| "Return the interrupt, if any, defined for CHAR in keyaction table TABLE.") (* |;;| "NIL => all user interrupts") (* |;;| "T => all system interrupts") (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) (* \; "Edited 20-Nov-87 11:00 by Snow") (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)(CHAR CLASS) etc.)") (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") nil) ((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 \\currentkeyaction)) (* \; "Edited 20-Nov-87 10:44 by Snow") (* |;;| "Returns list of previous settings, for use by RESETFORM but only when 2nd arg is non-NIL. --- PermittedInterrupts is a list of triples of the form (charcode interrupt hardness)") (cond (|PermittedInterrupts| (setq |PermittedInterrupts| (|for| triple |in| |PermittedInterrupts| |collect| (cond ((or (nlistp triple) (not (charcodep (car triple))) (nlistp (cdr triple))) (\\illegal.arg |PermittedInterrupts|)) ((nlistp (cddr triple)) (* \;  "Not a triple, so default the hardness to system hardness") (list (car triple) (cadr triple) (cadr (assoc (cadr triple) \\systeminterrupts)))) (t triple)))))) (uninterruptably (prog1 (and |SaveCurrent?| (|fetch| (keyaction interruptlist) |of| \\currentkeyaction )) (|replace| (keyaction interruptlist) |of| \\currentkeyaction |with| |PermittedInterrupts| ))))) (interruptable (lambda (flag) (* |lmm| "18-APR-82 13:52") (prog1 \\interruptable (setq \\interruptable flag)))) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (INTCHAR T) ) (* |;;| "^T this is actually not very useful any more, and the percentages are wrong") (DEFINEQ (control-t (lambda (pos out) (* \; "Edited 6-Dec-86 04:57 by lmm") (or out (setq out (getstream promptwindow 'output))) (|if| (and (hasttywindowp) (neq (ttydisplaystream) out) (wfromds (ttydisplaystream)) (openwp (wfromds (ttydisplaystream)))) |then| (flashwindow (ttydisplaystream) 1 10)) (uninterruptably (* \;  "UNINTERRUPTABLY only so you can't type ^T during ^T") (prog ((stki (cond ((stackp pos) 0) (t (setq pos 'control-t) -3))) temp swapdelta netiodelta diskiodelta gcdelta keyboarddelta totaldelta) (setq temp (stknthname stki pos)) (printout out "Process: " (process.name (this.process)) ", ") (|printout| out (|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 "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 "in "))))) (|bind| (cnt _ 0) |do| (cond ((xcl::interesting-frame-p temp) (prin2 temp out t) (cond ((eq (|add| cnt 1) \\control-t.depth) (return)) (t (|printout| out " in "))))) (setq temp (stknthname (|add| stki -1) pos))) (cond ((null last^tswaptime) (* \; "Just initialize the first time") (setq last^ttimebox (clock)) (setq last^tdiskiotime (|fetch| diskiotime |of| \\miscstats)) (setq last^tnetiotime (|fetch| netiotime |of| \\miscstats)) (setq last^tgctime (|fetch| gctime |of| \\miscstats)) (setq last^tswaptime (|fetch| swapwaittime |of| \\miscstats))) (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)))) (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) ))) (\\control-t.printratio swapdelta totaldelta "% Swap" nil out) (\\control-t.printratio diskiodelta totaldelta "% DskIO" nil out) (\\control-t.printratio netiodelta totaldelta "% Network" nil out) (\\control-t.printratio gcdelta totaldelta "% GC" nil out))) (terpri out))))) (\\control-t.printratio (lambda (n total label newline stream) (* \; "Edited 4-Dec-86 21:13 by lmm") (cond ((neq n 0) (cond (newline (terpri stream)) (t (|printout| stream ", "))) (cond ((or (igreaterp n total) (ilessp n 0)) (|printout| stream "??")) (t (|printout| stream |.I2| (iquotient (itimes n 100) total)))) (|printout| stream 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 ) (ADDTOVAR FONTVARS (INTERUPTMENUFONT DEFAULTFONT T)) (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 ( (* |;;| "This is the structure used to communicate between the emulator and Lisp re interrupts. There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt.") (* |;;| "This must match the INTSTAT definition in lispemul.h") (* |;;| "PENDING-INTERRUPT FLAGS:") (LOGMSGSPENDING FLAG) (* \;  " Log/Console msgs need printing.") (ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (IOINTERRUPT FLAG) (GCDISABLED FLAG) (* \; "No mroe room in GC tables.") (VMEMFULL FLAG) (* \; "VMEM is full!!") (STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (STORAGEFULL FLAG) (* \;  "Ran out of storage, atoms, etc.") (WAITINGINTERRUPT FLAG) (* |;;| "INTERRUPTS-IN-PROCESS MASK:") (P-LOGMSGSPENDING FLAG) (* \;  " Log/Console msgs need printing.") (P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (P-IOINTERRUPT FLAG) (P-GCDISABLED FLAG) (* \; "No mroe room in GC tables.") (P-VMEMFULL FLAG) (* \; "VMEM is full!!") (P-STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (P-STORAGEFULL FLAG) (* \;  "Ran out of storage, atoms, etc.") (P-WAITINGINTERRUPT FLAG) (INTCHARCODE WORD)) (BLOCKRECORD INTERRUPTSTATE ( (* |;;|  "Alternative view of the structure:") (PENDING BITS 8) (* \; "Pending-interrupt flags") (IN-PROGRESS BITS 8) (* \;  "Mask to prevent re-interrupt for an interrupt in progress") (NIL 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 ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1989 1990 1992)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2572 28843 (INTCHAR 2582 . 7650) (INTERRUPTCHAR 7652 . 7926) (INTERRUPTED 7928 . 15507) (LISPINTERRUPTS 15509 . 16026) (\\DOHELPINTERRUPT 16028 . 16926) (\\DOHELPINTERRUPT1 16928 . 18326) ( \\DOINTERRUPTHERE 18328 . 19508) (\\PROC.FINDREALFRAME 19510 . 20314) (\\SETPRINTLEVEL 20316 . 22268) (\\SETRECLAIMMIN 22270 . 23143) (GETINTERRUPT 23145 . 24519) (CURRENTINTERRUPTS 24521 . 24731) ( SETINTERRUPT 24733 . 26711) (RESET.INTERRUPTS 26713 . 28670) (INTERRUPTABLE 28672 . 28841)) (28991 34975 (CONTROL-T 29001 . 34442) (\\CONTROL-T.PRINTRATIO 34444 . 34973))))) STOP