TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
RELOCA
MAIN==1	;THIS INCLUDES ONCE ONLY CODE

NINT==72.	;NUMBER OF POSSIBLE ITS INTERRUPTS
NASOCS==159.	;LENGTH OF ASSOCIATION VECTOR


.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI

.INSRT MUDDLE >

VECTGO
TVBASE":	BLOCK	TVLNT
	GENERAL
	TVLNT+2,,0
TVLOC=TVBASE



;INITIAL TYPE TABLE

TYPVLC":	BLOCK	2*NUMPRI+2
	GENERAL
	2*NUMPRI+2+2,,0

TYPTP==.-2			; POINT TO TOP OF TYPES

INTVCL:	BLOCK	2*NINT
	TLIST,,0
	2*NINT+2,,0

NODLST:	TTP,,0
	0
	TASOC,,0
	BLOCK	ASOLNT-3
	GENERAL+<SASOC,,0>
	ASOLNT+2,,0


ASOVCL:	BLOCK	NASOCS
	TASOC,,0
	NASOCS+2,,0



;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION

ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
TYPVEC==TVOFF-1

ADDTV TVEC,TYPTP
TYPTOP==TVOFF-1			; POINT TO CURRENT TOP OF TYPE VECTORS

;ENTRY FOR ROOT,TTICHN,TTOCHN

ADDTV TCHAN,0
TTICHN==TVOFF-1

ADDTV TCHAN,0
TTOCHN==TVOFF-1

ADDTV TOBLS,0
ROOT==TVOFF-1
ADDTV TOBLS,0
INTOBL==TVOFF-1
ADDTV TOBLS,0
ERROBL==TVOFF-1
ADDTV TVEC,0
GRAPHS==TVOFF-1
ADDTV TFIX,0
INTNUM==TVOFF-1
ADDTV TVEC,[-2*NINT,,INTVCL]
INTVEC==TVOFF-1
ADDTV TUVEC,[-NASOCS,,ASOVCL]
ASOVEC==TVOFF-1

DEFINE ADDCHN N
	ADDTV TCHAN,0
	CHANL!N==TVOFF-1
	.GLOBAL CHANL!N
	TERMIN

REPEAT 16.,ADDCHN \.RPCNT

ADDTV TASOC,[-ASOLNT,,NODLST]
NODES==TVOFF-1


;GLOBAL SPECIAL PDL

GSP:	BLOCK	GSPLNT
	GENERAL
	GSPLNT+2,,0

ADDTV TVEC,[-GSPLNT,,GSP]
GLOBASE==TVOFF-1
GLOB==.-2
ADDTV TVEC,GLOB
GLOBSP==TVOFF-1	;ENTRY FOR CURRENT POINTER TO GLOBAL SP

;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS

GCPVP:	BLOCK	PVLNT*2
	GENERAL
	PVLNT*2+2,,0


VECRET

;INITIAL PROCESS VECTOR

PVBASE":	BLOCK	PVLNT*2
	GENERAL
	PVLNT*2+2,,0
PVLOC==PVBASE


;ENTRY FOR PROCESS I.D.

	ADDPV	TFIX,1,PROCID
;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS

ZZZ==.

IRP A,,[0,A,B,C,D,E,PVP,TVP,PP,AB,TB,TP,SP,P]B,,[0
0,0,0,0,0,TPVP,TTVP,TPP,TAB,TTB,TTP,TSP,TPDL]

LOC PVLOC+2*A
A!STO=.-PVBASE
B,,0
0
TERMIN

PVLOC==PVLOC+16.*2
LOC ZZZ

;ADD LAST ERROR AND PROG GOODIE

ADDPV TTB,0,LERR

ADDPV TTB,0,LPROG



ADDPV TTB,0,TBINIT
ADDPV TTP,0,TPBASE
ADDPV TSP,0,SPBASE
ADDPV TPDL,0,PBASE
ADDPV 0,0,RESFUN
ADDPV TLIST,0,.BLOCK
ADDPV TLIST,0,MESS
ADDPV TACT,0,FACTI



;MAIN LOOP AND STARTUP

;SECONDARY STARTUP

START:
	MOVE	PVP,MAINPR		;MAKE SURE WE START IN THE MAIN PROCESS
	PUSHJ	P,INTINT	;INITIALIZE INTERRUPT HANDLER
	PUSHJ	P,TTYOPEN		;OPEN THE TTY
MIO:	MOVEI	B,[ASCIZ /MUDDLE IN OPERATION./]
	PUSHJ	P,MSGTYP	;TYPE OUT TO USER

	XCT	MESSAG		;MAYBE PRINT A MESSAGE

