X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=sumex%2Fmain.mcr227;fp=sumex%2Fmain.mcr227;h=e006ec27ec819e9e56028d28cb68733ff91fa16b;hp=0000000000000000000000000000000000000000;hb=1c973408824dee4a587c040bc8075cd1bf047ba3;hpb=a3df309bdd1ea54242d39e62403548d1e4845f8e

diff --git a/sumex/main.mcr227 b/sumex/main.mcr227
new file mode 100644
index 0000000..e006ec2
--- /dev/null
+++ b/sumex/main.mcr227
@@ -0,0 +1,1819 @@
+TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
+
+RELOCA
+
+.GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
+.GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI
+.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
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM
+.GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY
+.GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG
+.GLOBAL	TYPIC
+.INSRT MUDDLE >
+
+MONITS==1		; SET TO 1 IF PC DEMON WANTED
+.VECT.==1		; BIT TO INDICATE VECTORS FOR GCHACK
+
+;MAIN LOOP AND STARTUP
+
+START:	MOVEI	0,0			; SET NO HACKS
+	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:	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
+	MOVE	TVP,TVPSTO+1(PVP)	; GET A TVP
+	SETZB	R,M			; RESET RSUBR AC'S
+	PUSHJ	P,%RUNAM
+	PUSHJ	P,%RJNAM
+	PUSHJ	P,TTYOPE		;OPEN THE TTY
+	MOVEI	B,MUDSTR
+	SKIPE	WHOAMI		; SKIP IF THIS IS MUDDLE
+	JRST	.+3		; ELSE NO MESSAGE
+	SKIPN	NOTTY			; IF NO TTY, IGNORE
+	PUSHJ	P,MSGTYP		;TYPE OUT TO USER
+
+	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	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
+	MOVEM	E,-1(TB)
+	JRST	CONTIN
+
+	MQUOTE	TOPLEVEL
+TOPLEVEL:
+	MCALL	0,LISTEN
+	JRST	TOPLEVEL
+
+
+MFUNCTION 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
+
+
+TPSUBR==TSUBR+400000
+
+MFUNCTION ERROR%,PSUBR,ERROR
+
+RMT [EXPUNGE TPSUBR
+]
+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(TVP)
+	JRST	NOTINC
+ER2:	MOVE	B,IMQUOTE INCHAN
+	MOVEI	C,TTICHN(TVP)	; POINT TO VALU
+	PUSHJ	P,PUSH6		; PUSH THE BINDING
+	MOVE	B,TTICHN+1(TVP)	; GET IN CHAN
+NOTINC:	SKIPE	NOTTY
+	JRST	NOECHO
+	PUSH	TP,$TCHAN
+	PUSH	TP,B
+	PUSH	TP,$TATOM
+	PUSH	TP,MQUOTE 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(TVP)
+	JRST	NOTOUT
+ER3:	MOVE	B,IMQUOTE OUTCHAN
+	MOVEI	C,TTOCHN(TVP)
+	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,PVP		; 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
+	MOVE	A,2(A)
+	CAIE	A,ERROBL+1
+	CAMN	A,ERROBL+1(TVP)	; 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
+	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(TVP)
+	PUSH	TP,INITIAL+1(TVP)
+	PUSH	TP,ROOT(TVP)
+	PUSH	TP,ROOT+1(TVP)
+	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,MQUOTE 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,MQUOTE 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,MQUOTE 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
+
+
+MFUNCTION 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
+	MCALL	0,TERPRI
+	MCALL	1,EVAL
+	PUSH	TP,$TATOM
+	PUSH	TP,IMQUOTE LAST-OUT
+	PUSH	TP,A
+	PUSH	TP,B
+	MCALL	2,SET
+	PUSH	TP,A
+	PUSH	TP,B
+	MCALL	1,PRIN1
+	POP	P,C		;FLAG FOR FALL THROUGH OR CALL
+	JUMPN	C,FINIS		;IN CASE LOOSER CALLED REP
+	JRST	MAINLP
+
+
+;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
+	CAMGE	C,VECTOP	; CHECK FOR RSUBR
+	CAMG	C,VECBOT
+	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(TVP)
+	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:	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	RETRN3
+
+RETRN2:	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE CANT-RETRY-ENTRY-GONE
+	JRST	CALER1
+
+RETRER:	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE PURE-LOAD-FAILURE
+	JRST	CALER1
+
+
+;FUNCTION TO DO ERROR RETURN
+
+MFUNCTION 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
+
+MFUNCTION	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,PVP		; 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,PVP		; 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	;RETURNS FUNCTION NAME OF
+	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
+	CAMG	A,VECTOP	;IS THIS AN RSUBR ?
+	CAMGE	A,VECBOT
+	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:
+	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE FRAME-NO-LONGER-EXISTS
+	JRST	CALER1
+
+
+TOPLOSE:
+	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE TOP-LEVEL-FRAME
+	JRST	CALER1
+
+
+
+
+; 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,MQUOTE 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,MQUOTE 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
+	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
+
+
+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
+
+MFUNCTION UNAME,SUBR
+
+	ENTRY	0
+
+	PUSHJ	P,%RUNAM
+	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 NO ARGS AND
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
+
+ICR:	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
+	PUSH	TP,[PLNT]
+	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)
+
+
+	MOVEI	A,TPLNT		;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
+	MOVEM	TVP,TVPSTO+1(C)	;AND THE GOOD OLD TRANSFER VECTOR
+	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
+
+	IRP	A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]
+	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
+
+SWAPIN:
+	;NOW RESTORE NEW PROCESSES AC'S
+
+	IRP	A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]
+	MOVE	A,A!STO+1(PVP)
+	TERMIN
+
+	JRST	(C)		;AND RETURN
+
+
+
+
+;SUBRS ASSOCIATED WITH TYPES
+
+;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
+;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
+
+SAT:	LSH	A,1		;TIMES 2 TO REF VECTOR
+	HRLS	A  		;TO BOTH HALVES TO HACK AOBJN POINTER
+	ADD	A,TYPVEC+1(TVP)	;ACCESS THE VECTOR
+	HRR	A,(A)		;GET PROBABLE SAT
+	JUMPL	A,.+2		;DID WE REALLY HAVE A VALID TYPE
+	MOVEI	A,0		;NO RETURN 0
+	ANDI	A,SATMSK
+	POPJ	P,  		;AND RETURN
+
+;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:	PUSH	TP,$TATOM	;SETUP ERROR CALL
+	PUSH	TP,EQUOTE TYPE-UNDEFINED
+	JRST	CALER1"		;STANDARD ERROR HACKER
+
+CITYPE:	GETYP	A,A		; GET TYPE FOR COMPILER CALL
+ITYPE:	LSH	A,1		;TIMES 2
+	HRLS	A  		;TO BOTH SIDES
+	ADD	A,TYPVEC+1(TVP)	;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,MQUOTE 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,TYPLOO	; search type vector
+	POP	P,B
+	CAMN	B,MQUOTE ANY
+	JRST	CTPEC1
+	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,
+
+MFUNCTION %TYPEW,SUBR,[TYPE-W]
+
+	ENTRY
+
+	JUMPGE	AB,TFA
+	GETYP	0,(AB)
+	CAIE	0,TATOM
+	JRST	WTYP1
+	MOVEI	D,0
+	MOVE	C,MQUOTE 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
+	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	CTYPW3
+
+CTYPEW:	PUSH	P,D
+	PUSHJ	P,CTYPEC	; GET CODE IN B
+	POP	P,B
+	HRLI	B,(D)
+	MOVSI	A,TTYPEW
+	POPJ	P,
+	
+;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
+
+STBL:	REPEAT NUMSAT,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]
+[PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
+[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]
+IRP B,C,[A]
+LOC STBL+S!B
+MQUOTE C
+
+.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 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,MQUOTE 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
+
+MFUNCTION 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:	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
+	JRST	CALER1
+
+; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
+
+MFUNCTION 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	B,1(AB)		; RESTORE B
+	JRST	MENTR2
+
+BENTRY:	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE BAD-VECTOR
+	JRST	CALER1
+	
+; 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
+	PUSHJ	P,@0		;GO TO THE PROPER SUBROUTINE
+	SUBM	M,(P)		;RECONSTITUTE THE RSUBR's PC
+	POPJ	P,
+
+
+; ERRORS IN COMPILED CODE MAY END UP HERE
+
+COMPERR:
+	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE ERROR-IN-COMPILED-CODE
+	JRST	CALER1
+
+
+;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"
+	CAME	0,MQUOTE TEMPLATE
+	CAIN	A,(B)
+	JRST	CHTMP1
+	JRST	TYPDIF
+
+CHMATC:	PUSH	TP,A
+	PUSH	TP,1(AB)	; SAVE GOODIE
+	MOVSI	A,TATOM
+	MOVE	B,3(AB)
+	MOVSI	C,TATOM
+	MOVE	D,MQUOTE DECL
+	PUSHJ	P,IGET		; FIND THE DECL
+	MOVE	C,(AB)
+	MOVE	D,1(AB)		; NOW GGO TO MATCH
+	PUSHJ	P,TMATCH
+	JRST	TMPLVIO
+	POP	TP,B
+	POP	TP,A
+	JRST	FINIS
+
+TYPLOO:	PUSHJ	P,TYPFND
+	JRST	.+2
+	POPJ	P,
+	PUSH	TP,$TATOM	;LOST, GENERATE ERROR
+	PUSH	TP,EQUOTE BAD-TYPE-NAME
+	JRST	CALER1
+
+TYPFND:	MOVE	A,TYPVEC+1(TVP)	;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:	PUSH	TP,$TATOM	;MAKE ERROR MESSAGE
+	PUSH	TP,EQUOTE STORAGE-TYPES-DIFFER
+	JRST	CALER1
+
+
+TMPLVI:	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE DECL-VIOLATION
+	JRST	CALER1
+
+
+; 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
+	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	0,SATMSK
+	ANDI	A,SATMSK
+	CAIN	0,(A)		; SKIP IF LOSER
+	JRST	NEWTFN		; O.K.
+
+	PUSH	TP,$TATOM
+	PUSH	TP,EQUOTE TYPE-ALREADY-EXISTS
+	JRST	CALER1
+
+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,MQUOTE 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(TVP)	; CHECK GROWTH NEED
+	CAMGE	C,TYPVEC+1(TVP)
+	JRST	ADDIT		; STILL ROOM
+GAGN:	PUSHJ	P,IGROWB	; SETUP BOTTOM GROWTH
+	SKIPE	C,EVATYP+1(TVP)
+	PUSHJ	P,IGROWT	; SET UP TOP GROWTH
+	SKIPE	C,APLTYP+1(TVP)
+	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(TVP)	; FIX UP POINTER
+
+ADDIT:	MOVE	C,TYPVEC+1(TVP)
+	SUB	C,[2,,2]	; ALLOCATE ROOM
+	MOVEM	C,TYPVEC+1(TVP)
+	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)
+	POPJ	P,
+
+
+; Interface to interpreter for setting up tables associated with
+;	template data structures.
+;	A/	<-name of type>-
+;	B/	<-length ins>-
+;	C/	<-uvector of length code or 0>
+;	D/	<-uvector of GETTERs>-
+;	E/	<-uvector of PUTTERs>-
+
+CTMPLT:	SUBM	M,(P)		; could possibly gc during this stuff
+	SKIPE	C		; for now dont handle vector of length ins
+	FATAL	TEMPLATE DATA WITH COMPUTED LENGTH
+	PUSH	TP,$TATOM	; save name of type
+	PUSH	TP,A
+	PUSH	P,B		; save length instr
+	HLRE	A,TD.LNT+1(TVP)	; check for template slots left?
+	HRRZ	B,TD.LNT+1(TVP)
+	SUB	B,A		; point to dope words
+	HLRZ	B,1(B)		; get real length
+	ADDM	B,A		; any room?
+	JUMPG	A,GOODRM	; jump if ok
+
+	PUSH	TP,$TUVEC	; save getters and putters
+	PUSH	TP,D
+	PUSH	TP,$TUVEC
+	PUSH	TP,E
+	MOVEI	A,6(B)		; grow it 10 by copying
+	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(TVP)	; prepare to BLT in
+	MOVEM	B,TD.LNT+1(TVP)	; and save as new length vector
+	HRRI	C,(B)		; destination
+	ADD	B,(P)		; final destination address
+	BLT	C,-13(B)
+	MOVE	A,(P)		; length for new getters
+	PUSHJ	P,CAFRE1
+	MOVE	C,TD.GET+1(TVP)	; get old for copy
+	MOVEM	B,TD.GET+1(TVP)
+	HRRI	C,(B)
+	ADD	B,(P)
+	BLT	C,-13(B)	; zap those guys in
+	MOVE	A,(P)		; finally putters
+	PUSHJ	P,CAFRE1
+	MOVE	C,TD.PUT+1(TVP)
+	MOVEM	B,TD.PUT+1(TVP)
+	HRRI	C,(B)		; BLT pointer
+	ADD	B,(P)
+	BLT	C,-13(B)
+	SUB	P,[1,,1]	; flush stack craft
+	MOVE	E,(TP)
+	MOVE	D,-2(TP)
+	SUB	TP,[4,,4]
+
+GOODRM:	MOVE	B,TD.LNT+1(TVP)	; move down to fit new guy
+	SUB	B,[1,,1]	; will always win due to prev checks
+	MOVEM	B,TD.LNT+1(TVP)
+	HRLI	B,1(B)
+	HLRE	A,TD.LNT+1(TVP)
+	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(TVP)
+	MOVNS	A		; A/ offset for other guys
+	PUSH	P,A		; save it
+	ADD	A,TD.GET+1(TVP)	; point for storing uvs of ins
+	MOVEM	D,-1(A)
+	MOVE	A,(P)
+	ADD	A,TD.PUT+1(TVP)
+	MOVEM	E,-1(A)		; store putter also
+	POP	P,A		; compute primtype
+	ADDI	A,NUMSAT
+	HRLI	A,TATOM
+	MOVE	B,(TP)		; ready to mung type vector
+	SUB	TP,[2,,2]
+	PUSHJ	P,INSNT		; insert into vector
+	JRST	MPOPJ
+
+
+; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
+
+MFUNCTION EVALTYPE,SUBR
+
+	ENTRY	2
+
+	PUSHJ	P,CHKARG	; VERIFY WINNAGE IN ARGS
+	MOVEI	A,EVATYP	; POINT TO TABLE
+	MOVEI	E,EVTYPE	; POINT TO PURE VERSION
+TBLCAL:	PUSHJ	P,TBLSET	; SETUP TABLE ENTRY
+	JRST	FINIS
+
+MFUNCTION APPLYTYPE,SUBR
+
+	ENTRY	2
+
+	PUSHJ	P,CHKARG
+	MOVEI	A,APLTYP	; POINT TO APPLY TABLE
+	MOVEI	E,APTYPE	; PURE TABLE
+	JRST	TBLCAL
+
+
+MFUNCTION PRINTTYPE,SUBR
+
+	ENTRY	2
+
+	PUSHJ	P,CHKARG
+	MOVEI	A,PRNTYP	; POINT TO APPLY TABLE
+	MOVEI	E,PRTYPE	; PURE TABLE
+	JRST	TBLCAL
+
+; CHECK ARGS AND SETUP FOR TABLE HACKER
+
+CHKARG:	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.
+	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
+	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:	HRLI	A,(A)		; FOR TVP HACKING
+	ADD	A,TVP		; POINT TO TVP SLOT
+	PUSH	TP,B
+	PUSH	TP,D		; SAVE VALUE 
+	PUSH	TP,$TVEC
+	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
+	HLRE	A,TYPBOT+1(TVP)	; GET CURRENT TABLE LNTH
+	MOVNS	A
+	ASH	A,-1
+	PUSHJ	P,IVECT		; GET VECTOR
+	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
+	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)
+	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:	MOVEM	A,(C)		; STORE
+	MOVEM	D,1(C)
+	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
+
+CALLTY:	MOVE	A,TYPVEC(TVP)
+	MOVE	B,TYPVEC+1(TVP)
+	POPJ	P,
+
+MFUNCTION ALLTYPES,SUBR
+
+	ENTRY	0
+
+	MOVE	A,TYPVEC(TVP)
+	MOVE	B,TYPVEC+1(TVP)
+	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
+	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:	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:	MOVE	B,TVP		; POINT TO XFER VECCTOR
+	ADD	B,[CHNL0+2,,CHNL0+2]	; POINT TO 1ST (NOT INCLUDING TTY I/O)
+	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)
+	SKIPN	C,-1(B)		; THIS ONE OPEN?
+	JRST	CLOSA4		; NO
+	CAME	C,TTICHN+1(TVP)
+	CAMN	C,TTOCHN+1(TVP)
+	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(TVP)
+	POPJ	P,
+	PUSH	TP,(B)
+	HLLZS	(TP)
+	PUSH	TP,1(B)
+	HRRZ	B,(B)
+	MOVEM	B,CHNL0+1(TVP)
+	MCALL	1,FCLOSE
+	JRST	CLOSA3
+
+; LITTLE ROUTINES USED ALL OVER THE PLACE
+
+CRLF:	MOVEI	A,15
+	PUSHJ	P,MTYO
+	MOVEI	A,12
+	JRST	MTYO
+MSGTYP: HRLI	B,440700	;MAKE BYTE POINTER
+MSGTY1:	ILDB	A,B		;GET NEXT CHARACTER
+	JUMPE	A,CPOPJ		;NULL ENDS STRING
+	CAIE	A,177		; DONT PRINT RUBOUTS
+	PUSHJ	P,MTYO"
+	JRST	MSGTY1		;AND GET NEXT CHARACTER
+CPOPJ:	POPJ	P,
+
+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
+
+
+PATCH:
+PAT:	BLOCK	100
+PATEND:	0
+
+END
+