TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES

RELOCA

.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
.GLOBAL	TYPIC,CISET,LSTUF,IMPURI,REALTV
.INSRT MUDDLE >

;MAIN LOOP AND STARTUP

START:	MOVEI	0,0			; SET NO HACKS
	JUMPE	0,START1
	TLNE	0,-1			; SEE IF CHANNEL
	JRST	START1
	MOVE	P,GCPDL
	MOVE	A,0
	PUSH	P,A
	PUSHJ	P,CKVRS			; CHECK VERSION NUMBERS
	POP	P,A
	JRST	FSTART			; GO RESTORE
START1:	MOVEM	0,WHOAMI		; HACK FOR TS FOO linked to TS MUDDLE
	MOVE	PVP,MAINPR		; MAKE SURE WE START IN THE MAIN PROCESS
	JUMPE	0,INITIZ		; MIGHT BE RESTART
	MOVE	P,PSTO+1(PVP)		; SET UP FOR BOOTSTRAP HACK
	MOVE	TP,TPSTO+1(PVP)
INITIZ:	MOVE	PVP,MAINPR
	SKIPN	P			; IF NO CURRENT P
	MOVE	P,PSTO+1(PVP)		; PDL TO GET OFF THE GROUND
	SKIPN	TP			; SAME FOR TP
	MOVE	TP,TPSTO+1(PVP)		; GET A TP TO WORK WITH
	SETZB	R,M			; RESET RSUBR AC'S
	PUSHJ	P,%RUNAM
	 JFCL
	PUSHJ	P,%RJNAM
	PUSHJ	P,TTYOPE		;OPEN THE TTY
	MOVEI	B,MUDSTR
	SKIPE	WHOAMI		; SKIP IF THIS IS MUDDLE
	JRST	NODEMT		; ELSE NO MESSAGE
	SKIPE	DEMFLG		; SKIP IF NOT DEMON
	JRST	NODEMT
	SKIPN	NOTTY			; IF NO TTY, IGNORE
	PUSHJ	P,MSGTYP		;TYPE OUT TO USER

NODEMT:	XCT	MESSAG			;MAYBE PRINT A MESSAGE
	PUSHJ	P,INTINT		;INITIALIZE INTERRUPT HANDLER
	XCT	IPCINI
	PUSHJ	P,PURCLN		; CLEAN UP PURE SHARED AREA
RESTART:				;RESTART A PROCESS
STP:	MOVEI	C,0
	MOVE	PVP,PVSTOR+1
	MOVE	B,TBINIT+1(PVP)		;POINT INTO STACK AT START
	PUSHJ	P,CHUNW			; LEAVE WHILE DOING UNWIND CHECK
	MOVEI	E,TOPLEV
	MOVEI	A,TFALSE		; IN CASE FALLS OFF PROCESS
	MOVEI	B,0
	HRRM	E,-1(TB)
	JRST	CONTIN

	IMQUOTE	TOPLEVEL
TOPLEVEL:
	MCALL	0,LISTEN
	JRST	TOPLEVEL


IMFUNCTION LISTEN,SUBR

	ENTRY
	PUSH	P,[0]		;FLAG: DON'T PRINT ERROR MSG
	JRST	ER1

; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
	IMQUOTE	ERROR

ERROR:	MOVE	B,IMQUOTE ERROR
	PUSHJ	P,IGVAL		; GET VALUE
	GETYP	C,A
	CAIN	C,TSUBR		; CHECK FOR NO CHANGE
	CAIE	B,RERR1		; SKIP IF NOT CHANGED
	JRST	.+2
	JRST	RERR1		; GO TO THE DEFAULT
	PUSH	TP,A		; SAVE VALUE
	PUSH	TP,B
	MOVE	C,AB		; SAVE AB
	MOVEI	D,1		; AND COUNTER
USER1:	PUSH	TP,(C)		; PUSH THEM
	PUSH	TP,1(C)
	ADD	C,[2,,2]	; BUMP
	ADDI	D,1
	JUMPL	C,USER1
	ACALL	D,APPLY		; EVAL USERS ERROR
	JRST	FINIS



IMFUNCTION ERROR%,SUBR,ERROR

RERR1:	ENTRY
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE ERROR,ERROR,INTRUP
	PUSHJ	P,FRMSTK	; PUT ERROR'S FRAME ON STACK
	MOVEI	D,2
	MOVE	C,AB
RERR2:	JUMPGE	C,RERR22
	PUSH	TP,(C)
	PUSH	TP,1(C)
	ADD	C,[2,,2]
	AOJA	D,RERR2
RERR22:	ACALL	D,EMERGENCY
	JRST	RERR

IMQUOTE ERROR
RERR:	ENTRY
	PUSH	P,[-1] 		;PRINT ERROR FLAG

ER1:	MOVE	B,IMQUOTE INCHAN
	PUSHJ	P,ILVAL		; CHECK INPUT CHANNEL IS SOME KIND OF TTY
	GETYP	A,A
	CAIE	A,TCHAN		; SKIP IF IT IS A CHANNEL
	JRST	ER2		; NO, MUST REBIND
	CAMN	B,TTICHN+1
	JRST	NOTINC
ER2:	MOVE	B,IMQUOTE INCHAN
	MOVEI	C,TTICHN	; POINT TO VALU
	PUSHJ	P,PUSH6		; PUSH THE BINDING
	MOVE	B,TTICHN+1	; GET IN CHAN
NOTINC:	SKIPN	DEMFLG		; SKIP IF DEMON
	SKIPE	NOTTY
	JRST	NOECHO
	PUSH	TP,$TCHAN
	PUSH	TP,B
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE T
	MCALL	2,TTYECH	; ECHO INPUT
NOECHO:	MOVE	B,IMQUOTE OUTCHAN
	PUSHJ	P,ILVAL		; GET THE VALUE
	GETYP	A,A
	CAIE	A,TCHAN		; SKIP IF OK CHANNEL
	JRST	ER3		; NOT CHANNEL, MUST REBIND
	CAMN	B,TTOCHN+1
	JRST	NOTOUT
ER3:	MOVE	B,IMQUOTE OUTCHAN
	MOVEI	C,TTOCHN
	PUSHJ	P,PUSH6		; PUSH THE BINDINGS
NOTOUT:	MOVE	B,IMQUOTE OBLIST
	PUSHJ	P,ILVAL	; GET THE VALUE OF OBLIST
	PUSHJ	P,OBCHK		; IS IT A WINNER ?
	SKIPA	A,$TATOM	; NO, SKIP AND CONTINUE
	JRST	NOTOBL		; YES, DO NOT DO REBINDING
	MOVE	B,IMQUOTE OBLIST
	PUSHJ	P,IGLOC
	GETYP	0,A
	CAIN	0,TUNBOU
	JRST	MAKOB		; NO GLOBAL OBLIST, MAKE ONE
	MOVEI	C,(B)		; COPY ADDRESS
	MOVE	A,(C)		; GET THE GVAL
	MOVE	B,(C)+1
	PUSHJ	P,OBCHK		; IS IT A WINNER ?
	JRST	MAKOB		; NO, GO MAKE A NEW ONE
	MOVE	B,IMQUOTE OBLIST
	PUSHJ	P,PUSH6

NOTOBL:	PUSH	TP,[TATOM,,-1]	;FOR BINDING
	PUSH	TP,IMQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,MAKACT
	HRLI	A,TFRAME	; CORRCT TYPE
	PUSH	TP,A
	PUSH	TP,B
	PUSH	TP,[0]
	PUSH	TP,[0]
	MOVE	A,PVSTOR+1		; GET PROCESS
	ADD	A,[PROCID,,PROCID]	; POINT TO ID (ALSO LEVEL)
	PUSH	TP,BNDV
	PUSH	TP,A
	MOVE	A,PROCID(PVP)
	ADDI	A,1		; BUMP ERROR LEVEL
	PUSH	TP,A
	PUSH	TP,PROCID+1(PVP)
	PUSH	P,A

	MOVE	B,IMQUOTE READ-TABLE
	PUSHJ	P,IGVAL
	PUSH	TP,[TATOM,,-1]
	PUSH	TP,IMQUOTE READ-TABLE
	GETYP	C,A		; TO GVAL OF READ-TABLE ON ERROR AND
	CAIE	C,TVEC	; TOP ERRET'S
	JRST	.+4
	PUSH	TP,A
	PUSH	TP,B
	JRST	.+3
	PUSH	TP,$TUNBOUND
	PUSH	TP,[-1]
	PUSH	TP,[0]
	PUSH	TP,[0]

	PUSHJ	P,SPECBIND	;BIND THE CRETANS
	MOVE	A,-1(P)		;RESTORE SWITHC
	JUMPE	A,NOERR		;IF 0, DONT PRINT ERROR MESS
	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE *ERROR*
	MCALL	0,TERPRI
	MCALL	1,PRINC	;PRINT THE MESSAGE
NOERR:	MOVE	C,AB		;GET A COPY OF AB

ERRLP:	JUMPGE	C,LEVPRT	;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
	PUSH	TP,$TAB
	PUSH	TP,C
	MOVEI	B,PRIN1
	GETYP	A,(C)		; GET  ARGS TYPE
	CAIE	A,TATOM
	JRST	ERROK
	MOVE	A,1(C)		; GET ATOM
	HRRO	A,2(A)
	CAME	A,[-1,,ERROBL+1]
	CAMN	A,ERROBL+1	; DONT SKIP IF IN ERROR OBLIST
	MOVEI	B,PRINC		; DONT PRINT TRAILER
