perm filename NWORLD[S,AIL]34 blob sn#675734 filedate 1982-09-07 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00042 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00004 00002	HISTORY
C00009 00003	 MANY DECLARATIONS
C00015 00004	PROCESS VARIABLE NUMBERS
C00018 00005	event variables
C00019 00006	procedure descriptors & null process skeleton
C00021 00007	DSCR SPROUT -- THE PROCESS SPROUTER
C00028 00008
C00035 00009
C00036 00010	routines for inserting & deleting set elements
C00040 00011	USER REQUESTED SCHEDULING
C00045 00012	HERE(RESUME)
C00051 00013	SUSPEND and TERMINATE runtime routines
C00054 00014	The JOIN runtime routine
C00057 00015	THE MAIN PROCESS INITIALIZER
C00059 00016	CALLER , MYPROC, AND PSTATUS 
C00061 00017	 PRISET -- ROUTINE USER CALLS TO CHANGE PRIORITY 
C00062 00018	SPECIAL GC ROUTINE FOR PROCESSES
C00063 00019	INTERRUPT ROUTINES
C00067 00020	
C00068 00021	THE INTERRUPT PROCESS
C00071 00022
C00072 00023	 CAUSE 
C00074 00024	CAUSE1 -- ROUTINE TO DO ACTUAL WORK 
C00077 00025	ANSWER -- subroutine used by CAUSE
C00079 00026	DELWRQ -- delete all wait requests
C00081 00027	INTERROGATE
C00083 00028	ASK -- used by INTERROGATE
C00086 00029	MKEVTT,SETCP,& SETIP
C00088 00030	SPARE HERE TABLE ENTRIES
C00089 00031	COMPIL(IRP,,,,,,DUMMYFORGDSCISS)
C00091 00032	HERE(INTTBL)
C00093 00033	PROCEDURES TO ENABLE FOR INTERRUPTS
C00105 00034	HERE(IRPSP1)
C00106 00035
C00107 00036	HERE(INTTBL)
C00110 00037	DSCR
C00115 00038	HERE(PSIDISMS)
C00117 00039	HERE(PSIRUNTM)
C00121 00040	HERE(KPSITIME)
C00122 00041
C00123 00042
C00124 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000026  ⊗;


COMMENT ⊗
VERSION 17-1(22) 2-13-75 BY RHT FIX THE FILE SO SCISS WILL WORK AGAIN
VERSION 17-1(21) 2-1-75 BY RLS TENEX
VERSION 17-1(20) 2-1-75 BY RLS INSTALL TENEX PSI SYSTEM
VERSION 17-1(20) 11-12-74 BY RHT FEAT %BX% MAKE SETPRI WORK FIFO
VERSION 17-1(19) 6-6-74 BY RHT MAKE KACTS USE ALLPDP
VERSION 17-1(18) 5-23-74 BY RHT BUG #SC# DOCUMENTATION BUG FIXED BY CODE CHANGE TO INTPRO
VERSION 17-1(17) 5-23-74 
VERSION 17-1(16) 1-18-74 BY RHT BUG #QK# INSERTING AN ELEMENT IN A LIST W/O TABL SET UP FOR GLOBAL HACK
VERSION 17-1(15) 1-8-74 BY RHT FINISH %BE% HACK
VERSION 17-1(14) 1-8-74 BY RHT FEAT %BE% GLOBAL EVENTS OF A SORT
VERSION 17-1(13) 1-8-74 
VERSION 17-1(12) 12-8-73 BY JRL  REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(11) 12-8-73 BY RHT FIX IEXT5 SCREW FOR EXPO WORLD
VERSION 17-1(10) 12-8-73 BY RHT CHANGE PLACE WHERE REMEMBER THE APRENB BITS
VERSION 17-1(9) 12-4-73 BY rht fix process string garb coll routine
VERSION 17-1(8) 12-3-73 BY RHT MAKE SUSPEND(OTHERGUY) RETURN ANY
VERSION 17-1(7) 12-2-73 BY RHT ADD A FEW IRP SPARES
VERSION 17-1(6) 10-30-73 BY RHT BUG #OU# A TYPO IN %AA%
VERSION 17-1(5) 10-30-73 BY RHT BUG #OT# SPROUT APPLY BUG
VERSION 17-1(4) 10-28-73 BY RHT FEAT %AG% INITIALIZE RSMR←DADDY WHEN SPROUT
VERSION 17-1(27) 10-14-73 BY RHT BUG #OO# SPROUT APPLY TROUBLES
VERSION 17-1(26) 9-1-73 BY RHT FEATURE %AA% -- ADD CODE FOR SPROUT DEFAULTS
VERSION 17-1(25) 8-19-73 BY RHT FIX COMPIL FOR SAIIRP TO KNOW ABOUT APRACS
VERSION 17-1(24) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(23) 7-15-73 BY RHT BUG #NC# ASKNTC WAS WRONG
VERSION 16-2(22) 7-15-73 BY RHT MORE OF BUG NB
VERSION 16-2(21) 7-15-73 BY RHT BUG #NB# NOT GETTING CONTXT RIGHT FOR USER IP
VERSION 16-2(20) 7-14-73 BY RHT MAKE SAIIRP A SEP COMPIL & PROVIDE FOR APPL$Y
VERSION 16-2(19) 7-14-73 BY RHT BUG #NA# RACE CONDITION IN URSCHD IWAIT
VERSION 16-2(18) 3-18-73 BY RHT MINOR MOD TO DFR1IN
VERSION 16-2(17) 2-4-73 BY RHT PROVIDE MORE HOOKS INTO EVENT ROUTINES
VERSION 16-2(16) 1-15-73 BY DCS BUG #LB# MINOR RESUME BUG
VERSION 16-2(15) 12-9-72 BY RHT MAKE MINOR ADJUSTMENTS TO RESUME
VERSION 16-2(14) 12-4-72 BY RHT INTERNAL PSTATUS
VERSION 16-2(13) 12-4-72 BY RHT  CURE POTENTIAL LOSSAGE OF STATIC LINKAGE
VERSION 16-2(12) 12-2-72 BY RHT REWRITE RESUME
VERSION 16-2(11) 12-1-72 BY RHT PROVIDE FOR DEFAULTS AS CORE VARS
VERSION 16-2(10) 11-30-72 BY RHT ADD THE DDFINT ROUTINE & ZAP POLL
VERSION 16-2(9) 11-29-72 BY DCS ADD INTERRUPT THINGS TO ENTRIES IN COMPIL
VERSION 16-2(8) 11-29-72 BY RHT RESUME DISPATCH NEEDS @
VERSION 16-2(7) 11-26-72 BY DCS ALLOW <ESC>I AS IO INTERRUPT (AVOID "NO ONE TO RUN")
VERSION 16-2(6) 11-26-72 BY DCS CHANGE OPDEF FOR INTENS TO 400030 FROM ..31
VERSION 16-2(5) 11-25-72 BY RHT FIX DATAB & INFTAB REFERENCES
VERSION 16-2(4) 11-15-72 BY RHT ADD OPTIONS FOR RESUME
VERSION 16-2(3) 11-15-72 BY RHT ADD INTERRUPTS,SPARE HERE ENTRIES
VERSION 16-2(2) 11-15-72 
VERSION 16-2(1) 11-15-72 

⊗;
; MANY DECLARATIONS
COMPIL(PRC,,,,,,DUMMYFORGDSCISS)
DEFINE ENS1 < SPROUT,URSCHD,RESUME,SUSPEND,TERMINATE,JOIN,MAINPR,CALLER>
DEFINE ENS2 <%PSSGC,DDFINT,INTSET,CAUSE,ANSWER,INTERROGATE,SETCP>
DEFINE ENS3 <MKEVTT,SETIP,MYPROC,CLKMOD,DFR1IN,DFRINT,INTPRO>
DEFINE ENS4 <DFCPKT,PSTATUS,ASKNTC,CAUSE1,PRISET>
DEFINE EXT1 <LEAP,STKUWD,X44,GOGTAB,%ARSR1,SGINS,ALLPDP>
DEFINE EXT2 <CORGET,CORREL,INTRPT,INFTB,%SPGC,X22,%SPGC1,FP1DON,STACSV>
DEFINE EXT3 <X33,%ARRSR,DATM,SGLKBK,FP2DON,SGREM,STACRS,RUNNER,NOPOLL>
NOTYMSHR <
DEFINE EXT4 <X11,DEFSSS,DEFPSS,DEFPRI,DEFQNT,INTTBL,APPL$Y>>;NOTMSHR
TYMSHR <
DEFINE EXT4 <DDFINA,X11,DEFSSS,DEFPSS,DEFPRI,DEFQNT,INTTBL,APPL$Y>>;TYMSHR

IFN APRISW <
DEFINE XJBCNI <JOBCNI>
DEFINE XJBTPC <JOBTPC>
DEFINE XJBAPR <JOBAPR>
DEFINE EXT5 <JOBCNI,JOBTPC,JOBAPR>
IFN ALWAYS <
EXTERN EXT5	;THESE ARE ALWAYS EXTERNAL
>;IFN ALWAYS
>;IFN APRISW
IFE APRISW <
DEFINE EXT5 <XJBCNI,XJBTPC,XJBAPR,JOBINT>
IFN ALWAYS <
EXTERNAL JOBINT ;THIS FELLOW IS ALWAYS EXTERNAL
>;IFN ALWAYS
>;IFE APRISW
COMMENT ⊗THIS IS FOR THE STUPIDITY OF SCISS ⊗

COMPXX(PRC,<ENS1,ENS2,ENS3,ENS4>,<EXT1,EXT2,EXT3,EXT4,EXT5>
	,<MULTIPLE PROCESS STUFF>,<SPRPDA>,HIIFPOSSIB)



BEGIN PROCSS

; (AC DEFNS)

; A,B,C,P,SP,RF AS BEFORE
KL	←D	;KILL LIST & SCRATCH
PB	←5	;PROCESS BASE
OPTS	←6	;HOLDS OPTIONS
PDA	←7	;HOLDS PDA
EVT	←10	;EVENT DATUM
NSP	←←10	;NEW SP
NP	←11	;NEW P
TMP	←LPSA	;TEMP AC

GLOB < 
TABL ←← 7	;NEEDED BY LIST CELL GETTER
>;GLOB
NOGLOB <
TABL ←← USER	;NEEDED BY LIST CELL GETTER
>;NOGLOB
FP ←← 6		;NEEDED BY LIST CELL GETTER

; (LOCAL VARIABLES FOR SCHEDULER)
MAXPRI ←← 0	;MAXIMUM PRIORITY
MINPRI ←← NPRIS-1

;REASONS FOR SUSPENSION
PSPF←←0		;ONLY P, SP, F NEED BE RESTORED
SPNDR←←1	;SUSPENDED (FROM READY) BY SUSPEND
JOINR←←2	;SUSPENDED BECAUSE OF A JOIN
WAITNG←←3	;WAITING ON AN EVENT OR SO

; ( CONSTANT DATA USED BY SPROUTER)

; FIELD DEFNS FOR OPTIONS WORD (SEE ALSO POINT S BELOW)

STSMSK←	77 ⊗ =8	;MASK FOR P STACK SIZE FIELD
SSSMSK←	17 ⊗ =14;MASK FOR SP STACK SIZE FIELD OF OPTIONS WORD
PRIMSK←	17 ⊗ 4	;MASK FOR PRIORITY FIELD
QNTMSK←← 17	;MASK FOR QUANTUM
RUNME←←	1	;RUN THE SPROUTING PROCESS
SPNDME←←2	;SUSPEND THE SPROUTING PROCESS
SPNDNP←←10	;SUSPEND THE NEW PROCESS

;MORE FIELD DEFS & BIT VALUES
TERM  ←← 1	;BIT (LH) IN DATUM OF TERMINATED PROCESS ITEM

;DEFAULT VALUES --INITIALLY SET BY MAINPR

STPSZ←	40	;DEFAULT P- STACK SIZE (MINUS THE PROCESS TABLE AREA)
STSPST ←20	;DEFAULT SP STACK SIZE
STDQNT ←← 4	;DEFAULT STD QUANTUM IS 4
STDPRI	←←7	;DEFAULT PRIORITY

;OPTIONS FOR RESUME
MSTMSK←←14	;MASK FOR MY NEW STATUS FIELD
NOTNOW←←1	;SET IF RESUMED PROCESS IS MERELY TO GO READY

;CONSTANTS USED BY RESUME
MSTBYT:	POINT	2,OPTS,33 ;MY NEW STATUS

; (CONSTANTS USED BY SPROUTER)
SSSBYT:	POINT	4,OPTS,21	;STRING STACK FIELD (MOD 32)
STSBYT:	POINT	6,OPTS,27	;P - STACK FIELD (MOD 32)
PRIBYT:	POINT	4,OPTS,31	;PRIORITY FIELD
QNTBYT:	POINT	4,OPTS,17	;LOG2 (QUANTUM)


; MACROS USED TO GET LIST CELLS
DEFINE NCELL(AC) <
	MOVE	FP,FP1(TABL)	;USE WHERE SURE THE LIST SPACE IS INITIALIZED
	HRRI	AC,(FP)
	SKIPN	FP,(FP)
	PUSHJ	P,FP1DON
	HRRM	FP,FP1(TABL)
>

DEFINE NNCELL(AC) <
	SKIPN	FP,FP1(TABL)	;USE WHERE LIST SPACE MAY NEED INITIALIZATION
	PUSHJ	P,FP1DON
	HRRI	AC,(FP)
	SKIPN	FP,(FP)
	PUSHJ	P,FP1DON
	HRRM	FP,FP1(TABL)
>

DEFINE NNCLL2(AC) <
	SKIPN	FP,FP2(TABL)	;USE WHERE LIST SPACE MAY NEED INITIALIZATION
	PUSHJ	P,FP2DON
	HRRI	AC,(FP)
	SKIPN	FP,(FP)
	PUSHJ	P,FP2DON
	HRRM	FP,FP2(TABL)
>

NOTENX<
OPDEF INTENS [CALLI 400030]
OPDEF IWAIT [CALLI 400040]
>;NOTENX
;PROCESS VARIABLE NUMBERS

DEFINE PVAR (V,ATTRIB),
	<↑V ←← NPVARS
	NPVARS←← NPVARS+1
IFE ALWAYS,<
	IFDIF <ATTRIB>,<> < ATTRIB V >
>;IFE ALWAYS
	>


NPVARS←← 0

	PVAR	DYNL	;DYNAMIC LINK
	PVAR	STATL	;STATIC LINK
	PVAR	ISP	;REST OF MSCP
	PVAR	AC0	;AC SAVE AREA
	PVAR	AC1
	PVAR	AC2
	PVAR	AC3
	PVAR	AC4
	PVAR	AC5
	PVAR	AC6
	PVAR	AC7
	PVAR	AC10
	PVAR	AC11
	PVAR	AC12
	PVAR	AC13
	PVAR	AC14
	PVAR	AC15
	PVAR	AC16
	PVAR	AC17
INTERNAL ACF
↑ACF ←← AC12
↑ACP ←← AC17
↑ACSP ←← AC16
	PVAR	PCW	;PC WORD
	PVAR	QUANTM	;TIME QUANTUM
	PVAR	PRIOR	;PRIORITY
	PVAR	PRCITM	;PROCESS ITEM OF THIS PROCESS
	PVAR	KLOWNR	;THE OWNER OF MY KILL LIST
	PVAR 	STATUS	;-1 = RUNNING, 0 = SUSPEND, 1 = READY, 2 = TERMINATED
	PVAR	DADDY,INTERNAL	;PROCESS ITEM OF SPROUTING PROCESS
	PVAR	CAUSRA	;RETN ADDRESS FROM CAUSE