RESTART:				;RESTART A PROCESS
STP:
	HRR	TB,TBINIT+1(PVP)	;POINT INTO STACK AT START
	MOVE	PP,PPSAV(TB)	;FLUSH FAILPOINTS
	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

MFUNCTION ERROR,SUBR

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

ER1:	PUSH	TP,$TMATOM	;BIND CHANNELS,OBLIST AND EOF
	PUSH	TP,MQUOTE INCHAN
	PUSH	TP,TTICHN(TVP)	;TYPE OF TTY CHAN
	PUSH	TP,TTICHN+1(TVP)	;AND ITS VALUE
	PUSH	TP,[0]	;DUMMY FOR SPECBIND
	PUSH	TP,[0]

	PUSH	TP,$TMATOM
	PUSH	TP,MQUOTE OUTCHAN
	PUSH	TP,TTOCHN(TVP)	;TYPE OF OUT CHNA
	PUSH	TP,TTOCHN+1(TVP)	;AND IT S VAL
	PUSH	TP,[0]
	PUSH	TP,[0]

	PUSH	TP,$TMATOM
	PUSH	TP,MQUOTE OBLIST
	PUSH	TP,ROOT(TVP)	;DEFAULT OBLIST TYPE
	PUSH	TP,ROOT+1(TVP)	;AND VALUE
	PUSH	TP,[0]
	PUSH	TP,[0]

	PUSH	TP,$TMATOM
	PUSH	TP,MQUOTE EOF
	PUSH	TP,$TLIST	;DEFAULT EOF- NIL
	PUSH	TP,[0]
	PUSH	TP,[0]
	PUSH	TP,[0]

	MOVE	B,MQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,ILVAL		;GET VALUE OF LAST ERR
	PUSH	TP,[TATOM,,-1]		;FOR BINDING
	PUSH	TP,MQUOTE LER,[LERR ]INTRUP
	PUSH	TP,$TTB
	ADD	B,[1,,0]		;INCREASE LEVEL
	HRR	B,TB
	HLRZ	A,B		;AND SAVE NEW LEVEL
	PUSH	P,A
	PUSH	TP,B
	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,MQUOTE *ERROR*
	MCALL	1,PRINT		;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
	PUSH	TP,(C)		;GET AN ARGS TYPE
	PUSH	TP,1(C)		;AND VALUE
	MCALL	1,PRINT
	POP	TP,C
	SUB	TP,[1,,1]
	ADD	C,[2,,2]	;BUMP SAVED AB
	JRST	ERRLP		;AND CONTINUE

LEVPRT:	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE LISTENING-AT-LEVEL
	MCALL	1,PRINT		;PRINT LEVEL
	PUSH	TP,$TFIX	;READY TO PRINT LEVEL
	MOVE	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,MQUOTE [ PROCESS ]
	MCALL	1,PRINC		;DONT SLASHIFY SPACES
	PUSH	TP,PROCID(PVP)	;NOW ID
	PUSH	TP,PROCID+1(PVP)
	MCALL	1,PRIN1
	
MAINLP:	PUSHJ	P,CRLF		;TYPE OUT A CARRIAGE RETURN, LINEFEED
	MCALL	0,READ
	PUSH	TP,A
	PUSH	TP,B
	MCALL	1,EVAL
	PUSH	TP,A
	PUSH	TP,B
	MCALL	1,PRINT
	JRST	MAINLP



;FUNCTION TO DO ERROR RETURN

MFUNCTION ERRET,SUBR

	ENTRY
	CAML	AB,[-1,,0]	;CHECK FOR AN ARG
	JRST	STP		;NO ARGS, RESTART PROCESS
	CAML	AB,[-3,,0]	;FRAME SUPPLIED
	JRST	ERRET1		;NO
	ADD	AB,[2,,2]	;POINT AB AT FRAME ARG
	PUSHJ	P,FRCHECK	;CHECK IT OUT	
	SUB	AB,[2,,2]	;POINT IT BACK


ERRET1:	MOVE	B,MQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,ILVAL		;GET VALUE
	HRR	TB,B		;AND CLOBBER
	CAMGE	AB,[-3,,0]	;FRAME SUPPLIED?
	HRR	TB,3(AB)	;YES, RESTORE TB FROM FRAME
RTA:	MOVE	A,(AB)
	MOVE	B,1(AB)		;AND GET RETURNED VALUE
	JRST	FINIS