ERROK:	PUSH	P,B		; SAVE ROUTINE POINTER
	PUSH	TP,(C)
	PUSH	TP,1(C)
	MCALL	0,TERPRI	; CRLF
	POP	P,B		; GET ROUTINE BACK
	.MCALL	1,(B)
	POP	TP,C
	SUB	TP,[1,,1]
	ADD	C,[2,,2]	;BUMP SAVED AB
	JRST	ERRLP		;AND CONTINUE


LEVPRT:	XCT	INITFL		;LOAD MUDDLE INIT FILE IF FIRST TIME
	MCALL	0,TERPRI
	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE [LISTENING-AT-LEVEL ]
	MCALL	1,PRINC		;PRINT LEVEL
	PUSH	TP,$TFIX	;READY TO PRINT LEVEL
	HRRZ	A,(P)		;GET LEVEL
	SUB	P,[2,,2]	;AND POP STACK
	PUSH	TP,A
	MCALL	1,PRIN1		;PRINT WITHOUT SPACES ETC.
	PUSH	TP,$TATOM	;NOW PROCESS
	PUSH	TP,EQUOTE [ PROCESS ]
	MCALL	1,PRINC		;DONT SLASHIFY SPACES
	MOVE	PVP,PVSTOR+1
	PUSH	TP,PROCID(PVP)	;NOW ID
	PUSH	TP,PROCID+1(PVP)
	MCALL	1,PRIN1
	SKIPN	C,CURPRI
	JRST	MAINLP
	PUSH	TP,$TFIX
	PUSH	TP,C
	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE [ INT-LEVEL ]
	MCALL	1,PRINC
	MCALL	1,PRIN1
	JRST	MAINLP		; FALL INTO MAIN LOOP
	
;ROUTINES FOR ERROR-LISTEN

OBCHK:	GETYP	0,A
	CAIN	0,TOBLS
	JRST	CPOPJ1		; WIN FOR SINGLE OBLIST
	CAIE	0,TLIST		; IF LIST, MAKE SURE EACH IS AN OBLIST
	JRST	CPOPJ		; ELSE, LOSE

	JUMPE	B,CPOPJ		; NIL ,LOSE
	PUSH	TP,A
	PUSH	TP,B
	PUSH	P,[0]		;FLAG FOR DEFAULT CHECKING
	MOVEI	0,1000		; VERY BIG NUMBER FOR CIRCULARITY TEST

OBCHK0:	INTGO
	SOJE	0,OBLOSE	; CIRCULARITY TEST
	HRRZ	B,(TP)		; GET LIST POINTER
	GETYP	A,(B)
	CAIE	A,TOBLS		; SKIP IF WINNER
	JRST	DEFCHK		; CHECK FOR SPECIAL ATOM DEFAULT
	HRRZ	B,(B)
	MOVEM	B,(TP)
	JUMPN	B,OBCHK0
OBWIN:	AOS	(P)-1
OBLOSE:	SUB	TP,[2,,2]
	SUB	P,[1,,1]
	POPJ	P,

DEFCHK:	SKIPN	(P)		; BEEN HERE BEFORE ?
	CAIE	A,TATOM		; OR, NOT AN ATOM ?
	JRST	OBLOSE		; YES, LOSE
	MOVE	A,(B)+1
	CAME	A,MQUOTE DEFAULT
	JRST	OBLOSE		; LOSE
	SETOM	(P)		; SET FLAG
	HRRZ	B,(B)		; CHECK FOR END OF LIST
	MOVEM	B,(TP)
	JUMPN	B,OBCHK0		; NOT THE END, CONTINUE LOOKING
	JRST	OBLOSE		; LOSE FOR DEFAULT AT THE END



PUSH6:	PUSH	TP,[TATOM,,-1]
	PUSH	TP,B
	PUSH	TP,(C)
	PUSH	TP,1(C)
	PUSH	TP,[0]
	PUSH	TP,[0]
	POPJ	P,


MAKOB:	PUSH	TP,INITIAL
	PUSH	TP,INITIAL+1
	PUSH	TP,ROOT
	PUSH	TP,ROOT+1
	MCALL	2,LIST
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OBLIST
	PUSH	TP,A
	PUSH	TP,B
	MCALL	2,SETG
	PUSH	TP,[TATOM,,-1]
	PUSH	TP,IMQUOTE OBLIST
	PUSH	TP,A
	PUSH	TP,B
	PUSH	TP,[0]
	PUSH	TP,[0]
	JRST	NOTOBL


;THIS IS IT FOLKS...THE MAIN LOOP.  READ, EVAL, PRINT

MAINLP:	MOVE	A,$TATOM	;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
	MOVE	B,IMQUOTE REP
	PUSHJ	P,ILVAL		;GET ITS LVAL TO SEE IF REDEFINED
	GETYP	C,A
	CAIE	C,TUNBOUND
	JRST	REPCHK
	MOVE	A,$TATOM	;SEE IF IT HAS GVAL SINCE NO LVAL
	MOVE	B,IMQUOTE REP
	PUSHJ	P,IGVAL
	GETYP	C,A
	CAIN	C,TUNBOUN
	JRST	IREPER
REPCHK:	CAIN	C,TSUBR
	CAIE	B,REPER
	JRST	.+2
	JRST	IREPER
REREPE:	PUSH	TP,A
	PUSH	TP,B
	GETYP	A,-1(TP)
	PUSHJ	P,APLQ
	JRST	ERRREP
	MCALL	1,APPLY		;LOOSER HAS REDEFINED SO CALL HIS
	JRST	MAINLP
IREPER:	PUSH	P,[0]		;INDICATE FALL THROUGH
	JRST	REPERF

ERRREP:	PUSH	TP,[TATOM,,-1]
	PUSH	TP,IMQUOTE REP
	PUSH	TP,$TSUBR
	PUSH	TP,[REPER]
	PUSH	TP,[0]
	PUSH	TP,[0]
	PUSHJ	P,SPECBIN
	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE NON-APPLICABLE-REP
	PUSH	TP,-11(TP)
	PUSH	TP,-11(TP)
	MCALL	2,ERROR
	SUB	TP,[6,,6]
	PUSHJ	P,SSPECS
	JRST	REREPE


IMFUNCTION REPER,SUBR,REP
REPER:	ENTRY	0
	PUSH	P,[1]		;INDICATE DIRECT CALL
REPERF:	MCALL	0,TERPRI
	MCALL	0,READ
	PUSH	TP,A
	PUSH	TP,B
	MOVE	B,IMQUOTE L-INS
	PUSHJ	P,ILVAL		; ASSIGNED?
	GETYP	0,A
	CAIN	0,TLIST

	PUSHJ	P,LSTTOF		; PUT LAST AS FIRST
	MCALL	0,TERPRI
	MCALL	1,EVAL
	MOVE	C,IMQUOTE LAST-OUT
	PUSHJ	P,CISET
	PUSH	TP,A
	PUSH	TP,B
	MOVE	B,IMQUOTE L-OUTS
	PUSHJ	P,ILVAL		; ASSIGNED?
	GETYP	0,A
	CAIN	0,TLIST

	CAME	B,(TP)		; DONT STUFF IT INTO ITSELF
	JRST	STUFIT		; STUFF IT IN
	GETYP	0,-1(TP)
	CAIE	0,TLIST		; IF A LIST THE L-OUTS
STUFIT:	PUSHJ	P,LSTTOF		; PUT LAST AS FIRST
	MCALL	1,PRIN1
	POP	P,C		;FLAG FOR FALL THROUGH OR CALL
	JUMPN	C,FINIS		;IN CASE LOOSER CALLED REP
	JRST	MAINLP

LSTTOF:	SKIPN	A,B
	POPJ	P,

	HRRZ	C,(A)
	JUMPE	C,LSTTO2
	MOVEI	D,(C)		; SAVE PTR TO 2ND ELEMENT
	MOVEI	0,-1		; LET THE LOSER LOSE (HA HA HA)

LSTTO1:	HRRZ	C,(C)		; START SCAN
	JUMPE	C,GOTIT
	HRRZ	A,(A)
	SOJG	0,LSTTO1

GOTIT:	HRRZ	C,(A)
	HLLZS	(A)
	CAIE	D,(C)		; AVOID CIRCULARITY
	HRRM	D,(C)
	HRRM	C,(B)
	MOVE	D,1(B)
	MOVEM	D,1(C)
	GETYP	D,(B)
	PUTYP	D,(C)

LSTTO2:	MOVSI	A,TLIST
	MOVE	C,-1(TP)
	MOVE	D,(TP)
	JRST	LSTUF

;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL

MFUNCTION RETRY,SUBR

	ENTRY
	JUMPGE	AB,RETRY1	; USE MOST RECENT
	CAMGE	AB,[-2,,0]
	JRST	TMA
	GETYP	A,(AB)		; CHECK TYPE
	CAIE	A,TFRAME
	JRST	WTYP1
	MOVEI	B,(AB)		; POINT TO ARG
	JRST	RETRY2