;THE FOLLOWING ARE ZEROED OUT ON CREATION
ZFIRST←←NPVARS
	PVAR	CURSCB,INTERNAL	;CURRENT SEARCH CONTROL BLOCK
	PVAR	REASON	;HOW GOT UNSCHEDULED (0 MEANS ONLY NEED ACS F,SP,P)
	PVAR	PLISTE,INTERNAL	;PRIORITY LIST ENTRY
	PVAR	RSMR	;THE GUY WHO RESUMED ME (%AG% ** INIT TO DADDY ** )
	PVAR	JOINCT	;HOW MANY PROCESSES NEED TO JOIN THIS ONE
	PVAR	JOINS	;WHO IS WAITING TO FOR ME TO JOIN (A SET OF ITEMS)
	PVAR	WAITES	;LIST OF ALL EVENT TYPES ON WHICH I AM WAITING
	PVAR	INTRGC	;THE CONTROL WORD FOR MY CURENT INTERROGATION
	PVAR	CAUSES	;COUNT OF CAUSES PENDING
	PVAR	CAUSEQ	;QUEUE OF CAUSES TO BE MADE
ZLAST←←NPVARS-1

↑NPVARS ← NPVARS
↑STKBAS ← NPVARS	;STACK BASE SIZE (= #PROCESS VARS FOR NOW)
COMMENT ⊗event variables⊗

NEVARS←←0

DEFINE EVAR(V) ,
	<↑↑V←←NEVARS
	NEVARS←←NEVARS+1
	>

	EVAR	NOTCLS		;LIST OF CURRENT NOTICES
	EVAR	WAITLS		;LIST OF CURRENTLY WAITING PROCESSES
	EVAR	CAUSEP		;USER SPEC CAUSE PROC
	EVAR	INTRGP		;USER SPEC INTERROGATE PROC
	EVAR	USER1		;AVAIL TO USER
	EVAR	USER2		;AVAIL TO USERR

;OPTIONS BITS FOR CAUSE
DNTSAV ←← 1
TELLAL ←← 2
SCHDIT ←← 4

;OPTIONS BITS FOR INTERROGATE
RETAIN ←← 1
WAIT   ←← 2
SAYWCH ←← 10
MULTIN ←← 200000
NOJOY  ←← 400000

COMMENT ⊗procedure descriptors & null process skeleton⊗

FLXXX←←0
NOTENX<
UP <
FLXXX←←%FIRLOC-400000
>;UP
>;NOTENX
TENX<
UP <
FLXXX←←%FIRLOC-(SEGPAGE*1000)
>;UP
>;TENX

DEFINE PUTINLOC(LCN,V),< 
UP <
	SVPCXX ←← .
	DEPHASE
>;UP
	RELOC LCN+FLXXX
	V
	RELOC
UP <
	PHASE SVPCXX
>;UP
>

;MAKE A PD FOR THE SPROUTER
↑SPRPDA:
;;#WV# used to be BLOCK PD.XXX+1
REPEAT PD.XXX+1, <0
>

DEFINE FPDE(IX,V),<PUTINLOC (SPRPDA+IX,V)>

	FPDE	(PD.,SPROUT)
	FPDE	(PD.ID1,6)
	FPDE	(PD.ID2,<<POINT 7,[ASCII/SPROUT/]>>)
	FPDE	(PD.DSW,STKBAS)
	FPDE	(PD.PDA,<<XWD SPRPDA,0>>)
	FPDE	(PD.LLW,<SPRPDA+PD.XXX>)
	FPDE	(PD.DLW,<SPRPDA+PD.XXX>)


IFN 0,<

;NULL PROCESS
NULPDA:	NULPRO			;PD OF NUL PROC
↑NULPRC: %NULPR			;NULL PROCESS

%NULPR:	BLOCK STKBAS+=32	;NULL PROCESS AREA

DEFINE NPE (IX,V), <PUTINLOC (%NULPR+IX,V)>

	NPE	(STATL,<<XWD SPRPDA,0>>)
	NPE	(ACF,STKBAS+%NULPR+1)
	NPE	(ACP,<<TPDL: XWD - =29,%NULPR+STKBAS+3>>)
	NPE	(STKBAS+1,%NULPR+DYNL)
	NPE	(STKBAS+2,<<XWD NULPDA,0>>)



↑NULPRO:
	ERR	<I SHOULD NEVER RUN>
>;IFN 0







DSCR SPROUT -- THE PROCESS SPROUTER
CAL 	PUSHJ
PARM	-1(P)	;KILL LIST
	-2(P)	;OPTIONS WORD
	-3(P)	;PDA OF SPROUTED PROCESS
	-4(P)	; PROCEDURE PARAMS
	:
	-?(P)	;LAST OF PROCEDURRE PARAMS
	-?-1(P)	;PROCESS ITEM
DES 
	This procedure acts as the "process" procedure.
Roughly, it does the following:

1. Saves the return address in PCW(RUNNER)
2. gets stack space
3. puts self on appropriate kill list & priority list
4. copies over the procedure parameters.
5. sets status of new & SPROUTing process
	&(eventually) calls the appropriate procedure.
6. when the procedure returns, SPROUT then kills the process.

⊗
HERE (SPROUT)
	MOVE	USER,RUNNER	;
	POP	P,PCW(USER)	;RETN ADDRESS
	POP	P,KL		;PICK UP KILLL LIST
	POP	P,OPTS		;OPTIONS
	POP	P,PDA		;FIND OUT WHO
;;%AA% -- 1 OF 1  DEFAULTS, ALSO THE POP P,PDA USED TO BE LATER
	CAIN 	PDA,APPL$Y	;SPROUT APPLY IS A ROYAL PAIN
;;#OU# A TYPO RHT
	SKIPA	TMP,-1(P)	;REAL PDA FOR SPROUT APPLY
	MOVE	TMP,PDA		;
	HRRZ	A,PD.PDB(TMP)	;THE DEFAULTS
	JUMPE	A,SALCS		;NO DEFAULTS -- SPROUT ALLOCATIONS NOW
	LSH	A,4		;INTO POSITION
	TRNE	OPTS,STSMSK	;P STACK
	TRZ	A,STSMSK
	TRNE	OPTS,SSSMSK	;SP STACK
	TRZ	A,SSSMSK
	TRNE	OPTS,PRIMSK	;PRIORITY
	TRZ	A,PRIMSK
	TLNE	OPTS,QNTMSK	;QUANTUM
	TLZ	A,QNTMSK	;
	IOR	OPTS,A		;OR IN THE BITS FOR DEFAULTS
SALCS:
;;%AA%

	TRNE	OPTS,SSSMSK	;SPECIFIED SP STACK SIZE ?
	JRST	[ LDB C,SSSBYT	;YES, GET IT
		LSH   C,5	;TIMES 32
		JRST  .+2 ]
	MOVE	C,DEFSSS	;STANDARD SIZE
	PUSHJ	P,CORGET	;GET SPACE
	ERR	<SPROUT: No core>
	MOVN	C,C		;MAKE PDP
	HRLZI	NSP,-1(C)	
	HRRI	NSP,-1(B)
	TRNE	OPTS,STSMSK	;P - STACK
	JRST	[ LDB C,STSBYT	;YES, GET IT
		LSH	C,5	;TIMES 32
		JRST	.+2]
	MOVE	C,DEFPSS	;STANDARD AMOUNT TO GET
	ADDI	C,STKBAS	;SPACE FOR BASE
	PUSHJ	P,CORGET	;GET ROOM
	ERR	<SPROUT: No core>
	MOVE	PB,B		;PROCESS BASE
	MOVN	C,C
	HRLZI	NP,STKBAS(C)	;MAKE PDP
	HRRI	NP,STKBAS(PB)

;ZERO OUT SOME OF THE PROCESS VARS
	HRLZI	A,ZFIRST(PB)	;
	HRRI	A,ZFIRST+1(PB)
	SETZM	ZFIRST(PB)
	BLT	A,ZLAST(PB)

;REMEMBER DADDY
	MOVE	USER,RUNNER
	MOVE	A,PRCITM(USER)
	MOVEM	A,DADDY(PB)
;;%AG% ! REMEMBER SPROUTER AS THE FIRST CALLER. RHT
	MOVEM	A,RSMR(PB)	;SO CALLER(MYPROC) STARTS OUT AS DADDY

;BUILD MSCP, ETC.

	SETZM	DYNL(PB)	;NULL DYN LINK
	CAIN	PDA,APPL$Y	;IS IT A SPROUT APPLY?
	JRST	[		;YES
UP <
		MOVE	PDA,(PDA) ;SINCE APPL$Y IS HERED
>;UP
		POP	P,TMP	;ARG LIST
		POP	P,A	;PDA OF TARGET
		PUSH	NP,A	;PUT ON CALL STACK
		PUSH	NP,TMP	;PUT ON CALL STACK
;;#OO# !(1 OF 2) A TYPO
		HRLZI	TMP,SPRPDA
		HLRZ	C,PD.DLW(A) ;LOOK FOR RIGHT LINK
;;#OT# ! RHT DONT LOOK IF THE FELLOW SUPPLIES AN ENVIRONMENT
		TLNN	A,-1	;ENVIRON SUPPLIED??
		CAIG	C,1	;GLOBAL??
		JRST	SSLON	;YES
		HRRZ	A,PD.PPD(A);
		SKIPA	TMP,RF
	SSLFLP:	HLRZ	TMP,C
		MOVS	C,1(TMP)
		CAIE	A,(C)
		JRST	SSLFLP
;;#OO# ! (2 OF 2) NEED TO SAY A SPROUT
		HRLI	TMP,SPRPDA
	SSLON:	MOVEM	TMP,STATL(PB)
		MOVEM	NSP,ISP(PB)
		JRST	APSON	]
	HLRZ	A,PD.DLW(PDA)	;DISPLAY LEVEL
	HRLZI	TMP,SPRPDA	;IN CASE OUTER LEVEL
	CAIG	A,1		;OUTER BLOCK PROC?
	JRST	SLON		;YES -- NO LOOP
	HRRZ	A,PD.PPD(PDA)	;THE LEXICAL PARENT
	SKIPA	TMP,RF		;DYNL
SLFLP:	HLRZ	TMP,C		;BACK A STATL
	MOVS	C,1(TMP)	;SL,,PDA
	CAIE	A,(C)		;SAME AS DADDY?
	JRST	SLFLP		;NO
	HRLI	TMP,SPRPDA	;SPRPDA,,STATL
SLON:	MOVEM	TMP,STATL(PB)	;STATIC LINK WORD
	MOVEM	NSP,ISP(PB)	;SP WORD

;COPY PROC PARAMS

	HLRZ	TMP,PD.NPW(PDA)	;#STRING PARAMS*2
	JUMPE	TMP,STPSON	;HAVE ANY ?
	HRL	TMP,TMP		;YES, DO A BLT
	HRRZI	A,1(NSP)	;DEST
	ADD	NSP,TMP		;BUMP NEW STACK
	JUMPL	NSP,.+2
	 ERR	<SPROUT: SP PDLOV>
	SUB	SP,TMP		;DECREMENT OLD STACK
	HRLI	A,1(SP)		;SOURCE
	BLT	A,(NSP)		;COPY THEM
STPSON:	HRRZ	TMP,PD.NPW(PDA)	;# ARITH PARMS +1
	SOJLE	TMP,APSON	;ANY TO BLT ?
	HRL	TMP,TMP		;MAKE XWD
	HRRZI	A,1(NP)		;DEST
	ADD	NP,TMP
	JUMPL	NP,.+2
	 ERR	<SPROUT: P PDLOV>
	SUB	P,TMP
	HRLI	A,1(P)
	BLT	A,(NP)		;DO IT
APSON:


;NOW  SET UP NEW PROCESS'S STATUS, QUANTUM, & PRIORITY

	SETOM	STATUS(PB)		;ASSUME RUNNING
	TRNE	OPTS,SPNDNP		;UNLESS SUSPEND
	SETZM	STATUS(PB)		;0 MEANS SUSPENDED
	MOVE	TMP,DEFQNT		;STANDARD QUANTUM
	TLNN	OPTS,QNTMSK		;GET LOG2 QUANTUM
	JRST	SVQNT			;NO NEED
	LDB	A,QNTBYT
	MOVEI	TMP,1
	LSH	TMP,(A)
SVQNT:	MOVEM	TMP,QUANTM(PB)
	MOVE 	A,DEFPRI		;ASSUME STD PRIORITY
	TRNE	OPTS,PRIMSK		;SAID OTHERWISE?
	LDB	A,PRIBYT
	PUSHJ	P,SETPRI		;GO SET PRIORITY

;SET UP PROCESS ITEM

	POP	P,C			;PICK UP ITEM #
	JUMPN	C,.+2
	 ERR	<SPROUT: Illegal process item >,7
	MOVEM	C,PRCITM(PB)		;REMEMBER IT
	MOVEI	A,PRCTYP		;SAY IS OF TYPE PROCESS

COMMENT **** MAY WANT TO WORRY HERE ABOUT GLOBAL ITEMS **** ;

	MOVE	TABL,GOGTAB
	DPB	A,INFOTAB(TABL)		;SAY IS A PROCESS
	HRRZM	PB,@DATAB(TABL)		;SET DATUM VALUE

;KILL SET STUFF
	MOVE	B,C			;ITEM NUMBER
	MOVEM	KL,KLOWNR(PB)		;REMEMBER KILL LIST OWNER
	JUMPE	KL,NEWSTT		;ONLY PUT ON KILL SET IF HAVE ONE
	PUSH	P,TABL			;NEED TO SAVE THESE
	PUSH	P,FP			;
	PUSHJ	P,INSRTS		;GO PUT ITEM IN KILL SET
	POP	P,FP
	POP	P,TABL

;NOW DECIDE WHAT TO DO WITH SPROUTING PROCESS & DO THE RIGHT THING

NEWSTT:	MOVE 	USER,RUNNER		;HOPE IT IS STILL HIM
	TRNE	OPTS,RUNME		; DOES SPROUTING PROCESS WANT TO RUN?
	JRST	RNSPRR			;YES
	MOVEM	P,ACP(USER)		;IF HERE, THEN WANT TO RUN NEW GUY
	MOVEM	SP,ACSP(USER)		;SAVE THE NECESSARY ACS
	MOVEM	RF,ACF(USER)		;
	MOVNS	STATUS(USER)		;RUNNING BECOMES READY
	TRNE	OPTS,SPNDME		;IF I WANTED SUSPENSION
	SETZM	STATUS(USER)		;DO IT
	SKIPL	STATUS(PB)		;DOES SPROUTED PROCESS WANT TO RUN
	JRST	NORFR			;NO
	MOVE	USER,GOGTAB
	MOVE	A,QUANTM(PB)
	MOVEM	A,TIMER(USER)
	MOVE	P,NP			;
	MOVE	SP,NSP			;GET READY
	MOVEI	RF,DYNL(PB)		;
	MOVEM	PB,RUNNER
CALLIT:	PUSHJ	P,@PD.(PDA)		;CALL THE SO AND SO

;HERE IS WHERE WE COME ON PROCEDURE EXIT
CALRET:	MOVE	PB,RUNNER		;I HOPE ITS ME
;;%  % ! RHT MAY AS WELL USA ALLPDP FOR KACTS TOO
	MOVE	P,ALLPDP		;USE THIS PDL FOR KILLING CORE
	PUSHJ	P,KACTS			;DO EVERYTHING BUT SPACE FREEING

;NOW KILL CORE FOR SP STACK

	HRRZ	B,ISP(PB)
	ADDI	B,1
	PUSHJ	P,CORREL

;NOW KILL CORE FOR P-STACK

	HRRZI	B,(PB)
	PUSHJ	P,CORREL

;NOW ALL TRACES ARE GONE (I HOPE)

	JRST	FOTR			;GO FIND SOMETHING TO DO

;PROCEDURE THAT PERFORMS ALL KILL ACTIONS EXCEPT STACK RELEASING
;EXPECTS PB TO POINT AT THE CONDEMNED PROCESS
;USES A,B,C,KL

KACTS:	HRRZ	C,PRCITM(PB)
	MOVE	B,C			;
	MOVE	TABL,GOGTAB		;
	TLO	PB,TERM			;SET TERM BIT
	MOVEM	PB,@DATAB(TABL)		;TERMINATED
	SKIPE	KL,KLOWNR(PB)		;IF HAVE A KILL SET
	PUSHJ	P,DELTSE		;DELETE FROM SET

;NOW  CHECK TO SEE IF WE WERE ON ANY JOIN LISTS

	SKIPN	A,JOINS(PB)
	JRST	REMPRI
	MOVE	KL,GOGTAB	;
KACT.1:	HLRZ	C,(A)		;THE ITEM
	MOVE	B,@DATAB(TABL)	;GET ADDRESS OF THE DATUM
	TLNE	B,TERM		;DEAD ALREADY??
	JRST	KACT.2		;YES
	SOSLE	JOINCT(B)	;READY TO ROLL ??
	JRST	KACT.2		;NO
	SKIPN	STATUS(B)	;CURRENT STATUS
	AOS	STATUS(B)	;READY
KACT.2:	HRRZ	B,(A)
	HRR	C,FP1(KL)	;RELEASE LIST CELL
	HRRM	C,(A)	
	HRRM	A,FP1(KL)	;NEW FREE LIST
	JUMPE	B,REMPRI	;END OF LIST
	MOVE	A,B		;
	JRST 	KACT.1



;NOW TAKE OFF PRIORITY LIST AND RETURN
;NOTE -- THE CODE FROM HERE TO THE POPJ IS ITSELF A PROCEDURE USED
;ELSEWHERE TO REMOVE PROCESS (PB) FROM ITS PRIORITY LIST
;SIDE EFFECTS -- USES A,B,C 

REMPRI:	MOVE	A,PRIOR(PB)
	ADD	A,GOGTAB
	HRRZ	B,PLISTE(PB)
	HLRZ	C,PLISTE(PB)
	JUMPN	C,.+3
	HRRM	B,PRILIS(A)		;HEAD OF LIST
	JRST	.+2
	HRRM	B,PLISTE(C)		;NEXT(C)←B
	JUMPN	B,.+3
	HRLM	C,PRILIS(A)		;NEW TAIL
	POPJ	P,
	HRLM	C,PLISTE(B)		;PREV(B)←C
	POPJ	P,

;PROCEDURE TO PUT PROCESS (PB) ON PRIORITY LIST A
;SIDE EFFECT -- MODIFIES B
SETPRI:	MOVEM	A,PRIOR(PB)		;REMEMBER MY PRIORITY
	ADD	A,GOGTAB
;;%BX%  RHT make this work fifo
;	SKIPE	B,PRILIS(A)		;PRIORITY LIST OWNER
;	HRLM	PB,PLISTE(B)		;LINK BACK
;	HRRZM	B,PLISTE(PB)		;LIINK DOWM
;	HRRM	PB,PRILIS(A)		;NEW RHS FOR OWNER IS PTR TO  ME
;	TLNN	B,-1			;WAS THE LIST EMPTY ??
;	HRLM	PB,PRILIS(A)		;YES -- THIS IS THE TAIL TOO

	HLRZ	B,PRILIS(A)		;OLD LAST ELEMENT
	JUMPN	B,OLDLST		;HAVE ONE
	SETZM	PLISTE(PB)		;DONT HAVE ONE, BOTH LINKS ARE NULL
	HRRZM	PB,PRILIS(A)		;NEW FIRST ELEMENT SINCE WAS EMPTY
	JRST	SETP.X			;GO FINISH OUT
OLDLST:	HRRM	PB,PLISTE(B)		;LINK ONTO END OF LIST
	HRLZM	B,PLISTE(PB)
SETP.X:	HRLM	PB,PRILIS(A)		;MAKE NEW LAST ELEMENT
;;%BX% ↑

CPOPJ:	POPJ	P,



;HERE IF DONT WANT TO RUN NEW GUY RIGHT AWAY
NORFR:	TROA	B,1			;FLAG
RNSPRR:	MOVEI	B,0
	MOVNS	STATUS(PB)		;IF NEW IS "RUNNING", THEN "READY"
	PUSH	NP,[CALRET]		;
	MOVEM	NP,ACP(PB)		;SET UP NEC. SAVES
	MOVEM	NSP,ACSP(PB)
	MOVEI	A,DYNL(PB)		
	MOVEM	A,ACF(PB)
	MOVE	A,PD.(PDA)		;WHERE HE STARTS
	MOVEM	A,PCW(PB)
	CAIN	B,			;SPROUTER RUNS??
	JRST	@PCW(USER)		;YES -- 
	JRST	FOTR			;NO -- FIND SOMEONE TO RUN

COMMENT ⊗routines for inserting & deleting set elements⊗

;expects item no in B , (KL) = the owner
;mangles A,B,C,FP,TABL

INSRTS:	MOVE	TABL,GOGTAB
	SKIPN	A,(KL)		;GET OWNER
	JRST	NEWINS		;IT WAS NULL BEFORE
	MOVE	C,(A)		;POINT AT FIRST
ISCH:	MOVS	C,(C)		;CONTENTS (SWAPPED) OF THIS
	CAILE	B,(C)		;ELIGIBLE
	JRST	NX1		;MUST GO FURTHER
	CAIL	B,(C)		;THERE ALREADY?
	POPJ	P,		;YES
NI:	HRL	B,(A)		;POINTER AT THIS
	NCELL	(C)		;GET A CELL FOR IT
	MOVSM	B,(C)		;SAVE CONTENTS OF CELL
	HRRM	C,(A)		;LINK TO NEW
	HRLZI	A,1
	ADDB	A,(KL)		;UPDATE COUNT -- POINT AT LAST,,FIRST
	TLNN	B,-1		;AT THE END???
	HRLM	C,(A)		;YES
	POPJ	P,
NX1:	HRRZ	A,(A)
	TLNN	C,-1		;END OF LIST
	JRST	NI		;YES -- PUT AT END
	MOVSS	C
	JRST	ISCH		;GO LOOK SOME MORE
NEWINS:	NNCELL	(A)
	SETZM	(A)
	HRRZM	A,(KL)		;IT USED TO BE NULL
	JRST	NI

;ROUTINES FOR ADDING TO LISTS
;EXPECT ITEM NO IN B, KL= ADRS OF OWNER
;MANGLE A,B,C,FP,TABL
;;#QK# RHT ! SET UP OF TABL NEEDED
IHEDLS:	MOVE	TABL,GOGTAB
	SKIPN	A,(KL)		;INSERT AT HEAD
	JRST	NEWINS
	JRST	NI		
ITAILS:	
;;#QK# ! SET UP TABL (2 OF 2)
	MOVE	TABL,GOGTAB	;
	SKIPN	A,(KL)		;INSERT AT TAIL
	JRST	NEWINS
	MOVS	A,(A)
	JRST	NI


;ROUTINE TO DELETE SET OR LIST ELEMENTS
;B = ITEM NO, (KL) IS THE OWNER
;MANGLES A,B,C,TABL

DELTLE:
DELTSE:	SKIPN	A,(KL)		;GET SET DESCRIPTOR
	POPJ	P,		;NULL ALREADY
	MOVE	C,(A)
DSCH:	MOVE	C,(C)
	TLC	C,(B)
	TLNN	C,-1		;WAS IT THIS ONE???
	JRST	DIT		;YES
	TRNN	C,-1		;END OF SEARCH
	POPJ	P,		;YES
	MOVE	A,(A)		;LINK
	JRST	DSCH		;GO LOOK
DIT:	MOVE	TABL,GOGTAB
	MOVE	B,(A)		;B PTR TO THIS CELL
	HRRM	C,(A)		;LINK PREV TO NEXT
	HRL	C,FP1(TABL)	;OLD FREE LIST
	HLRM	C,(B)		;LINK CELL
	HRRM	B,FP1(TABL)	;
	HRLZI	B,-1		;ADJUST DESCRIPTOR
	ADDB	B,(KL)
	TLNE	B,-1		;LIST NULL NOW???
	JRST	CKEND		;NO
	SETZM	(KL)		;YES
	MOVSS	(B)		;LAST,,FIRST CELL 
				;NOW IS 0,,PTR TO CELL JUST FREED UP
	HRRM	B,FP1(TABL)	;NEW FREE LIST
	POPJ	P,
CKEND:	TRNN	C,-1		;WAS THIS THE END
	HRLM	A,(B)		;YES
	POPJ	P,


;ROUTINE TO DELETE FIRST ELT OF A LIST
;PUTS ITEM # INTO A
;EXPECTS (KL) = THE OWNER
;MODIFIES A,B,C,TABL

REMCAR:	SKIPN	A,(KL)
	POPJ	P,		;IF WAS NULL RETURN A 0
	MOVE	C,(A)
	MOVE	C,(C)		;FIRST REAL LIST CELL
	HLRZ	B,C		;FIRST ONE
	PUSH	P,B		;SAVE IT
	PUSHJ	P,DIT
	POP	P,A		;VALUE
	POPJ	P,





;USER REQUESTED SCHEDULING


HERE(URSCHD)
	MOVE	PB,RUNNER
	SKIPL	STATUS(PB)		;
	JRST 	FOTR			;GO FIND ONE TO RUN
	MOVNS	STATUS(PB)		;SET TO READY
SPSRN1:	SETZM	REASON(PB)		;OTHER ACS NOT SAVED
SPSRN2:	POP	P,PCW(PB)		;DITTO -- BUT LEAVE REASON INTACT
					;THESE TWO LABELS ARE USED
					;BY SUSPEND, JOIN & THE LIKE
	MOVEM	P,ACP(PB)
	MOVEM	SP,ACSP(PB)
	MOVEM	RF,ACF(PB)		
FOTR:	HRRZ	B,GOGTAB
	TLO	B,-NPRIS
	MOVEI	A,1			;READY
SCHLIS:	SKIPN	PB,PRILIS(B)		;SEARCH DOWN THIS LIST
	JRST	NXLIS			;LIST IS EMPTY
TRYTHS:	CAMN	A,STATUS(PB)		;IS THIS READY
	JRST	SCDTHS			;YES -- DO HIM
	HRRZ	PB,PLISTE(PB)		;LINK DOWN LIST
	JUMPN	PB,TRYTHS		;IF ANY LEFT AT THIS LEVEL,TRY
NXLIS:	AOBJN	B,SCHLIS		;SEARCH LIST
	
NOTENX<
IFE APRISW <
;;#NA#  RACE CONDITION ON WHEN INTERRUPT HAPPENS
	IMSKCL	1,[-1]			;MASK OFF ALL INTERRUPTS
	SKIPE	INTRPT			; A RECENT INTERRUPT
	JRST	[INGOSC: SETZM INTRPT	;GO TRY AGAIN TO SCCHEDULE
			IMSKST 1,[-1]
			JRST	FOTR ]
	INTENS	B,			;GET INTERRUPT ENABLING
	TLNN	B,775204		;IS HE ENABLED FOR SOMETHING
					;THAT CAN STILL HAPPEN
	ERR <NO ONE TO RUN>,1,INGOSC	;NO
	IMSTW	[-1			;WAIT FOR AN INTERRUPT
		1]
	SETZM	INTRPT			;ZERO THE FLAG
;;#NA# -- EVENTUALLY FIX THIS CROCK
>;IFE APRISW
IFN APRISW <
	SKIPN	INTRPT
	ERR <NO ONE TO RUN>,1
	SETZM	INTRPT
>;IFN APRISW
>;NOTENX
TENX<
	SKIPN	INTRPT
	  ERR <NO ONE TO RUN>,1
	SETZM	INTRPT
>;TENX
	JRST	FOTR			;FIND SOMEONE TO RUN

SCDTHS:	
;CIRCLE THE QUEUE
	SKIPE	A,PLISTE(PB)		;ONLY ONE ON THE LIST?
	TRNN	A,-1			;ALREADY AT END?
	JRST	RDYTHS			;YES
	HLLM	A,PLISTE(A)		;PREV(NEXT(ME))←PREV(ME)
	MOVS	C,A			;NEXT(ME),,PREV(ME)
	TRNE	C,-1			;ANY PREV?
	HLRM	C,PLISTE(C)		;YES -- NEXT(PREV(ME))←NEXT(ME)
	TLNE	A,-1			;WAS I FIRST?
	HRR	A,PRILIS(B)		;NO -- FIRST WILL STAY FIRST
	HRL	A,PB			;NEW OWNER -- ME,,NEW FIRST
	EXCH	A,PRILIS(B)		;GET OLD LAST,,FIRST
	HLLZM	A,PLISTE(PB)		;MY NEW ENTRY IS OLD LAST,,0
	MOVS	A,A			;    XXX,,OLD LAST
	HRRM	PB,PLISTE(A)		;POINT AT ME


RDYTHS:	SETOM 	STATUS(PB)		;RUNNING
	HRRM 	PB,RUNNER		;SAY SO
	MOVE	USER,GOGTAB
	MOVE	A,QUANTM(PB)
	MOVEM	A,TIMER(USER)
	SKIPE	A,REASON(PB)
	JRST	@SPCASE(A)		;SOME SPECIAL CASE
RPSPF:	MOVE	P,ACP(PB)		;GET THE NEEDED REGISTERS
	MOVE	SP,ACSP(PB)
	MOVE	RF,ACF(PB)
	JRST	@PCW(PB)		;GO START RUNNING THE SO AND SO


SPCASE:	RPSPF				;0 THEN RESTORE P, SP, F
	RSTACS				;1 THEN RESTORE ALL ACS
	RPSPF				;2 THEN FROM JOINER
	RST1				;3 THEN FROM INTERROGATE

RSTACS:	MOVE	P,ACP(PB)		;PUT THE RETURN ADDRESS ON THE STACK
	PUSH	P,PCW(PB)
	MOVEM	P,ACP(PB)
	HRLZI	P,AC0(PB)
	BLT	P,P			;RESTORE THE OLD ACS
	POPJ	P,			;GO RUN


RST1:	MOVE	A,AC1(PB)		;RESTORE REG 1 , SP,P,F
	JRST	RPSPF

HERE(RESUME)
	MOVE	USER,RUNNER	;TAKE CARE OF RET ADDRS
	POP	P,PCW(USER)
	POP	P,OPTS		;OPTIONS
	POP	P,A		;RETURN VALUE
	POP	P,C		;WHO
	MOVE	TEMP,GOGTAB	;
	LDB	B,INFOTAB(TEMP)	;TEST THE TYPE
	CAIE	B,PRCTYP	;IS THE TYPE A PROCESS
	 JRST	[	MOVEI	LPSA,ER.NPI
		RESERR:	MOVSI	TEMP,[ASCIZ/RESUME/]
			PUSH	P,PCW(USER)	;ENTRY CONVENTION OF ER.ITN
			JRST	(LPSA)]
	MOVE	PB,@DATAB(TEMP)	;GET THE DATUM
	TLNE	PB,TERM		;WAS IT TERMINATED?
	 JRST	[MOVEI	LPSA,ER.TRP
		JRST	RESERR]
	MOVE	B,PRCITM(USER)	;MY NAME
	MOVEM	B,RSMR(PB)	;REMEMBER CALLER
	SKIPE	STATUS(PB)	;HIS STATUS BETTER BE 0
	 JRST	[MOVEI	LPSA,ER.SUS
		JRST	RESERR]
	JUMPN	OPTS,NS.RSM	;NONSTANDARD IF JUMP
	SETZM	STATUS(USER)
RSM.H:	SETOM	STATUS(PB)
	MOVEM	P,ACP(USER)	;SAVE NEEDFUL REGISTERS
	MOVEM	RF,ACF(USER)
	MOVEM	SP,ACSP(USER)
	SETZM	REASON(USER)	;ONTL P, SP, F IMPORTANT
	MOVEM	PB,RUNNER	;
	MOVE	C,REASON(PB)	;
	JRST	@SPCASE(C)	;GO FIRE HIM UP


NS.RSM:	TRNN	OPTS,MSTMSK	;FUNNYNESS IN MY NEW STATUS?
	JRST	RSM.4		;NO -- IT MUST BE NOTNOW
	LDB	D,MSTBYT	;GET INDEX
	JRST	@[ RSM.1	;I GO READY
		  RSM.3		;I DIE
		  RSM.4		;I WANT TO KEEP RUNNING
		]-1(D)		;SELECT

RSM.1:	TRNN	OPTS,NOTNOW	;HE RUNS?
	JRST	RSM.2		;YES
	AOS	STATUS(PB)	;MAKE HIM READY
	MOVE	B,REASON(PB)	;WERE ALL REGISTERS SAVED
	CAIN	B,1		;
	JRST	RSM.01		;YES
	MOVEM	A,AC1(PB)	;
	MOVEI	A,3
	MOVEM	A,REASON(PB)	;A IS IMPORTANT
RSM.01:	PUSH	P,PCW(USER)	;RET AD
	JRST	URSCHD		;RESCHEDULE



RSM.2:	MOVNS	STATUS(USER)	;
	JRST	RSM.H		;GO GET HIM GOING



RSM.3:	MOVE	B,REASON(PB)	;
	CAIN	B,1		;ALL ACS SAVED?
	JRST	RSM.3X		;YES
	MOVEM	A,AC1(PB)	;SAVE A
	MOVEI	A,3		;
	MOVEM	A,REASON(PB)	;
RSM.3X:	TRNE	OPTS,NOTNOW	;HE RUNS?
	JRST	RSM.03		;YES
	AOS	STATUS(PB)	;NO - I CAN COMMIT SUICIDE
	MOVE	PB,USER		;
	JRST	TERMPB		; I DIE
RSM.03:	MOVE	B,ACP(PB)	;
	MOVEI	C,RSM.T		;
	EXCH	C,PCW(PB)	;FIRST HE WILL KILL ME
	PUSH 	B,C		;
	PUSH	B,PB		;
	MOVEM	B,ACP(PB)	;THE TERMPB POPJ WILL CONTINUE HIM
	JRST	RSM.H		;GO FIRE THE DEAR BOY UP

RSM.4:	AOS	STATUS(PB)	;GET HIM READY
	MOVE	B,REASON(PB)	;SHOULD WE SAVE 1
;;#XL# ! JFR 8-17-76 WAS CAIE; C.F. RSM.3 ABOVE
	CAIN	B,1		;
	JRST	@PCW(USER)	;I GO ON MY WAY
	MOVEM	A,AC1(PB)	;SAVE IT
	MOVEI	A,3		;
	MOVEM	A,REASON(PB)	;
;;#LB#! 1-15-73 DCS WAS @PCW(PB), THAT'S WRONG ("TYPO")
	JRST	@PCW(USER)	;

RSM.T:	MOVE	PB,(P)		;
	PUSHJ	P,TERMPB	;
	MOVE	PB,1(P)		;TERMPB BACKED UP THE STACK
	POP	P,PCW(PB)	;RET AD
	MOVE	C,REASON(PB)	;
	JRST	@SPCASE(C)	;GO DO RIGHT THING ABOUT ACS

ER.SUS:	HRRI	TEMP,[ASCIZ/Non-suspended process/]
	JRST	ER.ITN
ER.TRP:	TROA	TEMP,[ASCIZ/Terminated process/]
ER.NPI:	HRRI	TEMP,[ASCIZ/Non-process item/]
ER.ITN:
		;ENTER WITH (P)=RETURN WORD, TEMP=[ASCIZ/routine/],,[ASCIZ/msg/]
		;C=ITEM NUMBER
	MOVE	LPSA,RUNNER	;STORE STATE
	POP	P,PCW(LPSA)	;RETURN WORD
	MOVEM	P,ACP(LPSA)
	MOVEM	SP,ACSP(LPSA)
	MOVEM	RF,ACF(LPSA)
	MOVEI	LPSA,(C)	;ITEM NUMBER (ERRSPL USES FF THRU D)
	ERRSPL	1,[[ASCIZ/
@A: @A #@D/]
		PLEFT	TEMP	;routine
		PRIGHT	TEMP	;msg
		PRIGHT	LPSA]	;item number
	MOVE	PB,RUNNER	;TRY TO IGNORE THE CALL THAT GAVE THE ERROR
	SETZ	A,		;RETURN 0 (=ANY) IF IT MATTERS
	JRST	RPSPF		;RESTORE P, SP, F AND CONTINUE
COMMENT ⊗SUSPEND and TERMINATE runtime routines⊗
HERE(SUSPEND)
	MOVE	C,-1(P)		;THE ITEM
	POP	P,-1(P)		;BACK UP RETN ADDR
	MOVSI	TEMP,[ASCIZ/SUSPEND/]
	MOVE	TABL,GOGTAB	;
	LDB	B,INFOTAB(TABL)
	CAIE	B,PRCTYP	;BE SURE A PROCESS ITEM
	 JRST	ER.NPI
	MOVE	PB,@DATAB(TABL)
        TLNE	PB,TERM		;IF TERMINATED , 
	 JRST	ER.TRP
	CAME	PB,RUNNER	;IS IT THE RUNNER
	JRST	OTHGUY		;NO
	SETZM	STATUS(PB)
	JRST	SPSRN1		;GO RESCHEDULE
OTHGUY:	MOVEI	A,SPNDR		;HE MUST HAVE BEEN READY
	SKIPE	STATUS(PB)	;IF HE WASNT SUSPENDED
	MOVEM	A,REASON(PB)	;THE REGISTERS MUST BE RESTORED
	SETZM	STATUS(PB)	;BE SURE
	MOVEI	A,ITMANY	;GET THE ITEM ANY
	POPJ	P,

HERE(TERMINATE)
	MOVE	C,-1(P)
	MOVE	TABL,GOGTAB	;
	LDB	B,INFOTAB(TABL)	;IS HE A PROCESS
	CAIE	B,PRCTYP
	 JRST	[	MOVSI	TEMP,[ASCIZ/TERMINATE/]
		NPIPOP:	POP	P,-1(P)	;MOVE RETURN WORD BACK
			JRST	ER.NPI]
	MOVE	PB,@DATAB(TABL)	;POINT AT PROCESS
	TLNE	PB,TERM		;ALREADY DEAD
	JRST	RET1		;YES
↑TERMPB:
	MOVE	USER,RUNNER	;COME HERE IF PB LOADED
	CAMN	PB,USER		;IS IT ME THAT IS TO DIE?
	JRST	KILLIT		;YES
	PUSH	P,PRIOR(USER)	;I AM ABOUT TO GET HIGH PRIORITY
	PUSHJ	P,REMPRI
	MOVEI	A,MAXPRI	;
	PUSHJ	P,SETPRI
	MOVEI	A,FIXPRI
	MOVEM	A,PCW(USER)
	MOVEM	P,ACP(USER)
	MOVEM	RF,ACF(USER)
	MOVEM	SP,ACSP(USER)
	MOVE	RF,ACF(PB)
	MOVE	P,ACP(PB)
	MOVE	SP,ACSP(PB)
	MOVEI	A,1		;NOW FIX STATUS
	MOVEM	A,STATUS(USER)	;
	MOVNM	A,STATUS(PB)
	MOVEM	PB,RUNNER	;THE NEW RUNNER
KILLIT:	MOVEI	LPSA,SPRPDA	;THE SPROUTER IS WHERE WE GO BACK TO
	PUSHJ	P,STKUWD	;UNWIND THE STACK
	JRST	CALRET		;GO DIE 

;IF LIVED THROUGH THE DESTRUCTION, WILL COME HERE
FIXPRI:	PUSHJ	P,REMPRI
	POP	P,A		;REAL PRIORITY
	PUSHJ	P,SETPRI
RET1:	SUB	P,[XWD 2,2]	;GET OFF THE PARAMETER
	JRST	@2(P)		;RETURN

COMMENT ⊗The JOIN runtime routine⊗

DSCR JOIN
CAL  PUSH P,SET
     PUSHJ P,JOIN
DES  CAUSES YOUR PROCESS TO WAIT FOR THE TERMINATION OF ANY
PROCESSES NAMED IN ITS ARGUMENT SET
⊗

HERE(JOIN)
;#ZM# 78-12-12 DON/KS -- USE OF LEAP 117&120 ADDED TO AVOID ACCUMULATION OF SETS
	HRROI	14,-1(P)	;POINTER TO THE SET
	MOVEI	5,117		;117=SETCOP (NOTE LEAP'S AC5 IS OUR PB)
	PUSHJ	P,LEAP		;COPY THE SET IF NOT TEMP
	MOVE	PB,RUNNER	;WHO AM US AHYHOW?
	SKIPN	B,-1(P)		;GET SET POINTER AGAIN (PERHAPS CHANGED BY LEAP)
	JRST	[PUSHJ P,JNREL	;NULL SET IS EASY, RELEASE IT
		POPJ P,]	;AND WE'RE DONE
	MOVE	TABL,GOGTAB	;GET READY FOR CELL GETTING
	HRRZ	A,(B)		;A NOW POINTS AT FIRST
	HRLZ	D,PRCITM(PB)	;THE PROCESS ITEM OF THE JOIN

;NOW LOOP ALONG SET, GIVING WARNINGS

JNST:	HLRZ	C,(A)		;THE ITEM NUMBER
	LDB	B,INFOTAB(TABL)	;GET TYPE
	CAIE	B,PRCTYP	;PROCESS?
	 JRST	[MOVSI	TEMP,[ASCIZ/JOIN/]
		PUSHJ	P,JNREL
		JRST	ER.NPI]
	MOVE	B,@DATAB(TABL)	;GET DATUM
	TLNE	B,TERM		;DEAD ???
	JRST	NXTJNR		;YES
	AOS	JOINCT(PB)	;ONE MORE TO DIE
	NNCELL	(C)		;GET (POSSIBLY FIRST) NEW CELL
	HRR	D,JOINS(B)	;LINK TO OLD JOIN LIST
	MOVEM	D,(C)		;NEW CONTENTS OF THIS CELL
	HRRZM	C,JOINS(B)	;NEW JOIN LIST
NXTJNR:	HRRZ	A,(A)		;GET NEXT ENTRY
	JUMPN	A,JNST
	PUSHJ	P,JNREL		;DONE WITH THE SET
	SKIPG	JOINCT(PB)	;DO WE NEED TO WAIT?
	POPJ	P,		;NO
	MOVEI	A,JOINR		;REASON IS A JOIN
	MOVEM	A,REASON(PB)	;
	SETZM	STATUS(PB)	;I AM SUSPENDED
	JRST	SPSRN2		;GO SAVE P,RF,SP & RUN SOMEONE
				;(BUT DONT CHANGE REASON)

JNREL:	HRROI	14,-2(P)	;GET SET POINTER AGAIN (-2(P) DUE TO OUR RET ADDR)
	MOVEI	5,120		;120=SETRCL
	PUSH	P,C		;ER.NPI MAY WANT THIS (GAD WHAT A CROCK!)
	PUSHJ	P,LEAP		;RELEASE THE SET
	POP	P,C
	POP	P,B		;SAVE OUR RETURN ADDR
	POP	P,-1(P)		;CLEAN UP STACK
	MOVE	PB,RUNNER	;REMEMBER AC5, USED BY LEAP, IS PB
	JRST	(B)		;ANOTHER GOOD DAY'S WORK DONE
COMMENT ⊗THE MAIN PROCESS INITIALIZER⊗

HERE(MAINPR)
	MOVE	USER,GOGTAB
	SKIPE	GGDAD(USER)	;INITIALIZED ALREADY
	POPJ	P,		;YES
	MOVEI	C,NPVARS+40	;HOW MUCH SPACE WE NEED
	PUSHJ	P,CORGET
	ERR	<NO ROOM FOR THE MAIN PROCESS>
	HRRZ	PB,B		;PROCESS BASE
	MOVE	A,SPDL(USER)	;STRING PDL
	MOVEM	A,ISP(PB)
	SETOM	DYNL(PB)
	HLROI	A,SPRPDA
	MOVEM	A,STATL(PB)
	MOVEM	PB,GGDAD(USER)
	MOVEM	PB,RUNNER	;SAY THIS IS THE RUNNER
	HRLZI	A,ZFIRST(PB)
	HRRI	A,ZFIRST+1(PB)
	SETZM	ZFIRST(PB)
	BLT	A,ZLAST(PB)

	MOVEI	C,MAINPI	;THE MAIN PROCESS ITEM NUMBER
	MOVEI	A,PRCTYP	;MAKE A PROCESS
	DPB	A,INFOTAB(USER)
	HRRZM	PB,@DATAB(USER)
	MOVEM	C,PRCITM(PB)

	SETZM	KLOWNR(PB)	;NASTY
	SETOM	STATUS(PB)	;I AM THE RUNNER
	MOVEI	A,STPSZ		;SET DEFAULTS
	MOVEM	A,DEFPSS	;P STACK
	MOVEI	A,STSPST	;
	MOVEM	A,DEFSSS	;SP STACK
	MOVEI	A,STDQNT	;
	MOVEM	A,DEFQNT	;QUANTUM
	MOVEM	A,QUANTM(PB)	;
	MOVEI	A,STDPRI	;STANDARD PRIORITY
	MOVEM	A,DEFPRI	;PRIORITY
	PUSHJ	P,SETPRI	;SET THE PRIORITY
	PUSH	P,[%SPGC]
	PUSHJ	P,SGREM
	PUSH	P,[%ARRSRT]
	PUSHJ	P,SGREM
	PUSH	P,[%PSSGC]
	PUSH	P,[SGLKBK+1]
	PUSHJ	P,SGINS

	POPJ	P,


COMMENT ⊗CALLER , MYPROC, AND PSTATUS ⊗

HERE(CALLER)
	JSP	TEMP,PDG
	 JRST	[MOVSI	TEMP,[ASCIZ/CALLER/]
		JRST	NPIPOP]
	TLNE	A,TERM
	 JRST	[	MOVSI	TEMP,[ASCIZ/CALLER/]
		TRPPOP:	POP	P,-1(P)	;BACK UP RETURN WORD
			JRST	ER.TRP]
	MOVE	A,RSMR(A)
C.XIT1:	EXCH	C,-1(P)
C.XIT:	SUB	P,X22
	JRST	@2(P)

HERE(MYPROC)
	MOVE	USER,RUNNER
	MOVE	A,PRCITM(USER)
	POPJ	P,

HERE(PSTATUS)
	JSP	TEMP,PDG
	 JRST	[MOVSI	TEMP,[ASCIZ/PSTATUS/]
		JRST	NPIPOP]
	TLNN	A,TERM
	SKIPA	A,STATUS(A)
	MOVEI	A,2
	JRST	C.XIT1


;PDG -- GETS PROC ITEM IN -1(P) INTO C , CHECKS TYPE, & PUTS DATUM INTO A
;CALLED BY JSP TEMP,PDG
;SIDE EFFECTS: USES USER, PUTS OLD VALUE OF C INTO -1(P), SKIP RETURNS IF
;THE ITEM WAS OK. OTHERWISE RETURNS WITH A= WHATEVER TYPE ITEM IN C IS

PDG:	EXCH	C,-1(P)		;ITEM NUMBER
	MOVE	USER,GOGTAB
	LDB	A,INFOTAB(USER)
	CAIE	A,PRCTYP
	JRST	(TEMP)		;WAS NOT A PROC ITEM
	MOVE	A,@DATAB(USER)
	JRST	1(TEMP)		;RETURN

COMMENT ⊗ PRISET -- ROUTINE USER CALLS TO CHANGE PRIORITY ⊗

HERE(PRISET)
	MOVE	C,-2(P)		;ITEM
	MOVE	TABL,GOGTAB	;
	LDB	A,INFOTAB(TABL)
	CAIE	A,PRCTYP
	 JRST	[	MOVEI	LPSA,NPIPOP
		PRIERR:	MOVSI	TEMP,[ASCIZ/PRISET/]
			POP	P,-1(P)
			JRST	(LPSA)]
	MOVE	PB,@DATAB(TABL)	;GET DATUM
	TLNE	PB,TERM
	 JRST	[MOVEI	LPSA,TRPPOP
		JRST	PRIERR]
	PUSHJ	P,REMPRI	;TAKE OFF MY LIST
	MOVE	A,-1(P)
	CAIG	A,17		;CHECK BOUNDS
	CAIGE	A,0
	 JRST	[MOVEI	LPSA,ER.IPR
		JRST	PRIERR]
	PUSHJ	P,SETPRI
RET.3:	SUB	P,X33
	JRST	@3(P)

ER.IPR:	HRRI	TEMP,[ASCIZ/Illegal priority/]
	POP	P,-1(P)
	POP	P,-1(P)
	JRST	ER.ITN
COMMENT ⊗SPECIAL GC ROUTINE FOR PROCESSES⊗


HERE(%PSSGC)
	MOVE	TEMP,RUNNER
	MOVEM	SP,ACSP(TEMP)
;; dont get it from here (assume was ok)
;	MOVE	RF,RACS+RF(USER)
	MOVEM	RF,ACF(TEMP)
	HRLZI	B,-NPRIS
	HRR	B,GOGTAB
SCHL1:	SKIPN	TEMP,PRILIS(B)
	JRST	NXLS
	PUSH	P,B
SCHL2:	MOVE	RF,ACF(TEMP)
	PUSH	P,TEMP
	PUSHJ	P,%ARSR1
	MOVE	TEMP,(P)
	HRRZ	A,ISP(TEMP)
	MOVE	SP,ACSP(TEMP)
	PUSHJ	P,%SPGC1
	POP	P,TEMP
	HRRZ	TEMP,PLISTE(TEMP)
	JUMPN	TEMP,SCHL2
	POP	P,B
NXLS:	AOBJN	B,SCHL1
	MOVE	TEMP,RUNNER
;; now get rf for this process back (also sp)
	MOVE	RF,ACF(TEMP)
	MOVE	SP,ACSP(TEMP)
	POPJ	P,






COMMENT ⊗INTERRUPT ROUTINES⊗


HERE(DDFINT)			;DO DEFERRED INTERRUPT
	SKIPE	NOPOLL		;IGNORING IT?
	POPJ	P,		;YES
	SETZM	INTRPT		;
	MOVE	USER,RUNNER	;NEED TO SAVE ACS
	POP	P,PCW(USER)	;SAVE PC WORD
	MOVNS	STATUS(USER)	;READY
	MOVEI	TEMP,AC0(USER)	;
	BLT	TEMP,ACP(USER)	;
	MOVEI	A,1		;NEED ALL ACS
	MOVEM	A,REASON(USER)	;
	JRST	FOTR		;SEE WHOM TO RUN

HERE(INTSET)

;CALL IS  INTSET(ITEM,SPROUT OPTS)
;ORS IN THE STATUS OPTIONS FOR SPNDNP+RUNME
;TURNS OFF THE OPTION FOR SPNDME
	MOVE	USER,GOGTAB	;
	SKIPE	DISPAT(USER)	;HAVE TABLES???
	JRST	.+3		;YES
	PUSH	P,[=128]	;DEFAULT BUFFER SIZE
	PUSHJ	P,INTTBL	;GO GET EM
	PUSH	P,-2(P)		;ITEM
	PUSH	P,[INTPDA]	;INTERRUPT PROCEDURE
;;#YM# ! was -2(P) typo WFW/JFR 1-21-77
	MOVE	A,-3(P)		;GET OPTIONS
	TRZ	A,SPNDME	;SET UP STATUS FIELD
	TRO	A,SPNDNP+RUNME	;
	PUSH	P,A		;
	PUSH	P,[0]		;NO KILL SET
	PUSHJ	P,SPROUT	;SPROUT IT

	MOVE	C,-2(P)		;THE ITEM
	MOVE	A,@DATM
	MOVE	USER,GOGTAB
	MOVEM	A,INTPRC(USER)	;REMEMBER INTERRUPT PROCESS BASE
	MOVE	A,-1(P)		;
	TRNE	A,PRIMSK	;DID HE SPEC A PRIORITY
	JRST	POK

	PUSH	P,C		;ITEM
	PUSH	P,[0]
	PUSHJ	P,PRISET	;SET THE PRIORITY
POK:
	SUB	P,X33
	JRST	@3(P)




HERE(CLKMOD)
	MOVE	USER,GOGTAB	;
	SOSG	TIMER(USER)	;IF COUNTDOWN COMPLETE THEN
	SETOM	INTRPT		;SIGNAL THE INTERRUPT
	POPJ	P,		;LET CALLER DISMIS

DEFINE QW(VALAC,WPAC,RPTR,WTOP,WBOT,OVINST) <
	MOVEM	VALAC,(WPAC)
	ADDI	WPAC,1
	CAMLE	WPAC,WTOP
	MOVE	WPAC,WBOT
	CAMN	WPAC,RPTR
	OVINST
	>

DEFINE QR(VALAC,WPTR,RPAC,WTOP,WBOT,OVINST) <
	CAMN	RPAC,WPTR
	OVINST
	MOVE	VALAC,(RPAC)
	ADDI	RPAC,1
	CAMLE	RPAC,WTOP
	MOVE	RPAC,WBOT
	>

DEFINE IQW(VAC) <
	QW(VAC,11,<INTQRP(USER)>,<INTQWT(USER)>,<INTQWB(USER)>,< JRST IQWOV >)
	>

HERE(DFR1IN)
	MOVE	USER,GOGTAB	;SO CAN CALL ANY TIME
	MOVE	11,INTQWP(USER)
	IQW	1
	IQW	6
NOTENX<
	MOVE	TEMP,XJBCNI
	IQW	TEMP
	MOVE	TEMP,XJBTPC
	IQW	TEMP
>;NOTENX
TENX<
	MOVE	TEMP,-5(P)
	IQW	TEMP
	MOVE	TEMP,-4(P)
	IQW 	TEMP
>;TENX
	MOVE	TEMP,RUNNER
	IQW	TEMP
	MOVE	1,-1(P)
VILOOP:	MOVE	TEMP,(1)
	IQW	TEMP
	AOBJN	1,VILOOP
	MOVEM	11,INTQWP(USER)
	SETOM	INTRPT
	SKIPN	7,INTPRC(USER)	;INTERRUPT PROCESS
	JRST	DF.X
	MOVEI	TEMP,1		;READY
	SKIPL	STATUS(7)
	MOVEM	TEMP,STATUS(7)
DF.X:	SUB	P,X22
	JRST	@2(P)

IQWOV:	ERR	<DRYROT IN INTMOD -- WRITER>
	JRST	DF.X

HERE(DFRINT)
	PUSH	P,@DFRINF(USER)
	PUSHJ	P,DFR1IN
	POPJ	P,



TYMSHR <IFE ALWAYS <
TYSDFF:	0
	XWD 0,TYSDF2
	0
	LINK %INLNK,TYSDFF

TYSDF2:	PUSH P,[PUSHJ P,DDFINT]
	POP P,DDFINA
	POPJ P,
>>;TYMSHR
     
COMMENT ⊗THE INTERRUPT PROCESS⊗


DEFINE IQR(AC) <
	QR	(AC,<INTQWP(USER)>,D,<INTQWT(USER)>,<INTQWB(USER)>,<JRST QRERR>)
	>

HERE(INTPRO)
	PUSH	P,RF
;;#YE# 1! JFR 1-5-77 FIX OBSCURE PHASING BUG
	PUSH	P,INTPDA+PD.PDA
	PUSH	P,SP
DO1INT:	MOVE	USER,GOGTAB
	MOVE	D,INTQRP(USER)	;READER OF THE QUEUE
	QR	(1,<INTQWP(USER)>,D,<INTQWT(USER)>,<INTQWB(USER)>,< JRST ALDCIS >);
	IQR	6
	IQR	TEMP
	MOVEM	TEMP,IJBCNI(USER)
	IQR	TEMP
	MOVEM	TEMP,IJBTPC(USER)
	IQR	TEMP
	MOVEM	TEMP,IRUNNR(USER)
	IQR	B
;;#SC# ! USED TO BE A JUMPE.
	SOJLE	B,DISDFI
DO1I.1:	
	IQR	C
	MOVEM	D,INTQRP(USER)
	SOJLE	B,DO1I.2
	PUSH	P,C
	JRST	DO1I.1
DO1I.2:	HLRZ	D,C		
	CAIN	D,-1		;IS THIS A PDA
	JRST	DO1I.4		;NO -- JUST ISSUE THE CALL
	TLNN	C,-1		;WAS THERE A CONTEXT??
	JRST	DO1I.3		;NO
	MOVS	D,C		;PDA,,STATIC LINK
	HRRZ	TEMP,PD.PPD(C)	;PARENTS PDA
	PUSH	P,[ DO1INT]
	PUSH	P,RF
	HLRZ	LPSA,1(D)	;THE PDA IIN THE STACK
	CAIE	LPSA,TEMP	;BETTER BE THE SAME
	ERR	<ATTEMPT TO REFERENCE A NON-EX ENVIRONMENT IN INTPRO >
	PUSH	P,D		;STATIC LINK
	PUSH	P,SP		;SAVE SP
	HLRZ	C,PD.PPD	;END OF MKSEMT
	JRST	(C)
DO1I.3:	HRRZ	C,PD.(C)	;ENTRY ADDRESS
DO1I.4:	PUSHJ	P,(C)		;CALL THE PROCEDURE
	JRST	DO1INT

ALDCIS:	MOVE	PB,RUNNER	;ALL DONE CURRENT INTERRUPTS
	SETZM	STATUS(PB)	;SUSPEND SELF
	PUSHJ	P,SPSRN1
	JRST	DO1INT

QRERR: ERR	<DRYROT IN INTPRO -- READER>
	JRST 	ALDCIS


DISDFI:	ERR	<STRANGENESS IN DEFERRED INTERRUPT>,1
	JRST	DO1INT

DEFINE IPDE(X,V), < PUTINLOC(INTPDA+X,V) >

INTPDA: BLOCK PD.XXX+1

	IPDE	(PD.,INTPRO)
	IPDE	(PD.DSW,3)
;;#YE# 1! JFR 1-5-77 DONT LABEL COMPLEX ATOMS IN FAIL--PHASING PROBLEMS
	IPDE	(PD.PDA,<<XWD INTPDA,0>>)
	IPDE	(PD.LLW,<INTPDA+PD.XXX>)
	IPDE	(PD.DLW,<INTPDA+PD.XXX>)




;DFCPKT(5 WD BLOCK ADDR,EVTYP,EVNOT,OPTS)
; CREATES A FIVE WORD BLOCK FOR A DEFERED CAUSE & RETURNS AN AOBJN 
; POINTER TO THE BLOCK
; IF THE SUPPLIED BASE ADDRESS IS ≠0 THEN USES THAT ADDRESS
; OTHERWISE DOES A CORGET TO GET THE FIVE WORDS

HERE(DFCPKT)
	SKIPE	B,-4(P)		;DID USER GIVE ME A BLOCK
	JRST	DFC.1		;YES
	MOVEI	C,5
	PUSHJ	P,CORGET
	ERR	<NO CORE LEFT>
DFC.1:	HRLI	B,-5
	MOVE	A,B		;AOBJN PTR
	SUB	B,X11		;READY FOR PUSHES
;;#SC# ! USED TO BE A 4
	PUSH	B,[5]
	PUSH	B,-3(P)
	PUSH	B,-2(P)
	PUSH	B,-1(P)
	PUSH	B,[XWD -1,CAUSE]
	SUB	P,[XWD 5,5]
	JRST	@5(P)		;RETURN

COMMENT ⊗ CAUSE ⊗

HERE(CAUSE)
	MOVE	PB,RUNNER
	AOS	A,CAUSES(PB)
	CAIE	A,1		;FIRST CAUSE?
	JRST	DFRCS		;NO -DEFER IT
	POP	P,CAUSRA(PB)	;SAVE RETN ADDRESS
CSIT:	PUSHJ	P,CAUSE1	;DO THE WORK
	MOVE	PB,RUNNER
	SOSG	A,CAUSES(PB)	;DONE ONE
	JRST	CSE.X		;ALL ARE DONE -- CHECK FOR SCHED REQ
	MOVEI	KL,CAUSEQ(PB)	;GET NEXT FROM QUEUE
	PUSHJ	P,REMCAR
	HLRZ	B,(A)		;PICK UP TYPE
	PUSH	P,B
	HRRZ	B,(A)		;NOTICE
	PUSH	P,B
	PUSH	P,1(A)		;OPTIONS
	MOVE	TABL,GOGTAB
	HRR	B,FP2(TABL)	;RELEASE 2 WD BLOCK
	HRRM	B,(A)
	HRRM	A,FP2(TABL)
	JRST	CSIT		;GO WORK ON THIS
DFRCS:	MOVE	TABL,GOGTAB	;
	NNCLL2	(B)		;GET 2 WD CELL
	POP	P,TMP		;RETURN ADDRESS
	POP	P,1(B)		;OPTS
	POP	P,(B)		;NOTICE
	POP	P,A		;TYPE
	HRLM	A,(B)
	MOVEI	KL,CAUSEQ(KL)	;PUT ON CAUSE QUEUE
	PUSHJ	P,ITAILS	;PUT ON TAIL OF QUEUE
	JRST	(TMP)		;RETURN
CSE.X:	MOVE	USER,GOGTAB
	SKIPN	SCHDRQ(USER)	;SCHEDULING REQUEST
	JRST	@CAUSRA(PB) 	;NO
	SETZM	SCHDRQ(USER)	;YES
	PUSH	P,CAUSRA(PB)	;YES
	JRST	URSCHD		;RESCHEDULE

COMMENT ⊗CAUSE1 -- ROUTINE TO DO ACTUAL WORK ⊗

HERE(CAUSE1)
CSE1:	JSP	TMP,EVTCK3	;VERIFY THAT THIS IS AN EVENT ITEM
				;ALSO EVT ← DATUM ,B&C←ITEM #
	SKIPE	PDA,CAUSEP(EVT)	;DID THE USER SAY SOMETHING???
	JRST	USPPRC		;USER SPEC PROCEDURE
	MOVE	FF,-1(P)	;OPTIONS
	SKIPN	TMP,WAITLS(EVT)	;WAS ANYONE WAITING?
	JRST	SCA.2		;NO
	MOVE	TEMP,B		;EV TYP NO
	MOVE	TMP,(TMP)	;LAST,,FIRST
	MOVE	D,-2(P)		;NOTICE NO
SCA.1:	MOVE	TMP,(TMP)	;WAIT ENTRY
	HLRZ	C,TMP		;PROCESS NO
	MOVE	TABL,GOGTAB	;SET TABL TO RIGHT THING
	PUSHJ	P,ANSWR1	;SPECIAL ENTRY POINT IN ANSWER
	TRNE	A,NOJOY		;DID WE SUCCEED??
	JRST	SCA.1A		;NO
	TRNN	A,RETAIN	;KEEP THE NOTICE??
	TRO	FF,DNTSAV	;YES
	TRNN	FF,TELLAL	;TELL THE WHOLE WORLD?
	JRST	SCA.2		;NO
SCA.1A:	TRNE	TMP,-1		;ANY LEFT
	JRST	SCA.1		;YES

SCA.2:	TRNE	FF,DNTSAV	;SAVE IT?
	JRST	SCA.3		;NO
	MOVE	B,-2(P)		;ITEM NO OF NOTICE
	MOVEI	KL,NOTCLS(EVT)	;
	PUSHJ	P,ITAILS	;PUT ON END OF NOTIICE LIST
SCA.3:
	MOVE	USER,GOGTAB
	TRNE	FF,SCHDIT	;WANT TO RESCHEDULE
	SETOM	SCHDRQ(USER)	;RESCHEDULE REQUEST
SCA.X:	SUB	P,X44		;RETURN
	JRST	@4(P)

USPPRC:	MOVE	B,PD.(PDA)	;HERE IF USER SPECIFIED A PROCEDURE
;;#NB# !TYPO -- WAS A TLNE
	TLNN	PDA,-1		;CONTEXT GIVEN
	JRST	(B)		;NO
	PUSH	P,RF		;SET UP CONTEXT
	HRRZ	C,PD.PPD	;PARENTS PDA
	MOVS	A,PDA		;
	HLRZ	D,1(A)
	CAME	D,C		;SAME?
	ERR 	<CONTEXT WRONG OR CLOBBERED IN INTERP CALL
USER SPEC EVENT PROC >
	PUSH	P,A		;STATL
	PUSH	P,SP
	HLRZ	B,PD.PPD(PDA)
	JRST	(B)		;GO TO INSTR AFTER THE MKSEMT

COMMENT ⊗ANSWER -- subroutine used by CAUSE⊗

HERE(ANSWER)

;A←ANSWER(EV!TYP,NOT,PROCESS!ITEM);
;IF ATTEMPT TO ANSWER INTERROGATE IS SUCCESSFUL, A ← REQUEST CODE
;OTHERWISE, NOJOY BIT IS ON IN A & REST OF WORD IS INVALID

	MOVE	TEMP,-3(P)	;EV TYPE
	POP	P,-3(P)		;RET ADRS
	POP	P,C		;PROCESS ITEM
	POP	P,D		;NOTICE
	MOVE	TABL,GOGTAB
	LDB	B,INFOTAB(TABL)
	CAIE	B,PRCTYP
	 JRST	[MOVSI	TEMP,[ASCIZ/ANSWER/]
		JRST	ER.NPI]

;THE REST OF THIS IS CALLED INTERNALLY 
;EXPECTS D= NOIICE, C=PROCESS ITEM, TEMP=EV TYPE
;        ALSO TABL SET UP FOR PROCESS ITEM
;MODIFIES A,B,C,TABL,PB,TEMP,USER

ANSWR1:	MOVE	PB,@DATAB(TABL)	;THE PROCESS BASE
	TLNN	PB,TERM		;TERMINATED?
	SKIPE	STATUS(PB)	;OR NOT SUSPENDED??
	JRST	NOANS		;YES
	AOS	STATUS(PB)	;MAKE READY
	MOVEM	D,AC1(PB)
ANSWR2:	PUSHJ	P,DELWRQ	;DELETE ALL WAIT REQUESTS
	MOVE	A,INTRGC(PB)	;THE INTERROG CONTROL WORD
	TRNN	A,SAYWCH	;ASKED FOR THE ASSOCIATION
	POPJ	P,		;NO
	PUSH	P,[EVTYPI]	;
	PUSH	P,D
	PUSH	P,TEMP
	PUSHJ	P,STACSV	;SAVE ALL ACS
	MOVEI	5,16		;MAKE
	PUSHJ	P,LEAP
	PUSHJ	P,STACRS	;GET ACS BACK
	POPJ	P,
NOANS:	TRO	A,NOJOY
	POPJ	P,		;RETURN
COMMENT ⊗DELWRQ -- delete all wait requests⊗

;EXPECTS PB = THIS PROCESS
;MANGLES A,B,C,TABL

DELWRQ:	SKIPN	A,WAITES(PB)
	POPJ	P,
	PUSH	P,KL
	MOVE	A,(A)		;A IS LAST,,FIRST
DTHSRQ:	MOVE	A,(A)		;NEXT ENTRY
	HLRZ	C,A		;ITEM NUMBER OF TYPE
	PUSH	P,A		;FOR SAFE KEEPING
	MOVE	TABL,GOGTAB	;
GLOB <
;;%BE%
	CAIL	C,GBRK		;GLOBAL ??
	MOVEI	TABL,GLUSER	;
>;GLOB
	MOVE	A,@DATAB(TABL)
	MOVEI	KL,WAITLS(A)
	MOVE	B,PRCITM(PB)
	PUSHJ	P,DELTLE	;DELETE ELEMENT
				;SETS TABL BACK TO GOGTAB
				;(MAYBE)
	POP	P,A		
	TRNE	A,-1		;ANY LEFT
	JRST	DTHSRQ		;YES
	MOVE	A,WAITES(PB)
	MOVE	TABL,GOGTAB
	HLRZ	B,(A)		;ADDRESS OF LAST
	HRRZ	C,FP1(TABL)
	HRRM	C,(B)		;RELEASE THE LOT
	HRRM	A,FP1(TABL)
	SETZM	WAITES(PB)	;NONE LEFT
	POP	P,KL
	POPJ	P,
COMMENT ⊗INTERROGATE⊗
HERE(INTERROGATE)
	SKIPN	B,-2(P)		;SET OR ITEM
	ERR	<NULL INTERROGATION???>
	TLNN	B,-1		;SET?
	JRST	ASK1.0		;NO
	MOVEI	FF,MULTIN
	IORM	FF,-1(P)	;SAY MULT REQUEST
	MOVE	TMP,(B)		;LAST,,FIRST
MPCI:	MOVE	TMP,(TMP)	;NEXT ENTRY
	HLRZ	B,TMP
	PUSH	P,TMP
	PUSH	P,B		;TYPE ITEM
	PUSH	P,-3(P)		;OPTIONS WORD
	PUSHJ	P,ASK1.0
	POP	P,TMP		;GET LIST BACK
	CAIE	A,NIC		;FIND ONE??
	JRST	ASK1.X		;YES
	TRNE	TMP,-1		;DONE LIST???
	JRST	MPCI		;NO
	MOVE	FF,-1(P)
	TRNN	FF,WAIT		;WAITING REQUESTED
	JRST	ASK1.X		;NO
	MOVE	PB,RUNNER	;SUSPEND SELF
	MOVE	B,-2(P)		;THE LIST
	MOVE	TMP,(B)		;LAST,,FIRST
BWL:	MOVEI	KL,WAITES(PB)
	MOVE	TMP,(TMP)	;NEXT
	HLRZ	B,TMP		;ITEM NO
	MOVE	C,B
	MOVE	EVT,@DATM
	PUSHJ	P,ITAILS	;ON TAIL
	MOVE	B,PRCITM(PB)	;
	MOVEI	KL,WAITLS(EVT)
	PUSHJ	P,ITAILS	;ON EVENT WAIL LIST
	TRNE	TMP,-1
	JRST	BWL		;CDR DOWN LIST
	JRST	DOWAIT		;GO WAIT
COMMENT ⊗ASK -- used by INTERROGATE⊗

ASK1I:	MOVE	B,-2(P)
ASK1.0:	JSP	TMP,EVTCKB	;GET DATUM OF EVENT TYPE
;;#NB# ! WAS SKIPE A,...
	SKIPE	PDA,INTRGP(EVT)	;USER WAIT PROCESS??
	JRST	USPPRC		;YES
;;# #! ASKNTC POINTS HERE
ASKN:	MOVE	FF,-1(P)	;CONTROL WORD
	SKIPN	A,NOTCLS(EVT)	;ANY READY TO GO
	JRST	ASK1.4		;NO
	TRNE	FF,RETAIN	;RETAIN THIS ONE??
	JRST 	ASK1.1		;YES
	MOVEI	KL,NOTCLS(EVT)
	PUSHJ	P,REMCAR	;GET THE FIRST
	JRST	ASK1.2		;TEST SAYWCH
ASK1.1:	MOVE	A,(A)
	HLRZ	A,(A)		;THI FIRST ITEM
ASK1.2:	TRNN	FF,SAYWCH	;WANT ASSOCIATION
	JRST	ASK1.3		;NO
	PUSH	P,[EVTYPI]	;EVENT TYPE
	PUSH	P,A		;NOTICE
	PUSH	P,-4(P)		;WHATEVER TYPE IT IS
	PUSHJ	P,STACSV	;SAVE REGS
	MOVEI	5,16		;MAKE
	PUSHJ	P,LEAP
	PUSHJ	P,STACRS	;GET ACS BACK
ASK1.3:
ASK1.X:	SUB	P,X33
	JRST	@3(P)		;RETURN

ASK1.4:	MOVEI	A,NIC
	TRNE	FF,WAIT		;IF NOT WAITING OR 
	TRNE	FF,MULTIN	;MUL REQ
	JRST	ASK1.X		;ALL DONE
	MOVE	PB,RUNNER
	MOVEI	KL,WAITES(PB)	;WAIT ON THIS ONE
	PUSHJ	P,ITAILS	;PUT ON TAIL
	MOVE	B,PRCITM(PB)
	MOVEI	KL,WAITLS(EVT)
	PUSHJ	P,ITAILS
DOWAIT:	SETZM	STATUS(PB)
	MOVEM	FF,INTRGC(PB)
	MOVEI	A,WAITNG
	MOVEM	A,REASON(PB)
	PUSHJ	P,SPSRN2	;WAIT
	JRST	ASK1.X		;RETURN

HERE(ASKNTC)
;;#NC# ! WAS A PUSHJ
	JSP  	TMP,EVTCK3	;CHECK EVENT TYPE
	JRST	ASKN		;GO DO IT

;ROUTINE TO SET UP EVENT TYPE ITEM
;SETS B & C TO ITEM #
;SETS EVT TO DATUM
;SETS TABL TO RIGHT THING FOR ITEM
;CALLED VIA JSP TMP,EVTCKX


EVTCK3:	SKIPA	B,-3(P)
EVTCK2:	MOVE	B,-2(P)
EVTCKB:	MOVE	TABL,GOGTAB
	MOVE	C,B
GLOB <
;;%BE% allow for global items RHT 1-8-74
	CAIL	C,GBRK		;IS THE ITEM GLOBAL
	MOVEI	TABL,GLUSER	;YES, USE GLOBAL INFO STUFF
>;GLOB

	LDB	A,INFOTAB(TABL)
	CAIE	A,EVTTYP
	ERR	<THIS ITEM IS NOT AN EVENT TYPE>,6
	MOVE	EVT,@DATAB(TABL)
GLOB <
;;%BE% real hack for now, only the item gets to be global.
	MOVE	TABL,GOGTAB
>;GLOB
	JRST	(TMP)
COMMENT ⊗MKEVTT,SETCP,& SETIP⊗
HERE(SETCP)
	JSP	TMP,EVTCK2
	MOVE	A,-1(P)
	MOVEM	A,CAUSEP(EVT)
XIT3:	SUB	P,X33
	JRST	@3(P)


HERE(SETIP)
	JSP	TMP,EVTCK2
	MOVE	A,-1(P)
	MOVEM	A,INTRGP(EVT)
	JRST	XIT3

HERE(MKEVTT)	;MAKE EVENT TYPE
	MOVE	C,-1(P)
	MOVEI	A,EVTTYP
	MOVE	TABL,GOGTAB
GLOB <
;;%BE%
	CAIL	C,GBRK
	JRST	[ SETOM USCOR2(TABL)	;BLOCK IN UPPER
		MOVEI TABL,GLUSER
		JRST	.+1 ]

>;GLOB
	DPB	A,INFOTAB(TABL)
	MOVEI	C,NEVARS
	PUSHJ	P,CORGET
	ERR	<MKEVT: No core>
	MOVE	C,-1(P)
	MOVE	TABL,GOGTAB
GLOB <
;;%BE%
	CAIL	C,GBRK
	JRST	[ SETZM USCOR2(TABL)	;UNDO ABOVE
		MOVEI	TABL,GLUSER
		JRST	.+1 ]
>;GLOB
	MOVEM	B,@DATAB(TABL)
	HRLI	D,(B)
	HRRI	D,1(B)
	SETZM	(B)
	BLT	D,NEVARS-1(B)
	SUB	P,X22
	JRST	@2(P)

COMMENT ⊗SPARE HERE TABLE ENTRIES⊗

;THE IDEA IS THAT THIS WAY WE HAVE FLEXIBILITY 
;WITHOUT GOING TO A NEW SEGMENT ALL THE TIME

HERE(NWLD1)
HERE(NWLD2)
HERE(NWLD3)
HERE(NWLD4)
HERE(NWLD5)
	ERR <DRYROT IN NWORLD>

BEND PROCSS

ENDCOM(PRC)

COMPIL(IRP,,,,,,DUMMYFORGDSCISS)
NOTENX <
NOTYMSHR <
DEFINE IENS1 < INTTBL,INTMOD,ENABLE,DISABLE,INTMAP>>;NOTYMSHR
TYMSHR <DEFINE IENS1 <INTTBL,ENABLE,DISABLE,INTMAP>>;TYMSHR
DEFINE IEXT1 < GOGTAB,INTRPT,X22,CORGET >
IFN APRISW <
DEFINE XJBCNI <JOBCNI>
DEFINE XJBTPC <JOBTPC>
DEFINE XJBAPR <JOBAPR>
DEFINE IEXT5 <JOBCNI,JOBTPC,JOBAPR,XJBENB,APRACS>
IFN ALWAYS <
EXTERN JOBCNI,JOBTPC,JOBAPR	;THESE ARE ALWAYS EXTERNAL
>;IFN ALWAYS
>;IFN APRISW
IFE APRISW <
DEFINE IEXT5 <XJBCNI,XJBTPC,XJBAPR,JOBINT>
IFN ALWAYS <
EXTERNAL JOBINT ;THIS FELLOW IS ALWAYS EXTERNAL
>;IFN ALWAYS
>;IFE APRISW

COMPXX(IRP,< IENS1 >,< IEXT1,IEXT5 >
		,<INTERRUPT STUFF>,,HIIFPOSSIB)

BEGIN IRPPKG

INTDBG←←0

IFE APRISW <

IFE INTDBG <
OPDEF DISMIS [ CALLI 400024]
>;IFE INTDBG
IFN INTDBG <
DEFINE DISMIS < JRST DSMMSR >
DSMMSR:
	HRLZI	P,INACS
	BLT	P,P
	JRST	@JOBTPC
INACS:	BLOCK 	20
>;IFN ITDBG
OPDEF INTORM [ CALLI 400026]
OPDEF INTACM [ CALLI 400027]
OPDEF INTENB [ CALLI 400025]
>;IFE APRISW

NOTYMSHR <
IFN APRISW <
OPDEF APRENB [ CALLI 16]
DEFINE DISMIS < JRST DSMSSR >
DSMSSR:	HRLZI	17,APRACS
	BLT	17,17	;BLT BACK ALL ACS
	JRST	@XJBTPC
>;IFN APRISW

HERE(INTTBL)
;CALL IS INTTBL(BUFFER!SIZE)
;SETS UP TABLES NEEDED BY THE INTERRUPT SYSTEM

	MOVE	USER,GOGTAB	;
INTTB1:	MOVEI	C,=110
	ADD	C,-1(P)
	PUSHJ	P,CORGET
	ERR <INTSET: No core>
	SKIPN	D,DISPAT(USER)	;ALREADY HABE ONE?
	JRST	INTTB2		;NO
	MOVSS	D		
	HRR	D,B		;D ← OLD,,NEW
	BLT	D,=71(B)	;COPY OLD DISPAT TABLE
	JRST	INTTB3
INTTB2:	SETZM	(B)
	HRL	A,B
	HRRI	A,1(B)
	ADDI	C,-1(B)
	BLT	A,(C)
INTTB3:	HRLI	B,10
	MOVEM	B,DISPAT(USER)
	ADDI	B,=36
	MOVEM	B,DFRINF(USER)
	ADDI	B,=36
	HRRZM	B,INTQWB(USER)
	HRRZM	B,INTQWP(USER)
	HRRZM	B,INTQRP(USER)
	ADD	B,-1(P)
	HRRZM	B,INTQWT(USER)
	HRLI	B,-20
	MOVEM	B,IPDP(USER)
	ADD	B,[XWD -10,20]
	MOVEM	B,ISPDP(USER)
	SUB	P,X22
	JRST 	@2(P)




IFN INTDBG,<
INTAPR:	MOVEM	P,INACS+17
	MOVEI	P,INACS
	BLT	P,INACS+16
>;IFN INTDBG

HERE(INTMOD)
IFN APRISW <
	MOVEM	17,APRACS+17
	MOVEI	17,APRACS
	BLT	17,APRACS+16	;SAVE THE ACS
>;IFN APRISW
	MOVE	USER,GOGTAB
	MOVE	7,XJBCNI	;PICK UP THE BITS
IFN APRISW <			
	ANDI	7,235110	;BE SURE LEGIT BITS ONLY
>;IFN APRISW
	MOVE	P,IPDP(USER)	;A PDL FOR THIS
	MOVE	SP,ISPDP(USER)	;A STRING PDL
DSPIT:	JFFO	7,DODISP	;DISPATCH INDEX
	ERR	<DRYROT: INTMOD>
DODISP:
	SKIPN	7,@DISPAT(USER)	;GO DISPATCH
	DISMIS			;DISMISS
	PUSHJ	P,(7)		;
	DISMIS


COMMENT ⊗PROCEDURES TO ENABLE FOR INTERRUPTS⊗

;ENABLE(INDEX) -- DOES AN INTORM
;DISABLE(INDEX) -- DOES AN INTACM

IFE APRISW <
HERE(ENABLE)
	SKIPA	B,[ INTORM A, ]
HERE(DISABLE)
	MOVE	B,[ INTACM A, ]
	MOVN	C,-1(P)
	HRLZI	A,400000
	LSH	A,(C)
	XCT	B
	SUB	P,X22
	JRST	@2(P)
>;IFE APRISW
IFN APRISW <
HERE(ENABLE)
	SKIPA	B,[OR A,XJBENB]
HERE(DISABLE)
	MOVE	B,[ANDCA A,XJBENB]
	MOVN	C,-1(P)		;
	HRLZI	A,400000
	LSH	A,(C)		;THE BIT
EXPO <
	TRO	A,400000	;REPETITIVE ENABLE (THIS MIGHT GET YOU
				;IN TROUBLE WITH THE CLOCK INTERRUPT)
>;EXPO
	XCT	B
	MOVEM	A,XJBENB	;REMEMBER
	APRENB	A,
	SUB	P,X22
	JRST	@2(P)
>;IFN APRISW

;INTMAP(INDEX,ENTRY!ADDR,PARAM);
;DISPAT[INDEX]←ENTRY!ADDR
;DFRINF[INDEX]←PARAM

HERE(INTMAP)

IFE APRISW <
	MOVEI	A,XJBCNI
	MOVEM	A,JOBINT
>;IFE APRISW

IFE INTDBG,<
	MOVEI	A,INTMOD
>;IFE INTDBG
IFN INTDBG,<
	MOVEI	A,INTAPR
>;IFN INTDBG
	MOVEM	A,XJBAPR
	MOVE	USER,GOGTAB
	SKIPE	DISPAT(USER)
	JRST	.+3
	PUSH	P,[=128]
	PUSHJ	P,INTTB1	;GET MINIMAL TABLES
	MOVE	10,-3(P)	;GET INDEX
	POP	P,-3(P)		;RET ADR
	POP	P,@DFRINF(USER)
	POP	P,@DISPAT(USER)
	POPJ	P,

> ;NOTYMSHR
TYMSHR <

COMMENT ! PROCEDURES TO ENABLE FOR INTERRUPTS

ENABLE (INDEX) -- ENABLES INTERUPT
DISABLE (INDEX) -- DISABLES

IN BOTH CASES IDEX MEANS:

IF INDEX LAND '777000 NEQ 0 THEN INDEX IS THE CHANNEL NUMBER
	TO ENABLE OR DIABLE (WATCH USING CHANNELS 1 TO 4)
ELSE INDEX IS AN OLD STYLE NUMBER
	29	FLOATING OVERFLOW CHL 1
	32	OVERFLOW CHL 2
	19	PDL OVERFLOW CHL 3
	22	ILL MEM REF CHL 4
!

HERE (DISABLE)
	TDZA B,B
HERE (ENABLE)
	MOVSI B,400000	;SET ON OR OFF BIT FOR INTENB
	MOVE USER,GOGTAB
	SKIPE DISPAT(USER)
	JRST ENAB1
	PUSH P,B
	PUSH P,[=128]
	PUSHJ P,INTTB1
	POP P,B
ENAB1:	HRRZ C,-1(P)
	TRZN C,777000
	JRST OLDENB
	MOVNS C
	MOVSI A,400000
	LSH A,(C)	;GET A BIT FOR THE CHANNEL
	OR B,A
ENBDO:	INTENB B,
	 JFCL
ENBRT:	SUB P,X22
	JRST @2(P)

OLDENB:	CAIN C,=29
	JRST ENBFOV
	CAIN C,=32
	JRST ENBOV
	CAIN C,=19
	JRST ENBPDL
	CAIE C,=22
	JRST ENBRT	;JUST RETURN
	TLO B,020000	;SET BIT FOR CHANNEL 4
	JRST ENBDO	;AND DO IT

ENBPDL:	HRRZ A,IPDP(USER)
	SUBI A,=6
	TLNE B,400000	;NEED JSR IF ENABLING
	TLOA A,(<JSR>)
	MOVSI A,1	;OTHERWISE JUST SOMETHING NON-ZERO (MONTOR)
	SETTR2 A,
	 JFCL
	TLO B,040000
	JRST ENBDO	;GO TURN ON CHL3

ENBOV:	TLOA B,100000	;FOR OVERFLOW
ENBFOV:	TLO B,200000	;OR FLOATING OVERFLOW
	MOVEI C,0
	INTENB C,	;JUST READ STATUS
	 JFCL
	TLNN B,400000
	TDZA C,B
	IOR C,B		;MAKE IT LOOK LIKE IT WILL
	HRRZ A,IPDP(USER)
	SUBI A,=11
	TLNE C,300000
	TLOA A,(<JSR>)	;MAKE EITHER JSR OR JFCL
	MOVSI A,(<JFCL>)
	SETTR1 A,
	 JFCL
	JRST ENBDO
COMMENT ! ROUTINE TO SET UP THE INTERUPT SYSTEM ORIGINALLY.
ALSO SETS UP THE DEFERED INTERUPT COMMUNICATION AREA
FROM SAIL PROGRAM CALL IS
	INTTBL (SPACE DESIRED)
INTERNAL ROUTINES CALL AT INTTB1 WITHER USER SET UP !

HERE (INTTBL)
	MOVE USER,GOGTAB
INTTB1:	SKIPE DISPAT(USER)	;ONNLY ZERO THE FIRST TIME
	JRST INTTB2
	MOVEI C,=210+20+30+=72+1+5+5	;SPACE FOR
		;INTERUPT TABLE AND ROUTINES, PDL, SPDL, DISPAT
		;AND DFRINF TABLES, SAVE INTERUPT PTR, OVERFLOW
		;AND PDL OVERFLOW ROUTINES IN THAT ORDER
	PUSHJ P,CORGET
	ERR <NOT ENOUGH SPACE FOR INTSET>
	HRLI B,10	;MUST HAVE INDEX FIELD SET IN THESE TABLES
	MOVEM B,DISPAT(USER)
	ADDI B,=36
	MOVEM B,DFRINF(USER)
	ADDI B,=36
	MOVE A,B
	HRLI A,6
	INTADR A,	;SET UP THE INTERUPT TABLE
	 JFCL
	HRLI B,-=35	;NOW SET UP THE ENTRIES

COMMENT !
FOR EACH OF THE 35 CHANNELS THERE ARE THREE ENTRIES
FIRST THE TWO WORDS OF THE INTERUPT TABLE
	RETURN ADDRESS
	INTERUPT ROUTINE ADDRESS
THEN THE TWO WORDS OF THE INTERUPT ROUTINE
	MOVEM 16,<STORAGE WORD 1>
	JSP 16,<COMMON INTERUPT ROUTINE>
THEN THE TWO STORAGE WORDS.

THE TOTAL STRUCTURE IS
	70 WORDS OF TABLE
	70 WORDS OF INTERUPT ROUTINE
	70 WORDS OF STORAGE
!
	MOVE C,[JSP 16,COMIMD]
MAKTB1:	MOVEI A,=70(B)
	MOVEM A,1(B)
	MOVSI A,(<MOVEM 16,>)
	HRRI A,=140(B)
	MOVEM A,=70(B)
	MOVEM C,=71(B)
	ADDI B,1
	AOBJN B,MAKTB1
	ADDI B,=140
COMMENT ! NOW FOR THE OVERFLOW AND PDL OV ROUTINES. THESE ARE
CALLED WITH JSR AND LOOK LIKE
	0	;JSR HERE
	MOVEM 16,.+2
	JSP 16,<EITHER COMOVF OR COMPDL>
	BLOCK 2
!
	MOVEI A,3(B)
	HRLI A,(<MOVEM 16,>)
	MOVEM A,1(B)
	HRRI A,=8(B)
	MOVEM A,6(B)
	MOVE A,[JSP 16,COMOVF]
	MOVEM A,2(B)
	HRRI A,COMPDL
	MOVEM A,7(B)
	ADDI B,=11	;ALSO LEAVE SPACE FOR INTEUPT POINTERWORD
	HRLI B,-20
	MOVEM B,IPDP(USER)
	ADD B,[XWD -10,20]
	MOVEM B,ISPDP(USER)
INTTB2:	MOVE C,-1(P)	;GET SPACE REQUESTED
	PUSHJ P,CORGET
	ERR <NOT ENOUGH SPACE FOR INTSET>
	HRRZM B,INTQWB(USER)
	HRRZM B,INTQWP(USER)
	HRRZM B,INTQRP(USER)
	ADD B,-1(P)
	HRRZM B,INTQWT(USER)
	SUB P,X22
	JRST @2(P)
COMMENT ! HERE IS THE ACTUAL INTERUPT CODE !

COMIMD:	MOVEM 17,=69(16)	;STORE ANOTHER AC IN PER CHL AREA
	MOVSI 17,1
	INTADR 17,	;TURN OFF PI SYSTEM TO PREVENT MULTIPLE
	 JFCL		;INTERUPTS
	MOVEI 17,APRACS
	BLT 17,APRACS+15
	DMOVE 1,=68(16)
	DMOVEM 1,APRACS+16	;GET ALL ACS THERE
	MOVE 1,-=72(16)
	MOVEM 1,JOBTPC	;AND THE INTERUPT ADDRESS
IFN <SP-16>,<MOVE SP,16		;JUST IN CASE ITS NOT 16>
	MOVE USER,GOGTAB
	MOVE P,IPDP(USER)
	MOVEM SP,-1(P)	;STORE IT HERE FOR RETURN
	MOVE SP,ISPDP(USER)
	REDPIP 7,
	JFCL
	TLZ 7,400000	;JUST IN CASE
	JFFO 7,DODISP
	 ERR <DRYROT: INTMOD>
DODISP:	CAIG 10,3
	JRST	[MOVE A,APRACS+16	;THESE ARE SPECIAL
		MOVE B,-3(A)
		MOVEM B,JOBTPC
		DMOVE A,(A)
		DMOVEM A,APRACS+16
		JRST .+1]
	SKIPE 7,@DISPAT(USER)
	PUSHJ P,(7)
	MOVE 16,-1(P)
	MOVE 1,JOBTPC	;GET SET TO PUT PC BACK
	MOVE 2,-2(1)
	CAMN 2,[SKIPE INTRPT]	;WOORY ABOUT RACE CONDITION
	SUBI 1,2
	MOVEM 1,-=72(16)	;THE DISPATCH LOCATION FOR DISMISS
	DMOVE 2,APRACS+16
	DMOVEM 2,=68(16)
	MOVSI 15,APRACS
	BLT 15,15	;RRESTORE SOME ACS
	MOVSI 17,300000
	INTACT 17,	;CLEAR PENDING OVERFLOW INTERUPTS
	 JFCL
	MOVSI 17,2
	INTADR 17,	;NOW SYSTEM IS ON AGAIN
	 JFCL
	DMOVE 16,=68(16)
	DISMIS

COMMENT ! NOW FOR THE OVERFLOW AND PDL OV ROUTINES!

COMPDL:	TLZ 16,440140	;ZERO ALL OVERFLOW BITS
COMOVF:	MOVEM 17,1(16)
	MOVSI 17,640000	;CAUSE SOME INTERUPTS
	TLNN 16,040000
	TLC 17,300000	;IF FLOAT-OVEFLOW FLAG OFF CHANGE TO OVERFLOW
	TLNN 16,440140	;IF NO OVERFLOW BITS
	TLZA 17,300000	;TURN OFF OVERFLOW CHANNELS
	TLZ 17,040000	;ELSE PDL CHANNELS
	TLZ 17,040000	;SAME FOR PDL OV
	INTACT 17,
	 JFCL
	MOVE 17,1(16)
	HRL 16,16
	JRA 16,@-3(16)
COMMENT ! INTMAP SETS UP AN INTERUPT. THE CALL IS
	INTMAP (INDEX,INTERUPT PROC,ARGS TO INT PROC)
INDEX TAKES ONE OF FOUR FORMS:

TYPE OF INT	INDEX			MONITOR CALL
OLD		OLD INTERUPT NUMBER	SPECIAL
INTASS		(18) CAUSE (3) 001	(18) CAUSE (18) CHANNEL
		(15) CHANNEL
TINASS		(18) PORT (3) 101	(9) CAUSE (9) CHANNEL
		(6) CAUSE (9) CHANNEL	(18) PORT
INTRMT		(18) DEV (3) 111	(9) CAUSE (9) CHANNEL
		(6) CAUSE (9) CHANNEL	(18) DEV
!

HERE (INTMAP)
	MOVE USER,GOGTAB
	SKIPE DISPAT(USER)
	JRST .+3
	PUSH P,[=128]
	PUSHJ P,INTTB1
	MOVE 10,-3(P)	;THE INDEX
	TRZN 10,100000
	JRST OLDMAP
	TRZE 10,400000
	JRST DEVMAP
COMMP2:	MOVE A,10
	MOVE B,[INTASS A,]
COMMAP:	ANDI 10,777	;GET CHANNEL
	POP P,-3(P)	;RETURN ADDRESS
	POP P,@DFRINF(USER)
	POP P,@DISPAT(USER)
	XCT B
	 JFCL
	POPJ P,

DEVMAP:	MOVS A,10	;SET UP FOR MONITOR
	TLZE A,200000
	SKIPA B,[INTRMT A,]
	MOVE B,[TINASS A,]
	JRST COMMAP

OLDMAP:	CAIN 10,=22
	JRST	[MOVE 10,[XWD 2,4]	;ILL MEM REF
		JRST COMMP2]
	CAIN 10,=19
	MOVEI 10,3	;PDL OV
	CAIN 10,=32
	MOVEI 10,2	;OVERFLOW
	CAIN 10,=29
	MOVEI 10,1	;FLOAT-OVERFLOW
	MOVSI B,(<JFCL>)	;DON'T NEED ANYTING SPECIAL
	CAILE 10,3
	MOVEI 10,0
	JRST COMMAP
> ;TYMSHR
     
HERE(IRPSP1)
HERE(IRPSP2)
HERE(IRPSP3)

BEND IRPPKG

>;NOTENX
TENX<

;; HERE IS THE TENEX VERSION

DEFINE IENS1 < INTTBL,PSIL1,PSIL2,PSIL3,ENABLE,DISABLE >
DEFINE IENS2 < ATI,DTI,RTIW,STIW,GTRPW,PSIMAP,INTMAP,PSIDISMS,PSIRUNTM,KPSITIME >
DEFINE IEXT1 < GOGTAB,INTRPT,JMPCHN,PS1CAS,PS2ACS,PS3ACS >
DEFINE IEXT2 < XJBCNI,XJBTPC,X22,X33,X44,CORGET,JOBUUO >

COMPXX(IRP,<IENS1,IENS2>
		,<IEXT1,IEXT2>,<INTERRUPT STUFF FOR TENEX>,,HIIFPOSSIB)

BEGIN IRPPKG

HERE(INTTBL)
;CALL IS INTTBL(BUFFER!SIZE)
;SETS UP TABLES NEEDED BY THE INTERRUPT SYSTEM

	MOVE	USER,GOGTAB	;
INTTB1:	MOVEI	C,=194
	ADD	C,-1(P)
	PUSHJ	P,CORGET
	  ERR <INTSET: No core>
	SKIPN	D,DISPAT(USER)	;ALREADY HABE ONE?
	JRST	INTTB2		;NO
	MOVSS	D		
	HRR	D,B		;D ← OLD,,NEW
	BLT	D,=71(B)	;COPY OLD DISPAT TABLE
	JRST	INTTB3
INTTB2:	SETZM	(B)
	HRL	A,B
	HRRI	A,1(B)
	ADDI	C,-1(B)
	BLT	A,(C)
INTTB3:	HRLI	B,10
	MOVEM	B,DISPAT(USER)
	ADDI	B,=36
	MOVEM	B,DFRINF(USER)
	ADDI	B,=36
	MOVEM	B,TIMFRK(USER)
	ADDI	B,=36
	HRRZM	B,INTQWB(USER)
	HRRZM	B,INTQWP(USER)
	HRRZM	B,INTQRP(USER)
	ADD	B,-1(P)
	HRRZM	B,INTQWT(USER)
DEFINE XXX $ (LEV) <
	MOVEI	C,(B)
	HRLI	C,-20
	MOVEM	C,IPDP$LEV(USER)
	ADDI	B,20
	MOVEI	C,(B)	
	HRLI	C,-10
	MOVEM	C,ISPDP$LEV(USER)
>
	XXX(1)
	XXX(2)
	XXX(3)
	SUB	P,X22
	JRST 	@2(P)


DEFINE XXX $ (LEV) <
HERE(PSIL$LEV)
	MOVEM	16,PS$LEV$ACS+16	;SAVE ACS
	MOVEI	16,PS$LEV$ACS
	BLT	16,PS$LEV$ACS+15
	HRRZI	10,-JMPCHN-1(17)	;CHANNEL NUMBER INTO 10
	MOVE	USER,GOGTAB
	MOVE	P,IPDP$LEV(USER)
	MOVE	SP,ISPDP$LEV(USER)
	SKIPN	7,@DISPAT(USER)
	  JRST	DIS$LEV
	MOVSI	A,400000
	MOVNI	B,(10)
	LSH	A,(B)
	PUSH	P,A			;THE CHANNEL AS A BIT
	MOVEI	1,400000		;THIS FORK
	JSYS	RIR			;READ LEVTAB,CHNTAB
	HLRZ	2,2			;LEVTAB
	PUSH	P,@LEV-1(2)		;PC WORD FOR THIS LEVEL
	PUSH	P,JOBUUO		;SAVE JOBUUO
	PUSHJ	P,(7)
	POP	P,JOBUUO		;RESTORE JOBUUO
	SUB	P,X22			;POINTLESS ACTUALLY
DIS$LEV:HRLZI	17,PS$LEV$ACS
	BLT	17,17
	JSYS	DEBRK
>;END OF MACRO DEFINITION

XXX(1)
XXX(2)
XXX(3)


DSCR
	ENABLE(PSICHAN)

	Does an AIC on the pseudo-interrupt channel.


	DISABLE(PSICHAN)

	Does a DIC on the pseudo-interrupt channel.	


⊗

HERE(ENABLE)
	SKIPA	C,AIC1
HERE(DISABLE)
	MOVE	C,DIC1
	MOVN	A,-1(P)			;NEGATED PSI CHAN
	HRLZI	B,400000
	LSH	B,(A)			;GET THE RIGHT BIT
	HRRZI	A,400000		
	XCT	C
	SUB	P,X22
	JRST	@2(P)

AIC1:	JSYS	AIC			;AVOID A LITERAL
DIC1:	JSYS	DIC
	

DSCR
	ATI(PSI,CHAR!CODE)

	Assigns a character code to a PSI channel.

	DTI(CHAR!CODE)

	Deassigns a character code.

⊗

HERE(ATI)
	HRRZ	B,-1(P)			;GET THE CODE
	JUMPL	B,.+2			;IF NOT (0 LEQ CODE LEQ =35) THEN ERR
	 CAILE	B,=35
	 ERR	<ATI:  Terminal code not in range 0 thru 35>
	MOVE	A,-2(P)			;PSI CHANNEL
	JUMPL	A,BADCHN
	CAILE	A,=35
	  JRST	BADCHN
	CAIGE	A,=24
	  CAIG	A,=5
	JRST	.+2
BADCHN:	ERR	<ATI:  Terminal interrupt channel not 0-5 or 24-35>
	HRL	A,B
	JSYS	ATI
	SUB	P,X33
	JRST	@3(P)

HERE(DTI)
	HRRZ	A,-1(P)			;TERMINAL CODE
	JUMPL	A,DTIERR
	CAILE	A,=35
DTIERR:	ERR	<DTI:  Terminal interrupt code not in range>
	JSYS	DTI
	SUB	P,X22
	JRST	@2(P)


HERE(RTIW)
	MOVE	1,-3(P)
	JSYS	RTIW
	MOVEM	2,@-2(P)
	MOVEM	3,@-1(P)
	SUB	P,X44
	JRST	@4(P)	

HERE(STIW)
	MOVE	1,-3(P)
	MOVE	2,-2(P)
	MOVE	3,-1(P)
	JSYS	STIW
	SUB	P,X44
	JRST	@4(P)

HERE(GTRPW)
	MOVE	1,-2(P)
	JSYS	GTRPW	
	MOVEM	2,@-1(P)
	SUB	P,X33
	JRST	@3(P)				;CONTENTS OF 1 OK


HERE(PSIMAP)
	MOVE	USER,GOGTAB
	SKIPE	DISPAT(USER)		;ARE TABLES SET UP?
	  JRST	.+3
	PUSH	P,[=128]
	PUSHJ	P,INTTB1		;SO SET UP
	MOVEI	A,400000		;THIS FORK
	JSYS	RIR			;READ ADDRESS
	JUMPN	2,.+2
	  ERR	<PSIMAP: DRYROT>
	JSYS	EIR			;TURN ON PSI SYSTEM
	SKIPL	10,-4(P)		;CHANNEL
	CAILE	10,=35			;CHECK RANGE
	  ERR	<PSIMAP:  Channel number not between 0 and 35>
	POP	P,-4(P)			;RETURN ADDRESS
	POP	P,D			;LEVEL
	CAIL	D,1
	CAILE	D,3
	  ERR	<PSIMAP:  Level not between 1 and 3>
	POP	P,@DFRINF(USER)		;INFORMATION ABOUT DEFERRED INTERRUPT -- CHANNEL IN 10
 	POP	P,@DISPAT(USER)		;DISPATCH ADDRESS -- CHANNEL IN 10
	ADDI	2,(10)			;POSITION IN TENEX CHNTBL
	ADDI	10,JMPCHN		;ADDRESS TO JMP TO FROM CHNTAB
	HRLI	A,(D)			;XWD LEVEL, ADDRESS
	HRRI	A,(10)
	MOVEM	A,(2)			;PUT INTO TENEX CHNTAB
	MOVE	A,LEVJMP-1(D)		;JUMP TO CORRECT LEVEL
	MOVEM	A,(10)
	POPJ	P,			;RETURN -- STACK IS OK

LEVJMP:	JSA	17,PS1ACS+17
	JSA	17,PS2ACS+17
	JSA	17,PS3ACS+17


HERE(INTMAP)
	PUSH	P,(P)			;RETURN ADDR
	MOVEI	A,3			;LEVEL 3
	MOVEM	A,-1(P)			;MAKE ANOTHER ARGUMENT
	JRST	PSIMAP			;AND CALL PSIMAP

DSCR


	PSIDISMS(PSICHANNEL, TIME)

	Causes an interrupt to occur on PSICHANNEL every
TIME ms.  (Currently uses a lower fork for this.)

	PSIRUNTM(PSICHANNEL TIME)
	
	Causes an interrrupt to occur on PSICHANNEL after
each TIME increment in the runtime (according to the RUNTM jsys)
of this fork.  TIME must be leq 777777 ms.

	KPSITIME(PSICHANNEL)

	Stops the interrupt from occurring on PSICHANNEL
that was initialized by PSIDISMS or PSIRUNTM.  No-op if none there.

⊗

HERE(PSIDISMS)
	BEGIN PSIDISMS
	MOVE	USER,GOGTAB
	SKIPE	DISPAT(USER)		;TABLES SET UP?
	  JRST	.+3
	PUSH	P,[=128]		;DEFAULT DI BUFFER SIZE
	PUSHJ	P,INTTBL		;INITIALIZE

	MOVE	10,-2(P)		;INTERRUPT CHANNEL	
	SKIPE	1,@TIMFRK(USER)		;GET FORK
	  JSYS	KFORK			;KILL OLD ONE
	MOVNI	1,(10)			;CHANNEL NEGATED
	MOVSI	2,400000	
	LSH	2,(1)			;BIT MASK FOR CHANNEL IN 2
	MOVE	3,-1(P)			;TIME TO DISMISS
	ADD	P,[XWD 20,20]	
	TLNN	P,400000		;OVERFLOW?
	  ERR	<PSITIME:  PDL overflow>
	HRLI	4,PSTACS		;ADDRESS OF ACS
	HRRI	4,-17(P)		;STACK ADDRESS
	BLT	4,(P)			;ONTO STACK
	MOVEM	3,-5(P)			;TIME	
	MOVEM	2,-6(P)			;CHANNEL MASK
	MOVE	1,[XWD 260000,3]	;SET ACS, START FORK AT LOCATION 3
	MOVEI	2,-17(P)		;POINTER TO ACS
	JSYS	CFORK			;CREATE FORK
	  ERR	<PSITIME:  Cannot CFORK>
	MOVEM	1,@TIMFRK(USER)		;SAVE HANDLE
	SUB	P,[XWD 23,23]		;ADJUST STACK, INCLUDING ARGS
	JRST	@3(P)			;RETURN

;TEMPLATE FOR ACS FOR LOWER FORK
PSTACS:	0				;0
	0				;1
	0				;2
	MOVE	1,12			;3
	JSYS	DISMS			;4
	MOVEI	1,-1			;HANDLE TO SUPERIOR FORK
	MOVE	2,11			;CHANNEL MASK
	JSYS	IIC			;CAUSE AN INTERRUPT
	JRST	3			;LOOP
	0				;11 --- CHANNEL MASK GOES HERE
	0				;12 -- TIME TO DISMISS GOES HERE
	BLOCK 5				;ACS 13-17 HERE
	BEND PSIDISMS

HERE(PSIRUNTM)
	BEGIN PSIRUNTM
	MOVE	USER,GOGTAB
	SKIPE	DISPAT(USER)		;TABLES SET UP?
	  JRST	.+3
	PUSH	P,[=128]		;DEFAULT DI BUFFER SIZE
	PUSHJ	P,INTTBL		;INITIALIZE

	MOVE	10,-2(P)		;INTERRUPT CHANNEL	
	SKIPE	1,@TIMFRK(USER)		;GET FORK
	  JSYS	KFORK			;KILL OLD ONE
	MOVNI	1,(10)			;CHANNEL NEGATED
	MOVSI	2,400000	
	LSH	2,(1)			;BIT MASK FOR CHANNEL IN 2
	CAIG	2,777777		;IN LEFT HALF
	   JRST	[HLL 2,[HRRZI 2,]
		 JRST GOTMSK]
	HLR	2,2			;MOVE MASK TO RIGHT HALF
	HLL	2,[HRLZI 2,]
GOTMSK:	MOVE	3,-1(P)			;TIME TO DISMISS
	CAILE	3,777777		;MAXIMUM IS 777777 MS
	  MOVEI	3,777777		;FORCE TO MAXIMUM
	ADD	P,[XWD 20,20]	
	TLNN	P,400000		;OVERFLOW?
	  ERR	<PSITIME:  PDL overflow>
	HRLI	4,PSTACS		;ADDRESS OF ACS
	HRRI	4,-17(P)		;STACK ADDRESS
	BLT	4,(P)			;ONTO STACK
	HRRM	3,-5(P)			;TIME INTERVAL INTO AC 12
	HRRM	3,-13(P)		;TIME INTERVAL INTO AC 4
	MOVEM	2,-2(P)			;CHANNEL MASK INTO AC 15
	PUSH	P,3			;SAVE TIME INTERVAL
	MOVEI	1,400000		;THIS FORK
	JSYS	RUNTM
	POP	P,3			;RESTORE INTERVAL
	ADD	1,3			;NEXT TIME TO INTERRUPT
	MOVEM	1,-17(P)		;STORE IN AC 0

	MOVE	1,[XWD 260000,4]	;SET ACS, START FORK AT LOCATION 4
	MOVEI	2,-17(P)		;POINTER TO ACS
	JSYS	CFORK			;CREATE FORK
	  ERR	<PSITIME:  Cannot CFORK>
	MOVEM	1,@TIMFRK(USER)		;SAVE HANDLE
	SUB	P,[XWD 23,23]		;ADJUST STACK, INCLUDING ARGS
	JRST	@3(P)			;RETURN

;TEMPLATE FOR ACS FOR LOWER FORK
PSTACS:	0				;0 NEXT RUNTM TO INTERRUPT
	0				;1
	0				;2
	0				;3
	MOVEI	1,0			;4 TIME INTERVAL IN THE RIGHT HALF
	JSYS	DISMS			;5 DISMISS FOR THIS LONG
	MOVEI	1,-1			;6 HANDLE TO SUPERIOR FORK
	JSYS	RUNTM			;7 GET RUNTIME IN AC 1
	CAMGE	1,0			;10 IS IT BEYOND THE INTERVAL?
	   JRST	4			;11 NO DISMISS AGAIN
	ADDI	1,0			;12 NEXT PERIOD -- INTERVAL IN RIGHT HALF
	MOVEM	1,0			;13 AND SAVE IT
	MOVEI	1,-1			;14 HANDLE TO SUPERIOR FORK
	HRRZ	2,0			;15 CHANNEL MASK -- EITHER A HRRZ OR HRLZ INSTRUCTION, MODIFIED
	JSYS	IIC			;16 CAUSE AN INTERRUPT
	JRST	4			;17 AND CONTINUE

	BEND PSIRUNTM

HERE(KPSITIME)
	MOVE	USER,GOGTAB
	SKIPN	TIMFRK(USER)		;CHECK SET UP
	  JRST	KPSIRET			;NOT SET UP -- RETURN
	MOVE	10,-1(P)		;CHANNEL NUMBER
	SKIPE	1,@TIMFRK(USER)
	  JSYS	KFORK			;KILL FORK
	SETZM	@TIMFRK(USER)		;REMEMBER NO FORK
KPSIRET:SUB	P,X22
	JRST	@2(P)			;RETURN

HERE(IRPSP1)
HERE(IRPSP2)
HERE(IRPSP3)

BEND IRPPKG

>;TENX
ENDCOM(IRP)