MFUNCTION	FRAME,SUBR
	ENTRY
	MOVE	B,MQUOTE LER,[LERR ]INTRUP
	PUSHJ	P,ILVAL
	JUMPGE	AB,FRM1		;FRAME ARGUMENT SUPPLIED?
	PUSHJ	P,FRCHECK	;YES, CHECK IT
	MOVE	B,OTBSAV(C)	;GET PREVIOUS FRAME

FRM1:	HLL	B,OTBSAV(B)	;TIME
	MOVEI	A,1(PVP)	;PVP END
	HLRE	D,PVP	;PVP LENGTH
	SUB	A,D	;ARRIVE AT PVP DOPE WORD
	HRLI	A,TFRAME
	JRST	FINIS

MFUNCTION	ARGS,SUBR
	ENTRY	1	;
	PUSHJ	P,FRCHECK
	MOVEI	A,2
	PUSHJ	P,CELL"		;B_ADDRESS OF INFO CELL
	MOVSI	A,TINFO
	MOVEM	A,(B)
	MOVEI	A,(TP)		;GENERATE DOPE WORD POINTER
	HLRE	E,TP
	SUBI	A,-1(E)
	CAME	A,TPGROW"	;ALLOWING FOR BLOWN PDL
	ADDI	A,PDLBUF"
	HRLZS	A		;POINTER TO LEFT HALF...
	HLR	A,OTBSAV(C)	;TIME TO RIGHT
	MOVEM	A,1(B)		;TO SECOND WORD OF CELL
	HRRI	A,(B)		;INFO CELL IN CDR OF ARGS VALUE CELL
	HRLI	A,TARGS
	MOVE	B,ABSAV(C)
	JRST	FINIS

MFUNCTION	FUNCT,SUBR	;RETURNS FUNCTION NAME OF
	ENTRY	1	; FRAME ARGUMENT
	PUSHJ	P,FRCHECK	;CHECK ARG; LEAVE TB IN C
	HRRZ	A,FSAV(C)	;FUNCTION POINTER
	MOVE	B,@-1(A)	;GET FUNCTION NAME POINTER
	MOVSI	A,TATOM
	JRST	FINIS

FRCHECK:
	HLRZ	A,(AB)	;CHECK TYPE OF ARG
	CAIE	A,TFRAME	;FRAME?
	JRST	WRTYFR
	HRRZ	C,1(AB)	;GET TB OF FRAME
	CAILE	C,1(TP)	;DOES FRAME POINT BEYOND END OF STACK?
	JRST	BADFRAME
	HLRZ	A,FSAV(C)	;GET TYPE OF  POINTED AT BY FRAME
	CAIE	A,TENTRY	;ENTRY?
	JRST	BADFRAME	;NO
	HLRZ	D,1(AB)	;TIME IN FRAME
	HLRZ	E,OTBSAV(C)	;TIME IN .FRAME
	CAME	D,E	;THE SAME?
	JRST	BADFRAME	;NO, PDL UP-DOWN LOSSAGE
	HRRZ	D,OTBSAV(C)	;AT TOPLEVEL?
	JUMPE D,TOPLOSE	;YES
	POPJ	P,



WRTYFR:
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE WRONG-TYPE-FRAME
	JRST	CALER1


BADFRAME:
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE FRAME-NO-LONGER-EXISTS
	JRST	CALER1


TOPLOSE:
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE TOP-LEVEL-FRAME
	JRST	CALER1






;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	;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,PPLNT		;GET LENGTH OF PP
	PUSHJ	P,IVECT
	ADD	B,[PDLBUF-2,,-1]
	MOVE	C,(TP)		;GET PROCESS POINTER BACK
	MOVEM	B,PPSTO+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)
	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,PTIME		;GOBBLE A UNIQUE PROCESS I.D.
	MOVEM	A,PROCID+1(C)	;SAVE THAT ALSO

;SETUP INITIAL BINDINGS

	PUSH	TP,$TPVP		;SAVE PVP
	PUSH	TP,C
	MOVEI	A,4
	PUSHJ	P,IVECT		;B _ NEW BIND VECTOR
	POP	TP,C
	SUB	TP,[1,,1]
	MOVEM	B,SPBASE+1(C)	;NEW SPBASE
	MOVE	A,$TSP
	MOVEM	A,(B)
	SETZM	1(B)
	MOVE	A,$TBIND
	HRR	A,B
	ADD	B,[1,,1]
	PUSH	B,A
	MOVEM	B,SPSTO+1(C)	;SAVE AS INITIAL SP
	PUSH	B,MQUOTE THIS-PROCESS
	PUSH	B,$TPVP
	PUSH	B,C
	PUSH	B,[0]
	PUSH	B,[0]
	AOBJP	B,ICRQ
	.VALUE	[ASCIZ /SP DISASTER/]