RETRY1:	MOVE	B,IMQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,ILOC		; LOCATIVE TO FRAME
RETRY2:	PUSHJ	P,CHFSWP	; CHECK VALIDITY AND SWAP IF NECESSARY
	HRRZ	0,OTBSAV(B)	; CHECK FOR TOP
	JUMPE	0,RESTAR	; YES RE-ENTER TOP LEVEL
	PUSH	TP,$TTB
	PUSH	TP,B		; SAVE FRAME
	MOVE	B,OTBSAV(B)	; GET PRVIOUS FOR UNBIND HACK
	MOVEI	C,-1(TP)
	PUSHJ	P,CHUNW		; CHECK ANY UNWINDING
	CAME	SP,SPSAV(TB)	; UNBINDING NEEDED?
	PUSHJ	P,SPECSTORE
	MOVE	P,PSAV(TB)	; GET OTHER STUFF
	MOVE	AB,ABSAV(B)
	HLRE	A,AB		; COMPUTE # OF ARGS
	MOVNI	A,-FRAMLN(A)	; MAKE TP POINT PAST FRAME
	HRLI	A,(A)
	MOVE	C,TPSAV(TB)	; COMPUTE TP
	ADD	C,A
	MOVE	TP,C
	MOVE	TB,B		; FIX UP TB
	HRRZ	C,FSAV(TB)	; GET FUNCTION
	CAIL	C,HIBOT
	JRST	(C)		; GO
	GETYP	0,(C)		; RSUBR OR ENTRY?
	CAIE	0,TATOM
	CAIN	0,TRSUBR
	JRST	RETRNT
	MOVS	R,(C)		; SET UP R
	HRRI	R,(C)
	MOVEI	C,0
	JRST	RETRN3

RETRNT:	CAIE	0,TRSUBR
	JRST	RETRN1
	MOVE	R,1(C)
RETRN4:	HRRZ	C,2(C)		; OFFSET
RETRN3:	SKIPL	M,1(R)
	JRST	RETRN5
RETRN7:	ADDI	C,(M)
	JRST	(C)

RETRN5:	MOVEI	D,(M)		; TOTAL OFFSET
	MOVSS	M
	ADD	M,PURVEC+1
	SKIPL	M,1(M)
	JRST	RETRN6
	ADDI	M,(D)
	JRST	RETRN7

RETRN6:	HLRZ	A,1(R)
	PUSH	P,D
	PUSH	P,C
	PUSHJ	P,PLOAD
	JRST	RETRER		; LOSER
	POP	P,C
	POP	P,D
	MOVE	M,B
	JRST	RETRN7

RETRN1:	HRL	C,(C)		; FIX LH
	MOVE	B,1(C)
	PUSH	TP,$TVEC
	PUSH	TP,C
	PUSHJ	P,IGVAL
	GETYP	0,A
	MOVE	C,(TP)
	SUB	TP,[2,,2]
	CAIE	0,TRSUBR
	JRST	RETRN2
	MOVE	R,B
	JRST	RETRN4

RETRN2:	ERRUUO	EQUOTE CANT-RETRY-ENTRY-GONE

RETRER:	ERRUUO	EQUOTE PURE-LOAD-FAILURE


;FUNCTION TO DO ERROR RETURN

IMFUNCTION ERRET,SUBR

	ENTRY
	HLRE	A,AB		; -2*# OF ARGS
	JUMPGE	A,STP		; RESTART PROCESS
	ASH	A,-1		; -# OF ARGS
	AOJE	A,ERRET2	; NO FRAME SUPPLIED
	AOJL	A,TMA
	ADD	AB,[2,,2]
	PUSHJ	P,OKFRT
	JRST	WTYP2
	SUB	AB,[2,,2]
	PUSHJ	P,CHPROC	; POINT TO FRAME SLOT
	JRST	ERRET3
ERRET2:	MOVE	B,IMQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,ILVAL		; GET ITS VALUE
ERRET3:	PUSH	TP,A
	PUSH	TP,B
	MOVEI	B,-1(TP)
	PUSHJ	P,CHFSWP	; CHECK VALIDITY AND SWAP IF NECESSARY
	HRRZ	0,OTBSAV(B)	; TOP LEVEL?
	JUMPE	0,TOPLOS
	PUSHJ	P,CHUNW		; ANY UNWINDING
	JRST	CHFINIS


; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME

IMFUNCTION	FRAME,SUBR
	ENTRY
	SETZB	A,B
	JUMPGE	AB,FRM1		; DEFAULT CASE
	CAMG	AB,[-3,,0]	; SKIP IF OK ARGS
	JRST	TMA
	PUSHJ	P,OKFRT		; A FRAME OR SIMILAR THING?
	JRST	WTYP1

FRM1:	PUSHJ	P,CFRAME	; GO TO INTERNAL
	JRST	FINIS

CFRAME:	JUMPN	A,FRM2		; ARG SUPPLIED?
	MOVE	B,IMQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,ILVAL
	JRST	FRM3
FRM2:	PUSHJ	P,CHPROC	; CHECK FOR PROCESS
	PUSH	TP,A
	PUSH	TP,B
	MOVEI	B,-1(TP)	; POINT TO SLOT
	PUSHJ	P,CHFRM		; CHECK IT
	MOVE	C,(TP)		; GET FRAME BACK
	MOVE	B,OTBSAV(C)	;GET PREVIOUS FRAME
	SUB	TP,[2,,2]
	TRNN	B,-1		; SKIP IF OK
	JRST	TOPLOSE

FRM3:	JUMPN	B,FRM4	; JUMP IF WINNER
	MOVE	B,IMQUOTE THIS-PROCESS
	PUSHJ	P,ILVAL		; GET PROCESS OF INTEREST
	GETYP	A,A		; CHECK IT
	CAIN	A,TUNBOU
	MOVE	B,PVSTOR+1	; USE CURRENT
	MOVEI	A,PVLNT*2+1(B)	; POINT TO DOPE WORDS
	MOVE	B,TBINIT+1(B)	; AND BASE FRAME
FRM4:	HLL	B,OTBSAV(B)	;TIME
	HRLI	A,TFRAME
	POPJ	P,

OKFRT:	AOS	(P)		;ASSUME WINNAGE
	GETYP	0,(AB)
	MOVE	A,(AB)
	MOVE	B,1(AB)
	CAIE	0,TFRAME
	CAIN	0,TENV
	POPJ	P,
	CAIE	0,TPVP
	CAIN	0,TACT
	POPJ	P,
	SOS	(P)
	POPJ	P,

CHPROC:	GETYP	0,A		; TYPE
	CAIE	0,TPVP
	POPJ	P,		; OK
	MOVEI	A,PVLNT*2+1(B)
	CAMN	B,PVSTOR+1	; THIS PROCESS?
	JRST	CHPRO1
	MOVE	B,TBSTO+1(B)
	JRST	FRM4

CHPRO1:	MOVE	B,OTBSAV(TB)
	JRST	FRM4

; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME

MFUNCTION	ARGS,SUBR
	ENTRY	1
	PUSHJ	P,OKFRT		; CHECK FRAME TYPE
	JRST	WTYP1
	PUSHJ	P,CARGS
	JRST	FINIS

CARGS:	PUSHJ	P,CHPROC
	PUSH	TP,A
	PUSH	TP,B
	MOVEI	B,-1(TP)	; POINT TO FRAME SLOT
	PUSHJ	P,CHFRM		; AND CHECK FOR VALIDITY
	MOVE	C,(TP)		; FRAME BACK
	MOVSI	A,TARGS
CARGS1:	GETYP	0,FSAV(C)	; IS THIS A FUNNY ONE
	CAIE	0,TCBLK		; SKIP IF FUNNY
	JRST	.+3		; NO NORMAL
	MOVE	C,OTBSAV(C)	; ASSOCIATE WITH PREVIOUS FRAME
	JRST	CARGS1
	HLR	A,OTBSAV(C)	; TIME IT AND
	MOVE	B,ABSAV(C)	; GET POINTER
	SUB	TP,[2,,2]	; FLUSH CRAP
	POPJ	P,

; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME

MFUNCTION FUNCT,SUBR
	ENTRY	1	; FRAME ARGUMENT
	PUSHJ	P,OKFRT		; CHECK TYPE
	JRST	WTYP1
	PUSHJ	P,CFUNCT
	JRST	FINIS

CFUNCT:	PUSHJ	P,CHPROC
	PUSH	TP,A
	PUSH	TP,B
	MOVEI	B,-1(TP)
	PUSHJ	P,CHFRM		; CHECK IT
	MOVE	C,(TP)		; RESTORE FRAME
	HRRZ	A,FSAV(C)	;FUNCTION POINTER
	CAIL	A,HIBOT
	SKIPA	B,@-1(A)	;NO, GET SUBR'S NAME POINTER
	MOVE	B,(A)+3		;YES, GET RSUBR'S NAME ENTRY
	MOVSI	A,TATOM
	SUB	TP,[2,,2]
	POPJ	P,

BADFRAME:
	ERRUUO	EQUOTE FRAME-NO-LONGER-EXISTS


TOPLOSE:
	ERRUUO	EQUOTE TOP-LEVEL-FRAME




; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED

MFUNCTION	HANG,SUBR

	ENTRY

	JUMPGE	AB,HANG1	; NO PREDICATE
	CAMGE	AB,[-3,,]
	JRST	TMA
REHANG:	MOVE	A,[PUSHJ P,CHKPRH]
	MOVEM	A,ONINT		; CHECK PREDICATE AFTER ANY INTERRUPT
	PUSH	TP,(AB)
	PUSH	TP,1(AB)
HANG1:	ENABLE			;LET OURSELVES BE INTERRUPTED OUT
	PUSHJ	P,%HANG
	DISABLE			;PREVENT INTERRUPTS AT RANDOM TIMES
	SETZM	ONINT
	MOVE	A,$TATOM
	MOVE	B,IMQUOTE T
	JRST 	FINIS


; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE

MFUNCTION	SLEEP,SUBR

	ENTRY

	JUMPGE	AB,TFA
	CAML	AB,[-3,,]
	JRST	SLEEP1
	CAMGE	AB,[-5,,]
	JRST	TMA
	PUSH	TP,2(AB)
	PUSH	TP,3(AB)
