3 <RENTRY CLASS ENABLE ENABLED? DISABLE ON ON? OFF HANDLER QUITTER
4 STOPPER INT-LEVEL INTERRUPT INTON DISMISS EMERGENCY
11 '<<PRIMTYPE VECTOR> STRING
20 '<<PRIMTYPE VECTOR> CLASS
21 <OR APPLICABLE FUNCTION>
26 <DEFINE CLASS (CNAM "OPTIONAL" (PRI <>) (CREATE? <>) (CHAN <>)
27 (NO-DEFER? <>) "AUX" CATM C)
28 #DECL ((CNAM) STRING (CATM CREATE?) <OR FALSE ATOM> (C) ANY
29 (PRI CHAN) <OR FIX FALSE>)
30 <COND (<AND <SET CATM <LOOKUP .CNAM <INTERRUPTS>>>
32 <TYPE? <SET C <GVAL .CATM>> CLASS>>
33 <COND (<NOT <M$$C-CHANNEL .C>>
34 <M$$C-CHANNEL .C .CHAN>)>
35 <COND (.PRI <M$$C-PRIORITY .C .PRI>)>
38 <COND (<NOT .PRI> <SET PRI 1>)>
39 <SETG <OR <LOOKUP .CNAM <INTERRUPTS>>
40 <INSERT .CNAM <INTERRUPTS>>>
41 <CHTYPE [.CNAM T <> .CHAN .PRI .NO-DEFER?] CLASS>>)>>
43 <DEFINE ENABLE (CNAM "OPTIONAL" (ENA? T) "AUX" C)
44 #DECL ((CNAM) STRING (ENA?) <OR ATOM FALSE> (C) <OR FALSE CLASS>)
45 <COND (<SET C <CLASS .CNAM>>
46 <M$$C-ENABLE .C .ENA?>)>>
48 <DEFINE DISABLE (CNAM)
52 <DEFINE ENABLED? (CNAM "AUX" C)
53 #DECL ((CNAM) STRING (C) <OR FALSE CLASS>)
54 <COND (<SET C <CLASS .CNAM>>
57 <DEFINE ON (HAND "AUX" C H HP ATM)
58 #DECL ((HAND) <OR CLASS HANDLER> (C) CLASS (H) <OR FALSE HANDLER>
60 <COND (<TYPE? .HAND HANDLER>
61 <SET C <M$$H-CLASS .HAND>>
62 <SET H <M$$C-HANDLER .C>>
63 <SET HP <M$$H-PRIORITY .HAND>>
64 <COND (<N==? .C ,M$$EVALCLASS!-INTERNAL>
66 <COND (<ON? .HAND> .HAND)
68 <G? .HP <M$$H-PRIORITY .H>>>
70 <M$$C-HANDLER .C .HAND>
76 <G? .HP <M$$H-PRIORITY .H>>>
82 <SET H <M$$H-NEXT .H>>)>>)>)
84 <SET ATM <OR <LOOKUP <M$$C-NAME .HAND> <INTERRUPTS>>
85 <INSERT <M$$C-NAME .HAND> <INTERRUPTS>>>>
86 <COND (<NOT <GASSIGNED? .ATM>>
88 <COND (<M$$C-CHANNEL .HAND>
89 <PUT ,M$$INT-CLASSES:VECTOR <M$$C-CHANNEL .HAND>
93 <ERROR CLASS ALREADY-EXISTS!-ERRORS .ATM .HAND
96 <DEFINE OFF (HAND "AUX" C H CC)
97 #DECL ((HAND) <OR CLASS STRING CHARACTER HANDLER>
98 (C) CLASS (H) <OR FALSE HANDLER>)
99 <COND (<TYPE? .HAND HANDLER>
100 <SET C <M$$H-CLASS .HAND>>
101 <SET H <M$$C-HANDLER .C>>
102 <COND (<==? .H .HAND>
103 <M$$C-HANDLER .C <M$$H-NEXT <CHTYPE .H HANDLER>>>
107 #DECL ((H) <OR FALSE HANDLER> (LH) HANDLER)
108 <COND (<NOT .H> <RETURN <>>)
110 <M$$H-NEXT .LH <M$$H-NEXT .H>>
114 <SET H <M$$H-NEXT .H>>)>>)>)
116 <COND (<TYPE? .HAND CHARACTER>
117 <SET HAND <STRING .HAND>>)>
118 <COND (<OR <AND <TYPE? .HAND CLASS>
120 <SET CC <CLASS <M$$C-NAME .CC>>>>
121 <SET CC <CLASS .HAND>>>
123 #DECL ((V) <OR VECTOR FALSE>)
124 <COND (<SET V <MEMQ .CC ,M$$INT-CLASSES:VECTOR>>
127 <GUNASSIGN <LOOKUP <M$$C-NAME .CC> <INTERRUPTS>>>
131 #DECL ((HAND) <OR CLASS HANDLER>)
132 <COND (<TYPE? .HAND CLASS>
133 <CLASS <M$$C-NAME .HAND>>)
135 <REPEAT ((H <M$$C-HANDLER <M$$H-CLASS .HAND>>))
136 #DECL ((H) <OR FALSE HANDLER>)
137 <COND (<NOT .H> <RETURN <>>)
138 (<==? .H .HAND> <RETURN T>)
139 (T <SET H <M$$H-NEXT .H>>)>>)>>
148 <MANIFEST M$$INFINT M$$CONTINT M$$PIPEINT M$$URGINT M$$IOINT M$$STKINT>>
150 <DEFINE HANDLER (CNAM APP "OPTIONAL" (LEV 0) (ARG <>) "AUX" C)
151 #DECL ((CNAM) <OR STRING CHARACTER> (APP) APPLICABLE
153 <COND (<TYPE? .CNAM CHARACTER>
154 <PUT ,M$$INT-CLASSES:VECTOR
155 <SET C <CALL ATIC .CNAM>>
156 <CLASS <SET CNAM <STRING .CNAM>> <> T .C>>)
157 (<=? .CNAM "INFERIOR">
158 <PUT ,M$$INT-CLASSES:VECTOR ,M$$INFINT
159 <CLASS .CNAM <> T ,M$$INFINT>>)
162 <COND (<=? .CNAM "CONTINUE">
163 <PUT ,M$$INT-CLASSES:VECTOR ,M$$CONTINT
164 <CLASS .CNAM <> T ,M$$CONTINT>>)
166 <PUT ,M$$INT-CLASSES:VECTOR ,M$$PIPEINT
167 <CLASS .CNAM <> T ,M$$PIPEINT>>)
170 <M$$URGINT ,M$$INT-CLASSES:VECTOR
171 <CLASS .CNAM <> T ,M$$URGINT>>)
173 <M$$IOINT ,M$$INT-CLASSES:VECTOR
174 <CLASS .CNAM <> T ,M$$IOINT>>)
176 <M$$STKINT ,M$$INT-CLASSES:VECTOR
177 <CLASS .CNAM <> <> ,M$$STKINT>>)>)>)>
178 <CHTYPE [<CLASS .CNAM <> T> .APP .LEV .ARG <>] HANDLER>>
180 <DEFINE NI$INTERRUPT II (CNUM "TUPLE" TUP
181 "AUX" (OLEV ,M$$INT-LEVEL)
182 C LEV (LV T) (NO-DEFER? <>) TC)
183 #DECL ((CNUM) <OR FIX CLASS VECTOR> (TUP) TUPLE (C) CLASS
186 <COND (<TYPE? .CNUM FIX>
187 <COND (<SET TC <NTH ,M$$INT-CLASSES:VECTOR .CNUM>>
189 (T <RETURN <> .II>)>)
190 (<TYPE? .CNUM VECTOR>
191 <SET C <CHTYPE .CNUM CLASS>>
196 <COND (<M$$C-ENABLE .C>
197 <COND (<L=? <M$$C-PRIORITY .C> .OLEV>
200 ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT!-ERRORS
203 (<N==? .C ,M$$EVALCLASS!-INTERNAL>
204 ; "Not very useful to queue eval interrupts"
205 <PROG ((Q ,M$$INT-QUEUE)
206 (P <M$$C-PRIORITY .C>) TL)
207 #DECL ((Q) LIST (P) FIX
208 (TL) <OR FALSE <LIST FIX [2 LIST]>>)
209 ; "Maintain a separate queue for each
211 <COND (<SET TL <MEMQ .P .Q>>
212 <2 .TL <REST <PUTREST <2 .TL>
215 <REPEAT ((OL <REST .Q>)
217 #DECL ((OL) <LIST [REST FIX LIST LIST]>
219 <COND (<OR <EMPTY? .OL> <L? <1 .OL> .P>>
221 (.P <REST .NL> .NL !.OL)>
225 <REST <PUTREST <2 .OL>
229 <SET OL <REST .OL 3>>>)>>)>)
231 <COND (<==? .C ,M$$EVALCLASS!-INTERNAL>
232 <COND (<AND <ASSIGNED? GC-RUNNING!- >
234 ; "Don't run eval interrupts in GC"
236 <M$$C-ENABLE .C <>>)>
239 <SET LV <RUN-INTERRUPT .C .OLEV !.TUP>>
240 <COND (<==? .C ,M$$EVALCLASS!-INTERNAL>
245 <COND (<==? .C ,M$$EVALCLASS!-INTERNAL>
246 <M$$C-ENABLE .C T>)>>>)>)>>
248 <DEFINE EMERGENCY (CNAM "TUPLE" TUP "AUX" C)
249 #DECL ((CNAM) STRING (TUP) TUPLE (C) <OR FALSE CLASS>)
250 <COND (<SET C <CLASS .CNAM>>
251 <I$INTERRUPT <CHTYPE .C VECTOR> !.TUP>)>>
253 <DEFINE INTERRUPT (CNAM "TUPLE" TUP "AUX" C)
254 #DECL ((CNAM) STRING (TUP) TUPLE (C) <OR FALSE CLASS>)
255 <COND (<SET C <CLASS .CNAM>>
256 <I$INTERRUPT .C !.TUP>)>>
258 ; "How interrupts are handled:
259 I$INTERRUPT compares the priority of the class it's called with to
260 M$$INT-LEVEL. If the interrupt cannot be run immediately, either it is
261 queued (from interrupt), or REAL-ERROR is called (from emergency).
262 If the interrupt can be run, RUN-INTERRUPT is called. It raises
263 the interrupt level to the class's priority, and wanders down its
264 chain of handlers, applying each in turn. Finally, <INT-LEVEL .OLEV>
265 is called, lowering the interrupt level.
266 When INT-LEVEL is called to lower the interrupt level, it wanders
267 down M$$INT-QUEUE processing (via RUN-INTERRUPT) those queued interrupts
268 that can now be handled. Since RUN-INTERRUPT calls INT-LEVEL, this will
269 mostly happen recursively."
271 <DEFINE RUN-INTERRUPT (C INTENDED-LEVEL "TUPLE" ARGS "AUX" (OLEV ,M$$INT-LEVEL) H
273 #DECL ((C) CLASS (OLEV) FIX (INTENDED-LEVEL) <SPECIAL FIX>)
274 <COND (<SET H <M$$C-HANDLER .C>>
275 <COND (<G? <M$$C-PRIORITY .C> .OLEV>
277 <INT-LEVEL <M$$C-PRIORITY .C>>)>
279 #DECL ((LINT) <SPECIAL FRAME>)
280 <SET LV <APPLY <M$$H-FUNCTION .H>
283 <COND (<OR <TYPE? .LV DISMISS> <NOT <SET H <M$$H-NEXT .H>>>>
284 <COND (.INT-LEVEL? <INT-LEVEL .OLEV>)>
285 <RETURN <COND (<TYPE? .LV DISMISS> T)(T .LV)>>)>>)>>
287 <DEFINE INT-LEVEL ("OPTIONAL" LEV "AUX" (OLEV ,M$$INT-LEVEL))
288 #DECL ((LEV OLEV) FIX)
289 <COND (<AND <ASSIGNED? LEV> <L? .LEV .OLEV>>
290 <REPEAT (MAIN-QUEUE RUN-QUEUE
291 NLEV IL C LEV-QUEUE LEV-RUN-QUEUE)
292 #DECL ((RUN-QUEUE) <LIST [REST FIX LIST LIST]>
294 (C) CLASS (NLEV) FIX (MAIN-QUEUE) LIST)
295 <SET MAIN-QUEUE ,M$$INT-QUEUE>
296 <SET RUN-QUEUE <REST .MAIN-QUEUE>>
297 <COND (<EMPTY? .RUN-QUEUE> <RETURN>)>
298 <COND (<G=? .LEV <1 .RUN-QUEUE>>
299 ; "No interrupts with enough priority"
301 <SET LEV-QUEUE <3 .RUN-QUEUE>>
302 <SET LEV-RUN-QUEUE <REST .LEV-QUEUE>>
303 <COND (<EMPTY? .LEV-RUN-QUEUE>
304 ; "No more queued interrupts at this level"
305 <PUTREST .MAIN-QUEUE <REST .RUN-QUEUE 3>>
308 <SET C <1 <SET IL <1 .LEV-RUN-QUEUE>>>>
309 <COND (<==? <2 .RUN-QUEUE> .LEV-RUN-QUEUE>
310 ; "Running last thing on this queue, so
311 make sure pointer doesn't get dropped"
312 <2 .RUN-QUEUE <3 .RUN-QUEUE>>)>
313 ; "Splice this interrupt out"
314 <PUTREST .LEV-QUEUE <REST .LEV-RUN-QUEUE>>
315 <RUN-INTERRUPT .C .LEV !<REST .IL>>>
316 <SETG M$$INT-LEVEL .LEV>)
318 <SETG M$$INT-LEVEL .LEV>)>
321 <DEFINE DISMISS (VAL "OPTIONAL" ACT LEV)
322 #DECL ((VAL) ANY (ACT) FRAME (LEV) FIX)
323 <COND (<ASSIGNED? LEV>
325 (<ASSIGNED? INTENDED-LEVEL>
326 <INT-LEVEL .INTENDED-LEVEL>)>
327 <COND (<NOT <ASSIGNED? ACT>>
328 <COND (<NOT <ASSIGNED? LINT>>
329 <RETURN .VAL .LPROG!-INTERRUPTS>)
333 <DEFINE QUITTER (ARG)
336 <ERROR CONTROL-G!-ERRORS>>
338 <DEFINE STOPPER (ARG)
341 <AGAIN .LERR!-INTERRUPTS>>
343 <DEFINE STACK-OVERFLOW (ARG "AUX" VAL)
348 <COND (<1? <CHTYPE <CALL BIGSTACK 0> FIX>>
349 ; "Will return 1 if stack is already big"
350 <REAL-ERROR STACK-AT-LIMIT!-ERRORS
352 ERRET-T-TO-FATAL!-ERRORS>)
353 (<SET VAL <REAL-ERROR STACK-OVERFLOW!-ERRORS
355 ERRET-T-TO-CONTINUE!-ERRORS>>
356 ; "Say let stack become big"
357 <CALL BIGSTACK 1>)>)>
360 <DEFINE INTON ("AUX" NM)
361 <NEWTYPE CLASS VECTOR>
362 <NEWTYPE HANDLER VECTOR>
363 <CALL SETS ICALL 'I$INTERRUPT>
364 <SETG M$$INT-QUEUE (T)>
365 <SETG M$$INT-QUEUE-R ,M$$INT-QUEUE>
366 <SETG M$$INT-LEVEL 0>
368 [<> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <>
369 <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <>]>
370 <SETG M$$EVALCLASS!-INTERNAL <M$$H-CLASS <HANDLER "EVAL" ,TIME 1>>>
372 <COND (<SET NM <LOOKUP <STRING <ASCII 7>> <INTERRUPTS>>>
375 <COND (<SET NM <LOOKUP <STRING <ASCII 1>> <INTERRUPTS>>>
378 <CLASS <STRING <ASCII 7>> 6 T>
379 <CLASS <STRING <ASCII 1>> 5 T>
381 <CLASS "STKINT" 1000 T ,M$$STKINT T>
382 <ON <HANDLER "STKINT" ,STACK-OVERFLOW>>)>
383 <ON <HANDLER <ASCII 7> ,QUITTER>>
384 <ON <HANDLER <ASCII 1> ,STOPPER>>
387 <DEFINE PRINT-HANDLER (HAND "AUX" (OUTCHAN .OUTCHAN))
388 #DECL ((HAND) HANDLER (OUTCHAN) CHANNEL)
389 <PRINC "#HANDLER [" .OUTCHAN>
390 <PRINC <M$$C-NAME <M$$H-CLASS .HAND>> .OUTCHAN>
391 <COND (<NOT <ON? <M$$H-CLASS .HAND>>>
392 <PRINC ":OFF" .OUTCHAN>)>
394 <COND (<NOT <ON? .HAND>>
395 <PRINC "OFF " .OUTCHAN>)>
396 <PRINC <M$$H-PRIORITY .HAND> .OUTCHAN>
398 <PRINC <M$$H-ARG .HAND> .OUTCHAN>
400 <PRINC <M$$H-FUNCTION .OUTCHAN> .OUTCHAN>
401 <PRINC !\] .OUTCHAN>>
403 <DEFINE PRINT-CLASS (CLASS "AUX" (OUTCHAN .OUTCHAN))
404 #DECL ((CLASS) CLASS (OUTCHAN) CHANNEL)
405 <PRINC "#CLASS [" .OUTCHAN>
406 <PRINC <M$$C-NAME .CLASS> .OUTCHAN>
408 <COND (<NOT <ON? .CLASS>>
409 <PRINC "OFF " .OUTCHAN>)>
410 <COND (<NOT <M$$C-ENABLE .CLASS>>
411 <PRINC "DISABLED " .OUTCHAN>)>
412 <COND (<M$$C-HANDLER .CLASS>
413 <PRINC "#HANDLER [&] " .OUTCHAN>)
414 (<PRINC "<> " .OUTCHAN>)>
415 <PRINC <M$$C-CHANNEL .CLASS> .OUTCHAN>
417 <PRINC <M$$C-PRIORITY .CLASS> .OUTCHAN>
418 <PRINC !\] .OUTCHAN>>
420 <COND (<GASSIGNED? PRINT-HANDLER>
421 <PRINTTYPE HANDLER ,PRINT-HANDLER>
422 <PRINTTYPE CLASS ,PRINT-CLASS>)>