ICRQ:	MOVSI	A,TPVP
	MOVE	B,C
	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,PP,AB,TB,TP,SP,P,PP]
	MOVEM	A,A!STO+1(PVP)
	TERMIN

	MOVE	E,PVP	;RETURN OLD PROCESS IN E
	MOVE	PVP,D	;AND MAKE NEW ONE BE D

	;NOW RESTORE NEW PROCESSES AC'S

	IRP	A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
	MOVE	A,A!STO+1(PVP)
	TERMIN

	JRST	(C)		;AND RETURN


;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
	MOVEI	A,(A)		;CLOBBER LEFT HALF
	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
	HLLZ	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,MQUOTE TYPE-UNDEFINED
	JRST	CALER1"		;STANDARD ERROR HACKER

ITYPE:	LSH	A,1		;TIMES 2
	HLRS	A  		;TO BOTH SIDES
	ADD	A,TYPVEC+1(TVP)	;GET ACTUAL LOCATION
	JUMPGE	A,TYPLOS	;LOST, TYPE OUT OF BOUNDS
	MOVE	B,1(A)		;PICKUP TYPE
	HLLZ	A,(A)
	POPJ	P,

TYPLOS:	MOVSI	A,TLIST
	MOVEI	B,NIL
	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,FIX],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR]
[ARGS,ARGUMENTS],[FRAME,FRAME],[ATOM,ATOM],[CHSTR,STRING]]

IRP B,C,[A]
LOC STBL+S!B
MQUOTE C

.ISTOP

TERMIN
TERMIN

LOC STBL+NUMSAT+1


MFUNCTION PRIMTYPE,SUBR

	ENTRY	1

	GETYP	A,(AB)		;GET TYPE
	PUSHJ	P,SAT		;GET SAT
	JUMPE	A,TYPERR
	MOVE	B,@STBL(A)
	MOVSI	A,TATOM
	JRST	FINIS

;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
	HLRZ	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
	HLRZ	A,(AB)		;NOW GET TYPE TO HACK
	PUSHJ	P,SAT		;FIND OUT ITS SAT
	JUMPE	A,TYPERR	;COMPLAIN
	CAIE	A,(B)		;DO THEY AGREE?
	JRST	TYPDIF		;NO, COMPLAIN
	MOVSI	A,(D)		;GET NEW TYPE
	MOVE	B,1(AB)		;AND VALUE
	JRST	FINIS

TYPLOO:	MOVE	A,TYPVEC+1(TVP)	;GOBBLE DOWN TYPE VECTOR
	MOVEI	D,0		;INITIALIZE TYPE COUNTER
TLOOK:	CAMN	B,1(A)		;CHECK THIS ONE
	POPJ	P,		;WIN, RETURN
	ADDI	D,1		;BUMP COUNTER
	AOBJP	A,.+2		;COUTN DOWN ON VECTOR
	AOBJN	A,TLOOK

	PUSH	TP,$TATOM	;LOST, GENERATE ERROR
	PUSH	TP,MQUOTE BAD-TYPE-NAME
	JRST	CALER1

TYPDIF:	PUSH	TP,$TATOM	;MAKE ERROR MESSAGE
	PUSH	TP,MQUOTE STORAGE-TYPES-DIFFER
	JRST	CALER1

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

MFUNCTION NEWTYPE,SUBR

	ENTRY	2

	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

	SKIPGE	C,TYPTOP+1(TVP)	; SKIP IF VECTOR FULL
	JRST	ADDIT		; NO, GO ADD
	PUSH	TP,$TVEC		; CALL GROW
	PUSH	TP,TYPVEC+1(TVP)
	PUSH	TP,$TFIX
	PUSH	TP,[100]
	PUSH	TP,$TFIX
	PUSH	TP,[0]
	MCALL	3,GROW		; GROW THE POOR VECTOR
	MOVE	C,TYPTOP+1(TVP)	; GET NEW TOP

ADDIT:	MOVE	B,3(AB)	; GET PRIM TYPE NAME
	PUSHJ	P,TYPLOO		; LOOK IT UP
	HRRZ	A,(B)		; GOBBLE SAT
	HRLI	A,TATOM	; MAKE NEW TYPE
	MOVEM	A,(C)		; CLOBBER IT IN
	MOVE	B,1(AB)		; GET NEW TYPE NAME
	MOVEM	B,1(C)
	ADD	C,[2,,2]	; BUMP POINTER
	MOVEM	C,TYPTOP+1(TVP)
	MOVE	A,(AB)
	MOVE	B,1(AB)		; RETURN NAME
	JRST	FINIS