SLEEP1:	GETYP	0,(AB)
	CAIE	0,TFIX
	JRST	.+5
	MOVE	B,1(AB)
	JUMPL	B,OUTRNG	;ARG SHOULDNT BE NEGATIVE
	IMULI	B,30.		;CONVERT TO # OF THIRTIETHS OF A SECOND
	JRST	SLEEPR		;GO SLEEP
	CAIE	0,TFLOAT	;IF IT WASNT FIX MAKE SURE IT IS FLOAT
	JRST	WTYP1		;WRONG TYPE ARG
	MOVE	B,1(AB)
	FMPR	B,[30.0]	;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
	MULI	B,400		;KLUDGE TO FIX IT
	TSC	B,B
	ASH	C,(B)-243
	MOVE	B,C		;MOVE THE FIXED NUMBER INTO B
	JUMPL	B,OUTRNG	;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
SLEEPR:	MOVE	A,B
RESLEE:	MOVE	B,[PUSHJ P,CHKPRS]
	CAMGE	AB,[-3,,]
	MOVEM	B,ONINT
	ENABLE
	PUSHJ	P,%SLEEP
	DISABLE
	SETZM	ONINT
	MOVE	A,$TATOM
	MOVE	B,IMQUOTE T
	JRST	FINIS

CHKPRH:	PUSH	P,B
	MOVEI	B,HANGP
	JRST	.+3

CHKPRS:	PUSH	P,B
	MOVEI	B,SLEEPP
	HRRM	B,LCKINT
	SETZM	ONINT		; TURN OFF FEATURE FOR NOW
	POP	P,B
	POPJ	P,

HANGP:	SKIPA	B,[REHANG]
SLEEPP:	MOVEI	B,RESLEE
	PUSH	P,B
	PUSH	P,A
	DISABLE
	PUSH	TP,(TB)
	PUSH	TP,1(TB)
	MCALL	1,EVAL
	GETYP	0,A
	CAIE	0,TFALSE
	JRST	FINIS
	POP	P,A
	POPJ	P,

MFUNCTION	VALRET,SUBR
; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS

	ENTRY	1
	GETYP	A,(AB)		; GET TYPE OF ARGUMENT
	CAIN	A,TFIX		; FIX?
	 JRST	VALRT1
	CAIE	A,TCHSTR	; IS IT A CHR STRING?
	JRST	WTYP1		; NO...ERROR WRONG TYPE
	PUSHJ	P,CSTACK	; COPY THE CHR STRING TO THE STACK
					; CSTACK IS IN ATOMHK
	MOVEI	B,0		; ASCIZ TERMINATOR
	EXCH	B,(P)		; STORE AND RETRIEVE COUNT

; CALCULATE THE BEGINNING ADDR OF THE STRING
	MOVEI	A,-1(P)		; GET ADDR OF TOP OF STACK
	SUBI	A,-1(B)		; GET STARTING ADDR
	PUSHJ	P,%VALRE	; PASS UP TO MONITOR
	JRST	IFALSE		; IF HE RETURNS, RETURN FALSE

VALRT1:	MOVE	A,1(AB)
	PUSHJ	P,%VALFI
	JRST	IFALSE

MFUNCTION	LOGOUT,SUBR

; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
	ENTRY	0
	PUSHJ	P,%TOPLQ	; SKIP IF AT TOP LEVEL
	JRST	IFALSE
	PUSHJ	P,CLOSAL
	PUSHJ	P,%LOGOUT	; TRY TO FLUSH
	JRST	IFALSE		; COULDN'T DO IT...RETURN FALSE

; FUNCTS TO GET UNAME AND JNAME

; GET XUNAME (REAL UNAME)
MFUNCTION XUNAME,SUBR

	ENTRY	0

	PUSHJ	P,%RXUNA
	 JRST	RSUJNM
	JRST	FINIS		; 10X ROUTINES SKIP

MFUNCTION UNAME,SUBR

	ENTRY	0

	PUSHJ	P,%RUNAM
	 JRST	RSUJNM
	JRST	FINIS

; REAL JNAME
MFUNCTION XJNAME,SUBR

	ENTRY	0

	PUSHJ	P,%RXJNA
	JRST	RSUJNM

MFUNCTION JNAME,SUBR

	ENTRY	0

	PUSHJ	P,%RJNAM
	JRST	RSUJNM

; FUNCTION TO SET AND READ GLOBAL SNAME

MFUNCTION SNAME,SUBR

	ENTRY

	JUMPGE	AB,SNAME1
	CAMG	AB,[-3,,]
	JRST	TMA
	GETYP	A,(AB)		; ARG MUST BE STRING
	CAIE	A,TCHSTR
	JRST	WTYP1
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE SNM
	PUSH	TP,(AB)
	PUSH	TP,1(AB)
	MCALL	2,SETG
	JRST	FINIS

SNAME1:	MOVE	B,IMQUOTE SNM
	PUSHJ	P,IDVAL1
	GETYP	0,A
	CAIN	0,TCHSTR
	JRST	FINIS
	MOVE	A,$TCHSTR
	MOVE	B,CHQUOTE
	JRST	FINIS

RSUJNM:	PUSHJ	P,6TOCHS	; CONVERT IT
	JRST	FINIS


SGSNAM:	MOVE	B,IMQUOTE SNM
	PUSHJ	P,IDVAL1
	GETYP	0,A
	CAIE	0,TCHSTR
	JRST	SGSN1

	PUSH	TP,A
	PUSH	TP,B
	PUSHJ	P,STRTO6
	POP	P,A
	SUB	TP,[2,,2]
	JRST	.+2

SGSN1:	MOVEI	A,0
	PUSHJ	P,%SSNAM	; SET SNAME IN SYSTEM
	POPJ	P,



;THIS SUBROUTINE ALLOCATES A NEW PROCESS
;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.

ICR:	PUSH	P,A
	PUSH	P,B
	MOVEI	A,PVLNT		;SETUP CALL TO VECTOR FOR PVP
	PUSHJ	P,IVECT		;GOBBLE A VECTOR
	HRLI	C,PVBASE	;SETUP A BLT POINTER
	HRRI	C,(B)		;GET INTO ADDRESS
	BLT	C,PVLNT*2-1(B)	;COPY A PROTOTYPE INTO NEW PVP
	MOVSI	C,400000+SPVP+.VECT.	;SET SPECIAL TYPE
	MOVEM	C,PVLNT*2(B)	;CLOBBER IT IN
	PUSH	TP,A		;SAVE THE RESULTS OF VECTOR
	PUSH	TP,B

	PUSH	TP,$TFIX	;GET A UNIFORM VECTOR
	POP	P,B
	PUSH	TP,B
	MCALL	1,UVECTOR
	ADD	B,[PDLBUF-2,,-1]	;FUDGE WITH BUFFER
	MOVE	C,(TP)		;REGOBBLE PROCESS POINTER
	MOVEM	B,PSTO+1(C)	;STORE IN ALL HOMES
	MOVEM	B,PBASE+1(C)


	POP	P,A		;PREPARE TO CREATE A TEMPORARY PDL
	PUSHJ	P,IVECT		;GET THE TEMP PDL
	ADD	B,[PDLBUF,,0]	;PDL GROWTH HACK
	MOVE	C,(TP)		;RE-GOBBLE NEW PVP
	SUB	B,[1,,1]	;FIX FOR STACK
	MOVEM	B,TPBASE+1(C)

;SETUP INITIAL BINDING

	PUSH	B,$TBIND
	MOVEM	B,SPBASE+1(C)	;SAVE AS BASE OF SP
	MOVEM	B,SPSTO+1(C)	;AND CURRENT THEREOF
	MOVEM	B,CURFCN+1(C)	; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
	PUSH	B,IMQUOTE THIS-PROCESS
	PUSH	B,$TPVP	;GIVE IT PROCESS AS VALUE
	PUSH	B,C
	ADD	B,[2,,2]	;FINISH FRAME
	MOVEM	B,TPSTO+1(C)	;MAKE THIS THE CURRENT STACK POINTER
	MOVEM	C,PVPSTO+1(C)	;SAVE THE NEW PVP ITSELF
	AOS	A,IDPROC		;GOBBLE A UNIQUE PROCESS I.D.
	MOVEM	A,PROCID+1(C)	;SAVE THAT ALSO
	AOS	A,PTIME		; GET A UNIQUE BINDING ID
	MOVEM	A,BINDID+1(C)

	MOVSI	A,TPVP		;CLOBBER THE TYPE
	MOVE	B,(TP)		;AND POINTER TO PROCESS
	SUB	TP,[2,,2]
	POPJ	P,

;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A

IVECT:	PUSH	TP,$TFIX
	PUSH	TP,A
	MCALL	1,VECTOR	;GOBBLE THE VECTOR
	POPJ	P,


;SUBROUTINE TO SWAP A PROCESS IN
;CALLED WITH JSP A,SWAP AND NEW PVP IN B

SWAP:				;FIRST STORE ALL THE ACS

	MOVE	PVP,PVSTOR+1
	MOVE	SP,$TSP		; STORE SPSAVE
	MOVEM	SP,SPSTO(PVP)
	MOVE	SP,SPSTOR+1
	IRP	A,,[SP,AB,TB,TP,P,M,R,FRM]
	MOVEM	A,A!STO+1(PVP)
	TERMIN

	SETOM	1(TP)		; FENCE POST MAIN STACK
	MOVEM	TP,TPSAV(TB)	; CORRECT FRAME
	SETZM	PSAV(TB)	; CLEAN UP CURRENT FRAME
	SETZM	SPSAV(TB)
	SETZM	PCSAV(TB)

	MOVE	E,PVP	;RETURN OLD PROCESS IN E
	MOVE	PVP,D	;AND MAKE NEW ONE BE D
	MOVEM	PVP,PVSTOR+1

