X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;ds=sidebyside;f=mim%2Fdevelopment%2Fmim%2Fvax%2Fint.mud;fp=mim%2Fdevelopment%2Fmim%2Fvax%2Fint.mud;h=cd9d890ce827e1f9fc990c2b17ad6ad095b677c9;hb=d73ace3f3292e320b461b8fcd2e9f5dc5d9684d7;hp=0000000000000000000000000000000000000000;hpb=d530283ea60fb0ddcc28e9c5bd072456afe06e07;p=pdp10-muddle.git

diff --git a/mim/development/mim/vax/int.mud b/mim/development/mim/vax/int.mud
new file mode 100644
index 0000000..cd9d890
--- /dev/null
+++ b/mim/development/mim/vax/int.mud
@@ -0,0 +1,424 @@
+<PACKAGE "INT">
+
+<RENTRY CLASS ENABLE ENABLED? DISABLE ON ON? OFF HANDLER QUITTER
+	STOPPER INT-LEVEL INTERRUPT INTON DISMISS EMERGENCY
+	INTERRUPT-HANDLER>
+
+<NEWTYPE DISMISS ATOM>
+
+<NEWTYPE CLASS
+	 VECTOR
+	 '<<PRIMTYPE VECTOR> STRING
+			     <OR ATOM FALSE>
+			     <OR HANDLER FALSE>
+			     <OR FIX FALSE>
+			     FIX
+			     <OR ATOM FALSE>>>
+
+<NEWTYPE HANDLER
+	 VECTOR
+	 '<<PRIMTYPE VECTOR> CLASS
+			     <OR APPLICABLE FUNCTION>
+			     FIX
+			     ANY
+			     <OR FALSE HANDLER>>>
+
+<DEFINE CLASS (CNAM "OPTIONAL" (PRI <>) (CREATE? <>) (CHAN <>)
+	       (NO-DEFER? <>) "AUX" CATM C)
+	#DECL ((CNAM) STRING (CATM CREATE?) <OR FALSE ATOM> (C) ANY
+	       (PRI CHAN) <OR FIX FALSE>)
+	<COND (<AND <SET CATM <LOOKUP .CNAM <INTERRUPTS>>>
+		    <GASSIGNED? .CATM>
+		    <TYPE? <SET C <GVAL .CATM>> CLASS>>
+	       <COND (<NOT <M$$C-CHANNEL .C>>
+		      <M$$C-CHANNEL .C .CHAN>)>
+	       <COND (.PRI <M$$C-PRIORITY .C .PRI>)>
+	       .C)
+	      (.CREATE?
+	       <COND (<NOT .PRI> <SET PRI 1>)>
+	       <SETG <OR <LOOKUP .CNAM <INTERRUPTS>>
+			 <INSERT .CNAM <INTERRUPTS>>>
+		     <CHTYPE [.CNAM T <> .CHAN .PRI .NO-DEFER?] CLASS>>)>>
+
+<DEFINE ENABLE (CNAM "OPTIONAL" (ENA? T) "AUX" C)
+	#DECL ((CNAM) STRING (ENA?) <OR ATOM FALSE> (C) <OR FALSE CLASS>)
+	<COND (<SET C <CLASS .CNAM>>
+	       <M$$C-ENABLE .C .ENA?>)>>
+
+<DEFINE DISABLE (CNAM)
+	#DECL ((CNAM) STRING)
+	<ENABLE .CNAM <>>>
+
+<DEFINE ENABLED? (CNAM "AUX" C)
+	#DECL ((CNAM) STRING (C) <OR FALSE CLASS>)
+	<COND (<SET C <CLASS .CNAM>>
+	       <M$$C-ENABLE .C>)>>
+
+<DEFINE ON (HAND "AUX" C H HP ATM)
+	#DECL ((HAND) <OR CLASS HANDLER> (C) CLASS (H) <OR FALSE HANDLER>
+	       (HP) FIX)
+	<COND (<TYPE? .HAND HANDLER>
+	       <SET C <M$$H-CLASS .HAND>>
+	       <SET H <M$$C-HANDLER .C>>
+	       <SET HP <M$$H-PRIORITY .HAND>>
+	       <COND (<N==? .C ,M$$EVALCLASS!-INTERNAL>
+		      <M$$C-ENABLE .C T>)>
+	       <COND (<ON? .HAND> .HAND)
+		     (<OR <NOT .H>
+			  <G? .HP <M$$H-PRIORITY .H>>>
+		      <M$$H-NEXT .HAND .H>
+		      <M$$C-HANDLER .C .HAND>
+		      .HAND)
+		     (T
+		      <REPEAT (OH)
+			      #DECL ((OH) HANDLER)
+			      <COND (<OR <NOT .H>
+					 <G? .HP <M$$H-PRIORITY .H>>>
+				     <M$$H-NEXT .OH .HAND>
+				     <M$$H-NEXT .HAND .H>
+				     <RETURN .HAND>)
+				    (T
+				     <SET OH .H>
+				     <SET H <M$$H-NEXT .H>>)>>)>)
+	      (T
+	       <SET ATM <OR <LOOKUP <M$$C-NAME .HAND> <INTERRUPTS>>
+			    <INSERT <M$$C-NAME .HAND> <INTERRUPTS>>>>
+	       <COND (<NOT <GASSIGNED? .ATM>>
+		      <SETG .ATM .HAND>
+		      <COND (<M$$C-CHANNEL .HAND>
+			     <PUT ,M$$INT-CLASSES:VECTOR <M$$C-CHANNEL .HAND>
+				  .HAND>)>
+		      .HAND)
+		     (<N==? ,.ATM .HAND>
+		      <ERROR CLASS ALREADY-EXISTS!-ERRORS .ATM .HAND
+			     ON>)>)>>
+
+<DEFINE OFF (HAND "AUX" C H CC)
+	#DECL ((HAND) <OR CLASS STRING CHARACTER HANDLER>
+	       (C) CLASS (H) <OR FALSE HANDLER>)
+	<COND (<TYPE? .HAND HANDLER>
+	       <SET C <M$$H-CLASS .HAND>>
+	       <SET H <M$$C-HANDLER .C>>
+	       <COND (<==? .H .HAND>
+		      <M$$C-HANDLER .C <M$$H-NEXT <CHTYPE .H HANDLER>>>
+		      T)
+		     (T
+		      <REPEAT ((H .H) LH)
+		        #DECL ((H) <OR FALSE HANDLER> (LH) HANDLER)
+			<COND (<NOT .H> <RETURN <>>)
+			      (<==? .H .HAND>
+			       <M$$H-NEXT .LH <M$$H-NEXT .H>>
+			       <RETURN T>)
+			      (T
+			       <SET LH .H>
+			       <SET H <M$$H-NEXT .H>>)>>)>)
+	      (T
+	       <COND (<TYPE? .HAND CHARACTER>
+		      <SET HAND <STRING .HAND>>)>
+	       <COND (<OR <AND <TYPE? .HAND CLASS>
+			       <SET CC .HAND>
+			       <SET CC <CLASS <M$$C-NAME .CC>>>>
+			  <SET CC <CLASS .HAND>>>
+		      <PROG (V)
+		        #DECL ((V) <OR VECTOR FALSE>)
+			<COND (<SET V <MEMQ .CC ,M$$INT-CLASSES:VECTOR>>
+			       <1 .V <>>
+			       <AGAIN>)>>
+		      <GUNASSIGN <LOOKUP <M$$C-NAME .CC> <INTERRUPTS>>>
+		      .CC)>)>>
+
+<DEFINE ON? (HAND)
+	#DECL ((HAND) <OR CLASS HANDLER>)
+	<COND (<TYPE? .HAND CLASS>
+	       <CLASS <M$$C-NAME .HAND>>)
+	      (T
+	       <REPEAT ((H <M$$C-HANDLER <M$$H-CLASS .HAND>>))
+		 #DECL ((H) <OR FALSE HANDLER>)
+		 <COND (<NOT .H> <RETURN <>>)
+		       (<==? .H .HAND> <RETURN T>)
+		       (T <SET H <M$$H-NEXT .H>>)>>)>>
+
+%%<PROG ()
+    <SETG M$$INFINT 19>
+    <SETG M$$CONTINT 35>
+    <SETG M$$PIPEINT 34>
+    <SETG M$$URGINT 33>
+    <SETG M$$IOINT 32>
+    <SETG M$$STKINT 31>
+    <MANIFEST M$$INFINT M$$CONTINT M$$PIPEINT M$$URGINT M$$IOINT M$$STKINT>>
+
+<DEFINE HANDLER (CNAM APP "OPTIONAL" (LEV 0) (ARG <>) "AUX" C)
+	#DECL ((CNAM) <OR STRING CHARACTER> (APP) APPLICABLE
+	       (LEV) FIX (ARG) ANY)
+	<COND (<TYPE? .CNAM CHARACTER>
+	       <PUT ,M$$INT-CLASSES:VECTOR
+		    <SET C <CALL ATIC .CNAM>>
+		    <CLASS <SET CNAM <STRING .CNAM>> <> T .C>>)
+	      (<=? .CNAM "INFERIOR">
+	       <PUT ,M$$INT-CLASSES:VECTOR ,M$$INFINT
+		    <CLASS .CNAM <> T ,M$$INFINT>>)
+	      (T
+	       <IFSYS ("UNIX"
+		       <COND (<=? .CNAM "CONTINUE">
+			      <PUT ,M$$INT-CLASSES:VECTOR ,M$$CONTINT
+				   <CLASS .CNAM <> T ,M$$CONTINT>>)
+			     (<=? .CNAM "PIPE">
+			      <PUT ,M$$INT-CLASSES:VECTOR ,M$$PIPEINT
+				   <CLASS .CNAM <> T ,M$$PIPEINT>>)
+			     (<=? .CNAM "SOCKET">
+			      ; "SIGURG"
+			      <M$$URGINT ,M$$INT-CLASSES:VECTOR
+					 <CLASS .CNAM <> T ,M$$URGINT>>)
+			     (<=? .CNAM "IOINT">
+			      <M$$IOINT ,M$$INT-CLASSES:VECTOR
+					<CLASS .CNAM <> T ,M$$IOINT>>)
+			     (<=? .CNAM "STKINT">
+			      <M$$STKINT ,M$$INT-CLASSES:VECTOR
+					 <CLASS .CNAM <> <> ,M$$STKINT>>)>)>)>
+	<CHTYPE [<CLASS .CNAM <> T> .APP .LEV .ARG <>] HANDLER>>
+
+<DEFINE NI$INTERRUPT II (CNUM "TUPLE" TUP
+		          "AUX" (OLEV ,M$$INT-LEVEL)
+			        C LEV (LV T) (NO-DEFER? <>) TC)
+	 #DECL ((CNUM) <OR FIX CLASS VECTOR> (TUP) TUPLE (C) CLASS
+		(LEV OLEV) FIX
+		(LV) ANY)
+	 <COND (<TYPE? .CNUM FIX>
+		<COND (<SET TC <NTH ,M$$INT-CLASSES:VECTOR .CNUM>>
+		       <SET C .TC>)
+		      (T <RETURN <> .II>)>)
+	       (<TYPE? .CNUM VECTOR>
+		<SET C <CHTYPE .CNUM CLASS>>
+		<SET NO-DEFER? T>)
+	       (T <SET C .CNUM>)>
+	 <COND (<6 .C>
+		<SET NO-DEFER? T>)>
+	 <COND (<M$$C-ENABLE .C>
+		<COND (<L=? <M$$C-PRIORITY .C> .OLEV>
+		       <COND (.NO-DEFER?
+			      <REAL-ERROR
+			       ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT!-ERRORS
+			       .C
+			       INTERRUPT>)
+			     (<N==? .C ,M$$EVALCLASS!-INTERNAL>
+			      ; "Not very useful to queue eval interrupts"
+			      <PROG ((Q ,M$$INT-QUEUE)
+				     (P <M$$C-PRIORITY .C>) TL)
+			        #DECL ((Q) LIST (P) FIX
+				       (TL) <OR FALSE <LIST FIX [2 LIST]>>)
+				; "Maintain a separate queue for each
+				   interrupt level."
+				<COND (<SET TL <MEMQ .P .Q>>
+				       <2 .TL <REST <PUTREST <2 .TL>
+							     ((.C !.TUP))>>>)
+				      (T
+				       <REPEAT ((OL <REST .Q>)
+						(NL (T (.C !.TUP))))
+				         #DECL ((OL) <LIST [REST FIX LIST LIST]>
+						(NL) LIST)
+					 <COND (<OR <EMPTY? .OL> <L? <1 .OL> .P>>
+						<PUTREST .Q
+						  (.P <REST .NL> .NL !.OL)>
+						<RETURN>)
+					       (<==? <1 .OL> .P>
+						<2 .OL
+						   <REST <PUTREST <2 .OL>
+								  ((.C !.TUP))>>>
+						<RETURN>)>
+					 <SET Q <REST .Q 3>>
+					 <SET OL <REST .OL 3>>>)>>)>)
+		      (T
+		       <COND (<==? .C ,M$$EVALCLASS!-INTERNAL>
+			      <COND (<AND <ASSIGNED? GC-RUNNING!- >
+					  .GC-RUNNING!- >
+				     ; "Don't run eval interrupts in GC"
+				     <RETURN <> .II>)>
+			      <M$$C-ENABLE .C <>>)>
+		       <UNWIND
+			<PROG ()
+			  <SET LV <RUN-INTERRUPT .C .OLEV !.TUP>>
+			  <COND (<==? .C ,M$$EVALCLASS!-INTERNAL>
+				 <M$$C-ENABLE .C T>)
+				(<SET LV T>)>
+			  .LV>
+			<PROG ()
+			  <COND (<==? .C ,M$$EVALCLASS!-INTERNAL>
+				 <M$$C-ENABLE .C T>)>>>)>)>>
+
+<DEFINE EMERGENCY (CNAM "TUPLE" TUP "AUX" C)
+	#DECL ((CNAM) STRING (TUP) TUPLE (C) <OR FALSE CLASS>)
+	<COND (<SET C <CLASS .CNAM>>
+	       <I$INTERRUPT <CHTYPE .C VECTOR> !.TUP>)>>
+
+<DEFINE INTERRUPT (CNAM "TUPLE" TUP "AUX" C)
+	#DECL ((CNAM) STRING (TUP) TUPLE (C) <OR FALSE CLASS>)
+	<COND (<SET C <CLASS .CNAM>>
+	       <I$INTERRUPT .C !.TUP>)>>
+
+; "How interrupts are handled:
+I$INTERRUPT compares the priority of the class it's called with to
+M$$INT-LEVEL.  If the interrupt cannot be run immediately, either it is
+queued (from interrupt), or REAL-ERROR is called (from emergency).
+If the interrupt can be run, RUN-INTERRUPT is called.  It raises
+the interrupt level to the class's priority, and wanders down its
+chain of handlers, applying each in turn.  Finally, <INT-LEVEL .OLEV>
+is called, lowering the interrupt level.
+When INT-LEVEL is called to lower the interrupt level, it wanders
+down M$$INT-QUEUE processing (via RUN-INTERRUPT) those queued interrupts
+that can now be handled.  Since RUN-INTERRUPT calls INT-LEVEL, this will
+mostly happen recursively."
+
+<DEFINE RUN-INTERRUPT (C INTENDED-LEVEL "TUPLE" ARGS "AUX" (OLEV ,M$$INT-LEVEL) H
+		       (INT-LEVEL? <>))
+  #DECL ((C) CLASS (OLEV) FIX (INTENDED-LEVEL) <SPECIAL FIX>)
+  <COND (<SET H <M$$C-HANDLER .C>>
+	 <COND (<G? <M$$C-PRIORITY .C> .OLEV>
+		<SET INT-LEVEL? T>
+		<INT-LEVEL <M$$C-PRIORITY .C>>)>
+	 <REPEAT LINT (LV)
+	   #DECL ((LINT) <SPECIAL FRAME>)
+	   <SET LV <APPLY <M$$H-FUNCTION .H>
+			  <M$$H-ARG .H>
+			  !.ARGS>>
+	   <COND (<OR <TYPE? .LV DISMISS> <NOT <SET H <M$$H-NEXT .H>>>>
+		  <COND (.INT-LEVEL? <INT-LEVEL .OLEV>)>
+		  <RETURN <COND (<TYPE? .LV DISMISS> T)(T .LV)>>)>>)>>
+
+<DEFINE INT-LEVEL ("OPTIONAL" LEV "AUX" (OLEV ,M$$INT-LEVEL))
+	#DECL ((LEV OLEV) FIX)
+	<COND (<AND <ASSIGNED? LEV> <L? .LEV .OLEV>>
+	       <REPEAT (MAIN-QUEUE RUN-QUEUE
+			NLEV IL C LEV-QUEUE LEV-RUN-QUEUE)
+		       #DECL ((RUN-QUEUE) <LIST [REST FIX LIST LIST]>
+			      (IL) <LIST CLASS>
+			      (C) CLASS (NLEV) FIX (MAIN-QUEUE) LIST)
+		       <SET MAIN-QUEUE ,M$$INT-QUEUE>
+		       <SET RUN-QUEUE <REST .MAIN-QUEUE>>
+		       <COND (<EMPTY? .RUN-QUEUE> <RETURN>)>
+		       <COND (<G=? .LEV <1 .RUN-QUEUE>>
+			      ; "No interrupts with enough priority"
+			      <RETURN>)>
+		       <SET LEV-QUEUE <3 .RUN-QUEUE>>
+		       <SET LEV-RUN-QUEUE <REST .LEV-QUEUE>>
+		       <COND (<EMPTY? .LEV-RUN-QUEUE>
+			      ; "No more queued interrupts at this level"
+			      <PUTREST .MAIN-QUEUE <REST .RUN-QUEUE 3>>
+			      ; "Try it again"
+			      <AGAIN>)>
+		       <SET C <1 <SET IL <1 .LEV-RUN-QUEUE>>>>
+		       <COND (<==? <2 .RUN-QUEUE> .LEV-RUN-QUEUE>
+			      ; "Running last thing on this queue, so 
+				 make sure pointer doesn't get dropped"
+			      <2 .RUN-QUEUE <3 .RUN-QUEUE>>)>
+		       ; "Splice this interrupt out"
+		       <PUTREST .LEV-QUEUE <REST .LEV-RUN-QUEUE>>
+		       <RUN-INTERRUPT .C .LEV !<REST .IL>>>
+	       <SETG M$$INT-LEVEL .LEV>)
+	      (<ASSIGNED? LEV>
+	       <SETG M$$INT-LEVEL .LEV>)>
+	.OLEV>
+			      
+<DEFINE DISMISS (VAL "OPTIONAL" ACT LEV)
+	#DECL ((VAL) ANY (ACT) FRAME (LEV) FIX)
+	<COND (<ASSIGNED? LEV>
+	       <INT-LEVEL .LEV>)
+	      (<ASSIGNED? INTENDED-LEVEL>
+	       <INT-LEVEL .INTENDED-LEVEL>)>
+	<COND (<NOT <ASSIGNED? ACT>>
+	       <COND (<NOT <ASSIGNED? LINT>>
+		      <RETURN .VAL .LPROG!-INTERRUPTS>)
+		     (<SET ACT .LINT>)>)>
+	<RETURN .VAL .ACT>>
+		      
+<DEFINE QUITTER (ARG)
+	<INT-LEVEL 0>
+	<RESET ,OUTCHAN>
+	<ERROR CONTROL-G!-ERRORS>>
+
+<DEFINE STOPPER (ARG)
+	<INT-LEVEL 0>
+	<RESET ,OUTCHAN>
+	<AGAIN .LERR!-INTERRUPTS>>
+
+<DEFINE STACK-OVERFLOW (ARG "AUX" VAL)
+	<IFSYS
+	 ("UNIX"
+	  <INT-LEVEL 0>
+	  <RESET ,OUTCHAN>
+	  <COND (<1? <CHTYPE <CALL BIGSTACK 0> FIX>>
+		 ; "Will return 1 if stack is already big"
+		 <REAL-ERROR STACK-AT-LIMIT!-ERRORS
+			     INTERRUPT-HANDLER 
+			     ERRET-T-TO-FATAL!-ERRORS>)
+		(<SET VAL <REAL-ERROR STACK-OVERFLOW!-ERRORS 
+				      INTERRUPT-HANDLER
+				      ERRET-T-TO-CONTINUE!-ERRORS>>
+		 ; "Say let stack become big"
+		 <CALL BIGSTACK 1>)>)>
+	T>
+
+<DEFINE INTON ("AUX" NM)
+	<NEWTYPE CLASS VECTOR>
+	<NEWTYPE HANDLER VECTOR>
+	<CALL SETS ICALL 'I$INTERRUPT>
+	<SETG M$$INT-QUEUE (T)>
+	<SETG M$$INT-QUEUE-R ,M$$INT-QUEUE>
+	<SETG M$$INT-LEVEL 0>
+	<SETG M$$INT-CLASSES
+	      [<> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <>
+	       <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <>]>
+	<SETG M$$EVALCLASS!-INTERNAL <M$$H-CLASS <HANDLER "EVAL" ,TIME 1>>>
+	<DISABLE "EVAL">
+	<COND (<SET NM <LOOKUP <STRING <ASCII 7>> <INTERRUPTS>>>
+	       <GUNASSIGN .NM>
+	       <REMOVE .NM>)>
+	<COND (<SET NM <LOOKUP <STRING <ASCII 1>> <INTERRUPTS>>>
+	       <GUNASSIGN .NM>
+	       <REMOVE .NM>)>
+	<CLASS <STRING <ASCII 7>> 6 T>
+	<CLASS <STRING <ASCII 1>> 5 T>
+	<IFSYS ("UNIX"
+		<CLASS "STKINT" 1000 T ,M$$STKINT T>
+		<ON <HANDLER "STKINT" ,STACK-OVERFLOW>>)>
+	<ON <HANDLER <ASCII 7> ,QUITTER>>
+	<ON <HANDLER <ASCII 1> ,STOPPER>>
+	T>
+
+<DEFINE PRINT-HANDLER (HAND "AUX" (OUTCHAN .OUTCHAN))
+  #DECL ((HAND) HANDLER (OUTCHAN) CHANNEL)
+  <PRINC "#HANDLER [" .OUTCHAN>
+  <PRINC <M$$C-NAME <M$$H-CLASS .HAND>> .OUTCHAN>
+  <COND (<NOT <ON? <M$$H-CLASS .HAND>>>
+	 <PRINC ":OFF" .OUTCHAN>)>
+  <PRINC !\  .OUTCHAN>
+  <COND (<NOT <ON? .HAND>>
+	 <PRINC "OFF " .OUTCHAN>)>
+  <PRINC <M$$H-PRIORITY .HAND> .OUTCHAN>
+  <PRINC !\  .OUTCHAN>
+  <PRINC <M$$H-ARG .HAND> .OUTCHAN>
+  <PRINC !\  .OUTCHAN>
+  <PRINC <M$$H-FUNCTION .OUTCHAN> .OUTCHAN>
+  <PRINC !\] .OUTCHAN>>
+
+<DEFINE PRINT-CLASS (CLASS "AUX" (OUTCHAN .OUTCHAN))
+  #DECL ((CLASS) CLASS (OUTCHAN) CHANNEL)
+  <PRINC "#CLASS [" .OUTCHAN>
+  <PRINC <M$$C-NAME .CLASS> .OUTCHAN>
+  <PRINC !\  .OUTCHAN>
+  <COND (<NOT <ON? .CLASS>>
+	 <PRINC "OFF " .OUTCHAN>)>
+  <COND (<NOT <M$$C-ENABLE .CLASS>>
+	 <PRINC "DISABLED " .OUTCHAN>)>
+  <COND (<M$$C-HANDLER .CLASS>
+	 <PRINC "#HANDLER [&] " .OUTCHAN>)
+	(<PRINC "<> " .OUTCHAN>)>
+  <PRINC <M$$C-CHANNEL .CLASS> .OUTCHAN>
+  <PRINC !\  .OUTCHAN>
+  <PRINC <M$$C-PRIORITY .CLASS> .OUTCHAN>
+  <PRINC !\] .OUTCHAN>>
+
+<COND (<GASSIGNED? PRINT-HANDLER>
+       <PRINTTYPE HANDLER ,PRINT-HANDLER>
+       <PRINTTYPE CLASS ,PRINT-CLASS>)>
+
+<ENDPACKAGE>