MFUNCTION ALLTYPES,SUBR

	ENTRY	0

	MOVE	A,TYPVEC(TVP)
	MOVE	B,TYPVEC+1(TVP)
	JRST	FINIS

MFUNCTION UTYPE,SUBR

	ENTRY	1

	GETYP	A,(AB)		;GET U VECTOR
	CAIE	A,TUVEC
	JRST	WTYP1
	HLRE	A,1(AB)		;GET -LENGTH
	HRRZ	B,1(AB)
	SUB	B,A		;POINT TO TYPE WORD
	HLLZ	A,(B)
	JRST	TYPE1		;NOW, USE TYPE CODE
MFUNCTION CHUTYPE,SUBR

	ENTRY	2

	GETYP	A,2(AB)		;GET 2D TYPE
	CAIE	A,TATOM
	JRST	NOTATO
	MOVE	A,3(AB)		;GET ATOM
	PUSHJ	P,TYPLOO	;LOOK IT UP
	HRRZ	B,(A)		;GET SAT
	GETYP	A,(AB)		;CHECK FOR UVECTOR
	CAIE	A,TUVEC
	JRST	WTYP1
	HLRE	C,1(AB)		;-LENGTH
	HRRZ	E,1(AB)
	SUB	E,C		;POINT TO TYPE
	HLRZ	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
	GETYPF	A,(AB)		;RETURN ARG
	MOVE	B,1(AB)
	JRST	FINIS

WNA:
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
	MOVEI	A,1
	JRST	CALER"

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


CRLF:	MOVEI	A,15
	JRST	TYO"
MSGTYP":	HRLI	B,440700	;MAKE BYTE POINTER
MSGTY1:	ILDB	A,B		;GET NEXT CHARACTER
	JUMPE	A,CPOPJ		;NULL ENDS STRING
	PUSHJ	P,TYO"
	JRST	MSGTY1		;AND GET NEXT CHARACTER
CPOPJ:	POPJ	P,

; HACK TO PRINT MESSAGE OF INTEREST TO USER

MESOUT:	MOVSI	A,(JFCL)
	MOVEM	A,MESSAG		;DO ONLY ONCE
	.SUSET	[.RSNAM,,A]	;READ SNAME AND SAVE
	PUSH	P,A		;AND SAVE
	.SUSET	[.SSNAM,,[SIXBIT /MUDDLE/]
	MOVEI	A,[SIXBIT /   DSKMUDDLEMESSAG/]
	PUSHJ	P,OPEN		;TRY TO OPEN
	JRST	RESNM
MESSI:	PUSHJ	P,IOT		;READ A CHAR
	JUMPL	B,MESCLS	;DONE, QUIT
	EXCH	A,B		;CHAR TO A SAVE CHAN
	CAIE	A,14		;DONT TYPE FF
	PUSHJ	P,TYO		;AND TYPE IT OUT
	MOVE	A,B		;CHANNEL BACK TO A
	JRST	MESSI		;UNTIL DONE

MESCLS:	PUSHJ	P,CLOSE	;AND CLOSE

RESNM:	POP	P,A		;RESTORE SNAME
	.SUSET	[.SSNAM,,A]
	POPJ	P,

MESSAG:	PUSHJ	P,MESOUT		;MESSAGE SWITCH


CRADIX":	10.
PTIME:	0			;UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
OBLNT":	151.			;LENGTH OF INITIAL OBLISTS
VECTOP:	VECLOC
VECBOT":	VECBASE
CODBOT:	0			;ABSOLUTE BOTTOM OF CODE
CODTOP":	PARBASE
PARTOP:	PARLOC
PARBOT":	PARBASE
PVLNTH:	0
TVLNTH:	0
TVBOT:	TVBASE
VECNEW":	0			;LOCATION FOR OFFSET BETWWEN OLD VECTOP AND NEW VECTOP
PARNEW":	0			;LOCATION FOR OFFSET BETTWEEN OLD PARBOT AND NEW PARBOT
INTFLG:	0			;INTERRUPT PENDING FLAG
MAINPR:	0		;HOLDS POINTER TO THE MAIN PROCESS

PATCH:
PAT:	BLOCK	100
PATEND:	0

;GARBAGE COLLECTORS PDLS


GCPDL:	-GCPLNT,,GCPDL

	BLOCK	GCPLNT


;PROCESS PDL


;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

APBAS:	BLOCK	IAPLNT
	IAPLNT+1,,0

VECRET




$TMATO:	TATOM,,-1


END