SWAPIN:
	;NOW RESTORE NEW PROCESSES AC'S

	MOVE	PVP,PVSTOR+1
	IRP	A,,[AB,TB,SP,TP,P,M,R,FRM]
	MOVE	A,A!STO+1(PVP)
	TERMIN

	SETZM	SPSTO(PVP)
	MOVEM	SP,SPSTOR+1
	JRST	(C)		;AND RETURN




;SUBRS ASSOCIATED WITH TYPES

;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
;TYPECODE.
MFUNCTION TYPE,SUBR

	ENTRY	1
	GETYP	A,(AB)		;TYPE INTO A
TYPE1:	PUSHJ	P,ITYPE		;GO TO INTERNAL
	JUMPN	B,FINIS		;GOOD RETURN
TYPERR:	ERRUUO	EQUOTE TYPE-UNDEFINED

CITYPE:	GETYP	A,A		; GET TYPE FOR COMPILER CALL
ITYPE:	LSH	A,1		;TIMES 2
	HRLS	A  		;TO BOTH SIDES
	ADD	A,TYPVEC+1	;GET ACTUAL LOCATION
	JUMPGE	A,TYPERR	;LOST, TYPE OUT OF BOUNDS
	MOVE	B,1(A)		;PICKUP TYPE
	HLLZ	A,(A)
	POPJ	P,

; PREDICATE -- IS OBJECT OF TYPE SPECIFIED

MFUNCTION %TYPEQ,SUBR,[TYPE?]

	ENTRY

	MOVE	D,AB		; GET ARGS
	ADD	D,[2,,2]
	JUMPGE	D,TFA
	MOVE	A,(AB)
	HLRE	C,D
	MOVMS	C
	ASH	C,-1		; FUDGE
	PUSHJ	P,ITYPQ		; GO INTERNAL
	JFCL
	JRST	FINIS

ITYPQ:	GETYP	A,A		; OBJECT
	PUSHJ	P,ITYPE
TYPEQ0:	SOJL	C,CIFALS
	GETYP	0,(D)
	CAIE	0,TATOM		; Type name must be an atom
	JRST	WRONGT
	CAMN	B,1(D)		; Same as the OBJECT?
	JRST	CPOPJ1		; Yes, return type name
	ADD	D,[2,,2]
	JRST	TYPEQ0		; No, continue comparing

CIFALS:	MOVEI	B,0
	MOVSI	A,TFALSE
	POPJ	P,

CTYPEQ:	SOJE	A,CIFALS	; TREAT NO ARGS AS FALSE
	MOVEI	D,1(A)		; FIND BASE OF ARGS
	ASH	D,1
	HRLI	D,(D)
	SUBM	TP,D		; D POINTS TO BASE
	MOVE	E,D		; SAVE FOR TP RESTORE
	ADD	D,[3,,3]	; FUDGE
	MOVEI	C,(A)		; NUMBER OF TYPES
	MOVE	A,-2(D)
	PUSHJ	P,ITYPQ
	JFCL		; IGNORE SKIP FOR NOW
	MOVE	TP,E		; SET TP BACK
	JUMPL	B,CPOPJ1	; SKIP
	POPJ	P,

; Entries to get type codes for types for fixing up RSUBRs and assembling

MFUNCTION %TYPEC,SUBR,[TYPE-C]

	ENTRY

	JUMPGE	AB,TFA
	GETYP	0,(AB)
	CAIE	0,TATOM
	JRST	WTYP1
	MOVE	B,1(AB)
	CAMGE	AB,[-3,,0]	; skip if only type name given
	JRST	GTPTYP
	MOVE	C,IMQUOTE ANY

TYPEC1:	PUSHJ	P,CTYPEC	; go to internal
	JRST	FINIS

GTPTYP:	CAMGE	AB,[-5,,0]
	JRST	TMA
	GETYP	0,2(AB)
	CAIE	0,TATOM
	JRST	WTYP2
	MOVE	C,3(AB)
	JRST	TYPEC1

CTYPEC:	PUSH	P,C		; save primtype checker
	PUSHJ	P,TYPFND	; search type vector
	JRST	CTPEC2		; create the poor loser
	POP	P,B
	CAMN	B,IMQUOTE ANY
	JRST	CTPEC1
	CAMN	B,IMQUOTE TEMPLATE
	JRST	TCHK
	PUSH	P,D
	HRRZ	A,(A)
	ANDI	A,SATMSK
	PUSH	P,A
	PUSHJ	P,TYPLOO
	HRRZ	0,(A)
	ANDI	0,SATMSK
	CAME	0,(P)
	JRST	TYPDIF
	MOVE	D,-1(P)
	SUB	P,[2,,2]
CTPEC1:	MOVEI	B,(D)
	MOVSI	A,TTYPEC
	POPJ	P,
TCHK:	PUSH	P,D		; SAVE TYPE
	MOVE	A,D		; GO TO SAT
	PUSHJ	P,SAT
	CAIG	A,NUMSAT	; SKIP IF A TEMPLATE
	JRST	TYPDIF
	POP	P,D		; RESTORE TYPE
	JRST	CTPEC1

CTPEC2:	POP	P,C		; GET BACK PRIMTYPE
	SUBM	M,(P)
	PUSH	TP,$TATOM
	PUSH	TP,B
	CAMN	C,IMQUOTE ANY
	JRST	CTPEC3
	PUSH	TP,$TATOM
	PUSH	TP,C
	MCALL	2,NEWTYPE		; CREATE THE POOR GUY
	MOVE	C,IMQUOTE ANY
	SUBM	M,(P)		; UNRELATIVIZE
	JRST	CTYPEC

CTPEC3:	HRRZ	0,FSAV(TB)
	CAIE	0,%TYPEC
	CAIN	0,%TYPEW
	JRST	TYPERR

	MCALL	1,%TYPEC
	JRST	MPOPJ

MFUNCTION %TYPEW,SUBR,[TYPE-W]

	ENTRY

	JUMPGE	AB,TFA
	GETYP	0,(AB)
	CAIE	0,TATOM
	JRST	WTYP1
	MOVEI	D,0
	MOVE	C,IMQUOTE ANY
	MOVE	B,1(AB)
	CAMGE	AB,[-3,,0]
	JRST	CTYPW1

CTYPW3:	PUSHJ	P,CTYPEW
	JRST	FINIS

CTYPW1:	GETYP	0,2(AB)
	CAIE	0,TATOM
	JRST	WTYP2
	CAMGE	AB,[-5,,0]	; JUMP IF RH IS GIVEN
	JRST	CTYPW2
CTYPW5:	MOVE	C,3(AB)
	JRST	CTYPW3

CTYPW2:	CAMGE	AB,[-7,,0]
	JRST	TMA
	GETYP	0,4(AB)
	CAIE	0,TFIX
	JRST	WRONGT
	MOVE	D,5(AB)
	JRST	CTYPW5

CTYPEW:	PUSH	P,D
	PUSHJ	P,CTYPEC	; GET CODE IN B
	POP	P,B
	HRLI	B,(D)
	MOVSI	A,TTYPEW
	POPJ	P,

MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]

	ENTRY	1

	GETYP	0,(AB)
	CAIE	0,TATOM
	JRST	WTYP1
	MOVE	B,1(AB)

	PUSHJ	P,CVTYPE
	JFCL
	JRST	FINIS

CVTYPE:	PUSHJ	P,TYPFND		; LOOK IT UP
	JRST	PFALS

	MOVEI	B,(D)
	MOVSI	A,TTYPEC
	JRST	CPOPJ1

PFALS:	MOVEI	B,0
	MOVSI	A,TFALSE
	POPJ	P,
	
;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS

STBL:	REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE

LOC STBL

IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
[PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
IRP B,C,[A]
LOC STBL+S!B
IRP X,Y,[C]
IFSE [Y],SETZ IMQUOTE X
IFSN [Y],SETZ MQUOTE X
.ISTOP
TERMIN
.ISTOP

TERMIN
TERMIN

LOC STBL+NUMSAT+1


MFUNCTION TYPEPRIM,SUBR

	ENTRY	1
	GETYP	A,(AB)
	CAIE	A,TATOM
	JRST	NOTATOM
	MOVE	B,1(AB)
	PUSHJ	P,CTYPEP
	JRST	FINIS

CTYPEP:	PUSHJ	P,TYPLOO	; CONVERT ATOM TO CODE
	HRRZ	A,(A)		; SAT TO A
	ANDI	A,SATMSK
	JRST	PTYP1

MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]

	ENTRY	1

	GETYP	A,(AB)
	CAIE	A,TATOM
	JRST	WTYP1
	MOVE	B,1(AB)
	PUSHJ	P,CPRTYC
	JRST	FINIS

CPRTYC:	PUSHJ	P,TYPLOO
	MOVE	B,(A)
	ANDI	B,SATMSK
	MOVSI	A,TSATC
	POPJ	P,


IMFUNCTION PRIMTYPE,SUBR

	ENTRY	1

	MOVE	A,(AB)		;GET TYPE
	PUSHJ	P,CPTYPE
	JRST	FINIS

CPTYPE:	GETYP	A,A
	PUSHJ	P,SAT		;GET SAT
PTYP1:	JUMPE	A,TYPERR
	MOVE	B,IMQUOTE TEMPLATE
	CAIG	A,NUMSAT	; IF BIG SAT, THEN TEMPLATE
	MOVE	B,@STBL(A)
	MOVSI	A,TATOM
	POPJ	P,


; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT

IMFUNCTION RSUBR,SUBR
	ENTRY	1

	GETYP	A,(AB)
	CAIE	A,TVEC		; MUST BE VECTOR
	JRST	WTYP1
	MOVE	B,1(AB)		; GET IT
	GETYP	A,(B)		; CHECK 1ST ELEMENTS TYPE
	CAIN	A,TPCODE	; PURE CODE
	JRST	.+3
	CAIE	A,TCODE
	JRST	NRSUBR
	HLRM	B,(B)		; CLOBEER SPECIAL COUNT FIELD
	MOVSI	A,TRSUBR
	JRST	FINIS

NRSUBR:	ERRUUO	EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE

; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR

IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]

	ENTRY	2

	GETYP	0,(AB)		; TYPE OF ARG
	CAIE	0,TVEC		; BETTER BE VECTOR
	JRST	WTYP1
	GETYP	0,2(AB)
	CAIE	0,TFIX
	JRST	WTYP2
	MOVE	B,1(AB)		; GET VECTOR
	CAML	B,[-3,,0]
	JRST	BENTRY
	GETYP	0,(B)		; FIRST ELEMENT
	CAIE	0,TRSUBR
	JRST	MENTR1
MENTR2:	GETYP	0,2(B)
	CAIE	0,TATOM
	JRST	BENTRY
	MOVE	C,3(AB)
	HRRM	C,2(B)		; OFFSET INTO VECTOR
	HLRM	B,(B)
	MOVSI	A,TENTER
	JRST	FINIS

MENTR1:	CAIE	0,TATOM
	JRST	BENTRY
	MOVE	B,1(B)		; GET ATOM
	PUSHJ	P,IGVAL		; GET VAL
	GETYP	0,A
	CAIE	0,TRSUBR
	JRST	BENTRY
	MOVE	C,1(AB)		; RESTORE B
	MOVEM	A,(C)
	MOVEM	B,1(C)
	MOVE	B,C
	JRST	MENTR2

BENTRY:	ERRUUO	EQUOTE BAD-VECTOR
	
; SUBR TO GET ENTRIES OFFSET

MFUNCTION LENTRY,SUBR,[ENTRY-LOC]

	ENTRY	1

	GETYP	0,(AB)
	CAIE	0,TENTER
	JRST	WTYP1
	MOVE	B,1(AB)
	HRRZ	B,2(B)
	MOVSI	A,TFIX
	JRST	FINIS

; RETURN FALSE

RTFALS:	MOVSI	A,TFALSE
	MOVEI	B,0
	POPJ	P,

;SUBROUTINE CALL FOR RSUBRs
RCALL:	SUBM	M,(P)		;CALCULATE PC's OFFSET IN THE RSUBR
	HRLI	0,400000	; DONT LOSE IN MULTI SEG MODE

	PUSHJ	P,@0		;GO TO THE PROPER SUBROUTINE
	SUBM	M,(P)		;RECONSTITUTE THE RSUBR's PC
	POPJ	P,



;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME
;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND

MFUNCTION CHTYPE,SUBR

	ENTRY	2
	GETYP	A,2(AB)		;FIRST CHECK THAT ARG 2 IS AN ATOM
	CAIE	A,TATOM	
	JRST	NOTATOM
	MOVE	B,3(AB)		;AND TYPE NAME
	PUSHJ	P,TYPLOO		;GO LOOKUP TYPE
TFOUND:	HRRZ	B,(A)		;GOBBLE THE SAT
	TRNE	B,CHBIT		; SKIP IF CHTYPABLE
	JRST	CANTCH
	TRNE	B,TMPLBT	; TEMPLAT
	HRLI	B,-1
	AND	B,[-1,,SATMSK]
	GETYP	A,(AB)		;NOW GET TYPE TO HACK
	PUSHJ	P,SAT		;FIND OUT ITS SAT
	JUMPE	A,TYPERR	;COMPLAIN
	CAILE	A,NUMSAT
	JRST	CHTMPL		; JUMP IF TEMPLATE DATA
	CAIE	A,(B)		;DO THEY AGREE?
	JRST	TYPDIF		;NO, COMPLAIN
CHTMP1:	MOVSI	A,(D)		;GET NEW TYPE
	HRR	A,(AB)		; FOR DEFERRED GOODIES
	JUMPL	B,CHMATC	; CHECK IT
	MOVE	B,1(AB)		;AND VALUE
	JRST	FINIS

CHTMPL:	MOVE	E,1(AB)		; GET ARG
	HLRZ	A,(E)
	ANDI	A,SATMSK
	MOVE	0,3(AB)		; SEE IF TO "TEMPLATE"
	CAMN	0,IMQUOTE TEMPLATE
	JRST	CHTMP1
	TLNN	E,-1		; SKIP IF RESTED
	CAIE	A,(B)
	JRST	TYPDIF
	JRST	CHTMP1

CHMATC:	PUSH	TP,A
	PUSH	TP,1(AB)	; SAVE GOODIE
	MOVSI	A,TATOM
	MOVE	B,3(AB)
	MOVSI	C,TATOM
	MOVE	D,IMQUOTE DECL
	PUSHJ	P,IGET		; FIND THE DECL
	PUSH	TP,A
	PUSH	TP,B
	MOVE	C,(AB)
	MOVE	D,1(AB)		; NOW GGO TO MATCH
	PUSHJ	P,TMATCH
	JRST	CHMAT1
	SUB	TP,[2,,2]
CHMAT2:	POP	TP,B
	POP	TP,A
	JRST	FINIS

CHMAT1:	POP	TP,B
	POP	TP,A
	MOVE	C,-1(TP)
	MOVE	D,(TP)
	PUSHJ	P,TMATCH
	JRST	TMPLVI
	JRST	CHMAT2

TYPLOO:	PUSHJ	P,TYPFND
	ERRUUO	EQUOTE BAD-TYPE-NAME
	POPJ	P,

TYPFND:	HLRE	A,B		; FIND DOPE WORDS
	SUBM	B,A		; A POINTS TO IT
	HRRE	D,(A)		; TYPE-CODE TO D
	JUMPE	D,CPOPJ
	ANDI	D,TYPMSK	; FLUSH FUNNY BITS
	MOVEI	A,(D)
	ASH	A,1
	HRLI	A,(A)
	ADD	A,TYPVEC+1
CPOPJ1:	AOS	(P)
	POPJ	P,


REPEAT 0,[	
	MOVE	A,TYPVEC+1	;GOBBLE DOWN TYPE VECTOR
	MOVEI	D,0		;INITIALIZE TYPE COUNTER
TLOOK:	CAMN	B,1(A)		;CHECK THIS ONE
	JRST	CPOPJ1
	ADDI	D,1		;BUMP COUNTER
	AOBJP	A,.+2		;COUTN DOWN ON VECTOR
	AOBJN	A,TLOOK
	POPJ	P,
CPOPJ1:	AOS	(P)
	POPJ	P,
]

TYPDIF:	ERRUUO	EQUOTE STORAGE-TYPES-DIFFER


TMPLVI:	ERRUUO	EQUOTE DECL-VIOLATION


; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE

MFUNCTION NEWTYPE,SUBR

	ENTRY

	HLRZ	0,AB		; CHEC # OF ARGS
	CAILE	0,-4		; AT LEAST 2
	JRST	TFA
	CAIGE	0,-6
	JRST	TMA		; NOT MORE THAN 3
	GETYP	A,(AB)		; GET 1ST ARGS TYPE (SHOULD BE ATOM)
	GETYP	C,2(AB)		; SAME WITH SECOND
	CAIN	A,TATOM		; CHECK
	CAIE	C,TATOM
	JRST	NOTATOM

	MOVE	B,3(AB)		; GET PRIM TYPE NAME
	PUSHJ	P,TYPLOO	; LOOK IT UP
	HRRZ	A,(A)		; GOBBLE SAT
	ANDI	A,SATMSK
	HRLI	A,TATOM		; MAKE NEW TYPE
	PUSH	P,A		; AND SAVE
	MOVE	B,1(AB)		; SEE IF PREV EXISTED
	PUSHJ	P,TYPFND
	JRST	NEWTOK		; DID NOT EXIST BEFORE
	MOVEI	B,2(A)		; FOR POSSIBLE TMPLAT BIT
	HRRZ	A,(A)		; GET SAT
	HRRZ	0,(P)		; AND PROPOSED
	ANDI	A,SATMSK
	ANDI	0,SATMSK
	CAIN	0,(A)		; SKIP IF LOSER
	JRST	NEWTFN		; O.K.

	ERRUUO	EQUOTE TYPE-ALREADY-EXISTS

NEWTOK:	POP	P,A
	MOVE	B,1(AB)		; NEWTYPE NAME
	PUSHJ	P,INSNT		; MUNG IN NEW TYPE

NEWTFN:	CAML	AB,[-5,,]	; SKIP IF TEMPLAT SUPPLIED
	JRST	NEWTF1
	MOVEI	0,TMPLBT	; GET THE BIT
	IORM	0,-2(B)		; INTO WORD
	MOVE	A,(AB)		; GET TYPE NAME
	MOVE	B,1(AB)
	MOVSI	C,TATOM
	MOVE	D,IMQUOTE DECL
	PUSH	TP,4(AB)	; GET TEMLAT
	PUSH	TP,5(AB)
	PUSHJ	P,IPUT
NEWTF1:	MOVE	A,(AB)
	MOVE	B,1(AB)		; RETURN NAME
	JRST	FINIS

; SET  UP GROWTH FIELDS

IGROWT:	SKIPA	A,[111100,,(C)]
IGROWB:	MOVE	A,[001100,,(C)]
	HLRE	B,C
	SUB	C,B		; POINT TO DOPE WORD
	MOVE	B,TYPIC	; INDICATED GROW BLOCK
	DPB	B,A
	POPJ	P,

INSNT:	PUSH	TP,A
	PUSH	TP,B		; SAVE NAME OF NEWTYPE
	MOVE	C,TYPBOT+1	; CHECK GROWTH NEED
	CAMGE	C,TYPVEC+1
	JRST	ADDIT		; STILL ROOM
GAGN:	PUSHJ	P,IGROWB	; SETUP BOTTOM GROWTH
	SKIPE	C,EVATYP+1
	PUSHJ	P,IGROWT	; SET UP TOP GROWTH
	SKIPE	C,APLTYP+1
	PUSHJ	P,IGROWT
	SKIPE	C,PRNTYP+1
	PUSHJ	P,IGROWT
	MOVE	C,[11.,,5]	; SET UP INDICATOR FOR AGC
	PUSHJ	P,AGC		; GROW THE WORLD
	AOJL	A,GAGN		; BAD AGC LOSSAGE
	MOVE	0,[-101,,-100]
	ADDM	0,TYPBOT+1	; FIX UP POINTER

ADDIT:	MOVE	C,TYPVEC+1
	SUB	C,[2,,2]	; ALLOCATE ROOM
	MOVEM	C,TYPVEC+1
	HLRE	B,C		; PREPARE TO BLT
	SUBM	C,B		; C POINTS DOPE WORD END
	HRLI	C,2(C)		; GET BLT AC READY
	BLT	C,-3(B)
	POP	TP,-1(B)	; CLOBBER IT IN
	POP	TP,-2(B)
	HLRE	C,TYPVEC+1	; GET CODE
	MOVNS	C
	ASH	C,-1
	SUBI	C,1
	MOVE	D,-1(B)		; B HAS POINTER TO TYPE VECTOR DOPE WORDS
	MOVEI	0,(D)
	CAIG	0,HIBOT		; IS ATOM PURE?
	 JRST	ADDNOI		; NO, SO NO HACKING REQUIRED
	PUSH	P,C
	MOVE	B,D
	PUSHJ	P,IMPURIF	; DO IMPURE OF ATOM
	MOVE	C,TYPVEC+1
	HLRE	B,C
	SUBM	C,B		; RESTORE B
	POP	P,C
	MOVE	D,-1(B)		; RESTORE D
ADDNOI:	HLRE	A,D
	SUBM	D,A
	TLO	C,400000
	HRRM	C,(A)		; INTO "GROWTH" FIELD
	POPJ	P,


; Interface to interpreter for setting up tables associated with
;	template data structures.
;	A/	<-name of type>-
;	B/	<-length ins>-
;	C/	<-uvector of garbage collector code or 0>
;	D/	<-uvector of GETTERs>-
;	E/	<-uvector of PUTTERs>-

CTMPLT:	SUBM	M,(P)		; could possibly gc during this stuff
	PUSH	TP,$TATOM	; save name of type
	PUSH	TP,A
	PUSH	P,B		; save length instr
	HLRE	A,TD.LNT+1	; check for template slots left?
	HRRZ	B,TD.LNT+1
	SUB	B,A		; point to dope words
	HLRZ	B,1(B)		; get real length
	ADDI	A,-2(B)
	JUMPG	A,GOODRM	; jump if ok

	PUSH	TP,$TUVEC	; save getters and putters
	PUSH	TP,C
	PUSH	TP,$TUVEC	; save getters and putters
	PUSH	TP,D
	PUSH	TP,$TUVEC
	PUSH	TP,E
	MOVEI	A,10-2(B)	; grow it 10 by copying remember d.w. length
	PUSH	P,A		; save new length
	PUSHJ	P,CAFRE1	; get frozen uvector
	ADD	B,[10,,10]	; rest it down some
	HRL	C,TD.LNT+1	; prepare to BLT in
	MOVEM	B,TD.LNT+1	; and save as new length vector
	HRRI	C,(B)		; destination
	ADD	B,(P)		; final destination address
	BLT	C,-12(B)
	MOVE	A,(P)		; length for new getters
	PUSHJ	P,CAFRE1
	HRL	C,TD.GET+1	; get old for copy
	MOVEM	B,TD.GET+1
	PUSHJ	P,DOBLTS	; go fixup new uvector
	MOVE	A,(P)		; finally putters
	PUSHJ	P,CAFRE1
	HRL	C,TD.PUT+1
	MOVEM	B,TD.PUT+1
	PUSHJ	P,DOBLTS	; go fixup new uvector
	MOVE	A,(P)		; finally putters
	PUSHJ	P,CAFRE1
	HRL	C,TD.AGC+1
	MOVEM	B,TD.AGC+1
	PUSHJ	P,DOBLTS	; go fixup new uvector
	SUB	P,[1,,1]	; flush stack craft
	MOVE	E,(TP)
	MOVE	D,-2(TP)
	MOVE	C,-4(TP)			;GET TD.AGC
	SUB	TP,[6,,6]

GOODRM:	MOVE	B,TD.LNT+1	; move down to fit new guy
	SUB	B,[1,,1]	; will always win due to prev checks
	MOVEM	B,TD.LNT+1
	HRLI	B,1(B)
	HLRE	A,TD.LNT+1
	MOVNS	A
	ADDI	A,-1(B)		; A/ final destination
	BLT	B,-1(A)
	POP	P,(A)		; new length ins munged in
	HLRE	A,TD.LNT+1
	MOVNS	A		; A/ offset for other guys
	PUSH	P,A		; save it
	ADD	A,TD.GET+1	; point for storing uvs of ins
	MOVEM	D,-1(A)
	MOVE	A,(P)
	ADD	A,TD.PUT+1
	MOVEM	E,-1(A)		; store putter also
	MOVE	A,(P)
	ADD	A,TD.AGC+1
	MOVEM	C,-1(A)		; store putter also
	POP	P,A		; compute primtype
	ADDI	A,NUMSAT
	PUSH	P,A
	MOVE	B,(TP)		; ready to mung type vector
	SUB	TP,[2,,2]
	PUSHJ	P,TYPFND	; CHECK TO SEE WHETHER TEMPLATE EXISTS
	JRST	NOTEM
	POP	P,C		; GET SAT
	HRRM	C,(A)
	JRST	MPOPJ
NOTEM:	POP	P,A		; RESTORE SAT
	HRLI	A,TATOM		; GET TYPE
	PUSHJ	P,INSNT		; INSERT INTO VECTOR
	JRST	MPOPJ

; this routine copies GET and PUT vectors into new ones

DOBLTS:	HRRI	C,(B)
	ADD	B,-1(P)
	BLT	C,-11(B)	; zap those guys in
	MOVEI	A,TUVEC		; mung in uniform type
	PUTYP	A,(B)
	MOVEI	C,-7(B)		; zero out remainder of uvector
	HRLI	C,-10(B)
	SETZM	-1(C)
	BLT	C,-1(B)
	POPJ	P,


; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES

MFUNCTION EVALTYPE,SUBR

	ENTRY

	PUSHJ	P,CHKARG	; VERIFY WINNAGE IN ARGS
	MOVEI	A,EVATYP	; POINT TO TABLE
	MOVEI	E,EVTYPE	; POINT TO PURE VERSION
	MOVEI	0,EVAL
TBLCAL:	PUSHJ	P,TBLSET	; SETUP TABLE ENTRY
	JRST	FINIS

MFUNCTION APPLYTYPE,SUBR

	ENTRY

	PUSHJ	P,CHKARG
	MOVEI	A,APLTYP	; POINT TO APPLY TABLE
	MOVEI	E,APTYPE	; PURE TABLE
	MOVEI	0,APPLY
	JRST	TBLCAL


MFUNCTION PRINTTYPE,SUBR

	ENTRY

	PUSHJ	P,CHKARG
	MOVEI	A,PRNTYP	; POINT TO APPLY TABLE
	MOVEI	E,PRTYPE	; PURE TABLE
	MOVEI	0,PRINT
	JRST	TBLCAL

; CHECK ARGS AND SETUP FOR TABLE HACKER

CHKARG:	JUMPGE	AB,TFA
	CAMGE	AB,[-5,,]
	JRST	TMA
	GETYP	A,(AB)		; 1ST MUST BE TYPE NAME
	CAIE	A,TATOM
	JRST	WTYP1
	MOVE	B,1(AB)		; GET ATOM
	PUSHJ	P,TYPLOO	; VERIFY THAT IT IS A TYPE
	PUSH	P,D		; SAVE TYPE NO.
	MOVEI	D,-1		; INDICATE FUNNYNESS
	CAML	AB,[-3,,]	; SKIP IF 2 OR MORE
	JRST	TY1AR
	HRRZ	A,(A)		; GET SAT
	ANDI	A,SATMSK
	PUSH	P,A
	GETYP	A,2(AB)		; GET 2D TYPE
	CAIE	A,TATOM		; EITHER TYPE OR APPLICABLE
	JRST	TRYAPL		; TRY APPLICABLE
	MOVE	B,3(AB)		; VERIFY IT IS A TYPE
	PUSHJ	P,TYPLOO
	HRRZ	A,(A)		; GET SAT
	ANDI	A,SATMSK
	POP	P,C		; RESTORE SAVED SAT
	CAIE	A,(C)		; SKIP IF A WINNER
	JRST	TYPDIF		; REPORT ERROR
TY1AR:	POP	P,C		; GET SAVED TYPE
	MOVEI	B,0		; TELL THAT WE ARE A TYPE
	POPJ	P,

TRYAPL:	PUSHJ	P,APLQ		; IS THIS APPLICABLE
	JRST	NAPT
	SUB	P,[1,,1]
	MOVE	B,2(AB)		; RETURN SAME
	MOVE	D,3(AB)
	POP	P,C
	POPJ	P,


; HERE TO PUT ENTRY IN APPROPRIATE TABLE

TBLSET:	PUSH	TP,B
	PUSH	TP,D		; SAVE VALUE 
	PUSH	TP,$TFIX
	PUSH	TP,A
	PUSH	P,C		; SAVE TYPE BEING HACKED
	PUSH	P,E
	SKIPE	B,1(A)		; SKIP IF VECTOR DOESN'T EXIST YET
	JRST	TBL.OK
	MOVE	B,-2(TP)	; CHECK FOR RETURN IT HACK
	SKIPN	-3(TP)
	CAIE	B,-1
	JRST	.+2
	JRST	RETPM2
	HLRE	A,TYPBOT+1	; GET CURRENT TABLE LNTH
	MOVNS	A
	ASH	A,-1
	PUSH	P,0
	PUSHJ	P,IVECT		; GET VECTOR
	POP	P,0
	MOVE	C,(TP)		; POINT TO RETURN POINT
	MOVEM	B,1(C)		; SAVE VECTOR

TBL.OK:	POP	P,E
	POP	P,C		; RESTORE TYPE
	SUB	TP,[2,,2]
	POP	TP,D
	POP	TP,A
	JUMPN	A,TBLOK1	; JUMP IF FUNCTION ETC. SUPPLIED
	CAIN	D,-1
	JRST	TBLOK1
	CAILE	D,NUMPRI	; SKIP IF ORIGINAL TYPE
	MOVNI	E,(D)		; CAUSE E TO ENDUP 0
	ADDI	E,(D)		; POINT TO PURE SLOT
TBLOK1:	ADDI	C,(C)		; POINT TO VECTOR SLOT
	ADDI	C,(B)
	CAIN	D,-1
	JRST	RETCUR
	JUMPN	A,OK.SET	; OK TO CLOBBER
	ADDI	B,(D)		; POINT TO TARGET TYPE'S SLOT
	ADDI	B,(D)		; POINT TO TARGET TYPE'S SLOT
	SKIPN	A,(B)		; SKIP IF WINNER
	SKIPE	1(B)		; SKIP IF LOSER
	SKIPA	D,1(B)		; SETUP D
	JRST	CH.PTB		; CHECK PURE TABLE

OK.SET:	CAIN	0,(D)		; SKIP ON RESET
	SETZB	A,D
	MOVEM	A,(C)		; STORE
	MOVEM	D,1(C)
RETAR1:	MOVE	A,(AB)		; RET TYPE
	MOVE	B,1(AB)
	JRST	FINIS

CH.PTB:	MOVEI	A,0
	MOVE	D,[SETZ NAPT]
	JUMPE	E,OK.SET
	MOVE	D,(E)
	JRST	OK.SET

RETPM2:	SUB	TP,[4,,4]
	SUB	P,[2,,2]
	ASH	C,1
	SOJA	E,RETPM4

RETCUR:	SKIPN	A,(C)
	SKIPE	1(C)
	SKIPA	B,1(C)
	JRST	RETPRM	

	JUMPN	A,CPOPJ
RETPM1:	MOVEI	A,0
	JUMPL	B,RTFALS
	CAMN	B,1(E)
	JRST	.+3
	ADDI	A,2
	AOJA	E,.-3

RETPM3:	ADD	A,TYPVEC+1
	MOVE	B,3(A)
	MOVE	A,2(A)
	POPJ	P,

RETPRM:	SUBI	C,(B)		; UNDO BADNESS
RETPM4:	CAIG	C,NUMPRI*2
	SKIPG	1(E)
	JRST	RTFALS

	MOVEI	A,-2(C)
	JRST	RETPM3

CALLTY:	MOVE	A,TYPVEC
	MOVE	B,TYPVEC+1
	POPJ	P,

MFUNCTION ALLTYPES,SUBR

	ENTRY	0

	MOVE	A,TYPVEC
	MOVE	B,TYPVEC+1
	JRST	FINIS

;

;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR

MFUNCTION UTYPE,SUBR

	ENTRY	1

	GETYP	A,(AB)		;GET U VECTOR
	PUSHJ	P,SAT
	CAIE	A,SNWORD
	JRST	WTYP1
	MOVE	B,1(AB)		; GET UVECTOR
	PUSHJ	P,CUTYPE
	JRST	FINIS

CUTYPE:	HLRE	A,B		;GET -LENGTH
	HRRZS	B
	SUB	B,A		;POINT TO TYPE WORD
	GETYP	A,(B)
	JRST	ITYPE		; GET NAME OF TYPE

; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR

MFUNCTION CHUTYPE,SUBR

	ENTRY	2

	GETYP	A,2(AB)		;GET 2D TYPE
	CAIE	A,TATOM
	JRST	NOTATO
	GETYP	A,(AB)		; CALL WITH UVECTOR?
	PUSHJ	P,SAT
	CAIE	A,SNWORD
	JRST	WTYP1
	MOVE	A,1(AB)		; GET UV POINTER
	MOVE	B,3(AB)		;GET ATOM
	PUSHJ	P,CCHUTY
	MOVE	A,(AB)		; RETURN UVECTOR
	MOVE	B,1(AB)
	JRST	FINIS

CCHUTY:	PUSH	TP,$TUVEC
	PUSH	TP,A
	PUSHJ	P,TYPLOO	;LOOK IT UP
	HRRZ	B,(A)		;GET SAT
	TRNE	B,CHBIT
	JRST	CANTCH
	ANDI	B,SATMSK
	SKIPGE	MKTBS(B)
	JRST	CANTCH
	HLRE	C,(TP)		;-LENGTH
	HRRZ	E,(TP)
	SUB	E,C		;POINT TO TYPE
	GETYP	A,(E)		;GET TYPE
	JUMPE	A,WIN0		;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
	PUSHJ	P,SAT		;GET SAT
	JUMPE	A,TYPERR
	CAIE	A,(B)		;COMPARE
	JRST	TYPDIF
WIN0:	ADDI	D,.VECT.
	HRLM	D,(E)		;CLOBBER NEW ONE
	POP	TP,B
	POP	TP,A
	POPJ	P,

CANTCH:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE CANT-CHTYPE-INTO
	PUSH	TP,2(AB)
	PUSH	TP,3(AB)
	MOVEI	A,2
	JRST	CALER

NOTATOM:
	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE NON-ATOMIC-ARGUMENT
	PUSH	TP,(AB)
	PUSH	TP,1(AB)
	MOVEI	A,2
	JRST	CALER



; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY

MFUNCTION QUIT,SUBR

	ENTRY	0


	PUSHJ	P,CLOSAL	; DO THE CLOSES
	PUSHJ	P,%KILLM
	JRST	IFALSE		; JUST IN CASE

CLOSAL:	MOVEI	B,CHNL0+2	; POINT TO 1ST (NOT INCLUDING TTY I/O)
	MOVE	PVP,PVSTOR+1
	MOVE	TVP,REALTV+1(PVP)
	SUBI	B,(TVP)
	HRLS	B
	ADD	B,TVP
	PUSH	TP,$TVEC
	PUSH	TP,B
	PUSH	P,[N.CHNS-1]	; MAX NO. OF CHANS

CLOSA1:	MOVE	B,(TP)
	ADD	B,[2,,2]
	MOVEM	B,(TP)
	HLLZS	-2(B)
	SKIPN	C,-1(B)		; THIS ONE OPEN?
	JRST	CLOSA4		; NO
	CAME	C,TTICHN+1
	CAMN	C,TTOCHN+1
	JRST	CLOSA4
	PUSH	TP,-2(B)	; PUSH IT
	PUSH	TP,-1(B)
	MCALL	1,FCLOSE		; CLOSE IT
CLOSA4:	SOSLE	(P)		; COUNT DOWN
	JRST	CLOSA1


	SUB	TP,[2,,2]
	SUB	P,[1,,1]

CLOSA3:	SKIPN	B,CHNL0+1
	POPJ	P,
	PUSH	TP,(B)
	HLLZS	(TP)
	PUSH	TP,1(B)
	HRRZ	B,(B)
	MOVEM	B,CHNL0+1
	MCALL	1,FCLOSE
	JRST	CLOSA3


IMPURE

WHOAMI:	0		; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK


;GARBAGE COLLECTORS PDLS


GCPDL:	-GCPLNT,,GCPDL

	BLOCK	GCPLNT


PURE

MUDSTR:	ASCII /MUDDLE /
STRNG:	-1
	-1
	-1
	ASCIZ / IN OPERATION./

;MARKED PDLS FOR GC PROCESS

VECTGO
; DUMMY FRAME FOR INITIALIZER CALLS

	TENTRY,,LISTEN
	0
	.-3
	0
	0
	-ITPLNT,,TPBAS-1
	0

TPBAS:	BLOCK	ITPLNT+PDLBUF
	GENERAL
	ITPLNT+2+PDLBUF+7,,0


VECRET


$TMATO:	TATOM,,-1

END