TITLE INITIALIZATION FOR MUDDLE

RELOCATABLE

LAST==1	;POSSIBLE CHECKS DONE LATER

.INSRT MUDDLE >

SYSQ

IFE ITS,[
FATINS==.FATAL"
SEVEC==104000,,204
]

IMPURE

OBSIZE==151.	;DEFAULT OBLIST SIZE

.LIFG <TVBASE+TVLNT-TVLOC>
.LOP .VALUE
.ELDC


.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP
.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE
.GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER
.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC
.GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1
; INIITAL AMOUNT OF AFREE SPACE

STOSTR:	BLOCK	400		; A RANDOM AMOUNT
ISTOST:	401,,0

SETUP:
IFN ITS,	.SUSET	[.RUNAM,,%UNAM]		; FOR AGC'S BENFIT
	MOVE	P,GCPDL		;GET A PUSH DOWN STACK
IFN ITS,	.SUSET	[.SMASK,,[200000]]	; ENABLE PDL OVFL
	MOVE	TVP,[-TVLNT,,TVBASE]	;GET INITIAL TRANSFER VECTOR
	PUSHJ	P,TTYOPE		;OPEN THE TTY
	AOS	A,20		; TOP OF LOW SEGG
	HRRZM	A,P.TOP
	SOSN	A		; IF NOTHING YET
IFN ITS,	.SUSET	[.RMEMT,,P.TOP]
IFE ITS,	JRST	4,
	HRRE	A,P.TOP		; CHECK TOP
	TRNE	A,377777		; SKIP IF ALL LOW SEG
	JUMPL	A,PAGLOS	; COMPLAIN
	MOVE	A,HITOP		; FIND HI SEG TOP
	ADDI	A,1777
	ANDCMI	A,1777
	MOVEM	A,RHITOP	; SAVE IT
	MOVEI	A,200
	SUBI	A,PHIBOT
	JUMPE	A,HIBOK
	MOVSI	A,(A)
	HRRI	A,200
IFN ITS,[
	.CALL	GIVCOR
	.VALUE
]
HIBOK:	MOVEI	B,[ASCIZ /MUDDLE INITIALIZATION.
/]
	PUSHJ	P,MSGTYP	;PRINT IT
	MOVE	A,CODTOP	;CHECK FOR A WINNING LOAD
	CAML	A,VECBOT	;IT BETTER BE LESS
	JRST	DEATH1		;LOSE COMPLETELY
	MOVE	B,PARBOT	;CHECK FOR ANY PAIRS
	CAME	B,PARTOP	;ANY LOAD/ASSEMBLE TIME PAIRS?
	JRST	PAIRCH		;YES CHECK THEM
	ADDI	A,2000		;BUMP UP
	ANDCMI	A,1777
	MOVEM	A,PARBOT	;UPDATE PARBOT AND TOP
	MOVEM	A,PARTOP
SETTV:	MOVE	PVP,[-PVLNT*2,,GCPVP]	;AND A PROCESS VECTOR
	MOVEI	A,(PVP)		;SET UP A BLT
	HRLI	A,PVBASE	;FROM PROTOTYPE
	BLT	A,PVLNT*2-1(PVP)	;INITIALIZE
	MOVE	TP,[-ITPLNT,,TPBAS]	;GET A STACK FOR THIS PROCCESS
	MOVEI	TB,(TP)		;AND A BASE
	HRLI	TB,1
	SUB	TP,[1,,1]	;POP ONCE

; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS

	PUSH	P,[5]		;COUNT INITIAL OBLISTS

	PUSH	P,OBLNT		;SAVE CURRENT OBLIST DEFAULT SIZE

MAKEOB:	SOS	A,-1(P)
	MOVE	A,OBSZ(A)
	MOVEM	A,OBLNT
	MCALL	0,MOBLIST	;GOBBLE AN OBLIST
	PUSH	TP,$TOBLS	;AND SAVE THEM
	PUSH	TP,B
	MOVE	A,(P)-1		;COUNT DOWN
	MOVEM	B,@OBTBL(A)	;STORE
	JUMPN	A,MAKEOB

	POP	P,OBLNT		;RESTORE DEFAULT OBLIST SIZE

	MOVE	C,TVP		;MAKE 2 COPIES OF XFER VECTOR POINTER
	MOVE	D,TVP

;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE
;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR

ILOOP:	HLRZ	A,(C)		;FIRST TYPE
	JUMPE	A,TVEXAU	;USEFUL STUFF EXHAUSTED
	CAIN	A,TCHSTR	;CHARACTER STRING?
	JRST	CHACK		;YES, GO HACK IT
	CAIN	A,TATOM		;ATOM?
	JRST	ATOMHK		;YES, CHECK IT OUT
	MOVE	A,(C)		;MOVE TO NEW HOME (MAY BE SAME)
	MOVEM	A,(D)
	MOVE	A,1(C)
	MOVEM	A,1(D)
SETLP:	AOS	(P)		;COUNT NUMBER OF PAIRS IN XFER VECTOR
	ADD	D,[2,,2]	;OUT COUNTER
SETLP1:	ADD	C,[2,,2]	;AND IN COUNTER
	JUMPL	C,ILOOP		;JUMP IF MORE TO DO
;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST

TVEXAU:	HLRE	B,C		;GET -LENGTH
	SUBI	C,(B)		;POIT TO DOPE WORD
	ANDI	C,-1		;NO LH
	HLRZ	A,1(C)		;INTIAL LENGTH TO A
	MOVEI	E,(C)		;COPY OF POINTER TO DOPW WD
	SUBI	E,(D)		;AMOUNT LEFT OVER TO E
	HRLZM	E,1(C)		;CLOBBER INTO DOPE WORD FOR GARBAGE
	MOVSI	E,(E)		;PREPARE TO UPDATE TVP
	ADD	TVP,E		;NOW POINTS TO THE RIGHT AMOUNT
	HLRE	B,D		;-AMOUNT LEFT TO B
	ADD	B,A		;AMOUNT OF GOOD STUFF
	HRLZM	B,1(D)		;STORE IT IN GODD DOPE WORD
	MOVSI	E,400000	;CLOBBER TO GENERAL IN BOTH CASES
	MOVEM	E,(C)
	MOVEM	E,(D)


; FIX UP TYPE VECTOR

	MOVE	A,TYPVEC+1(TVP)	;GET POINTER
	MOVEI	0,0		;FOR POSSIBLE NULL SLOTS
	MOVSI	B,TATOM		;SET TYPE TO ATOM

TYPLP:	HLLM	B,(A)		;CHANGE TYPE TO ATOM
	MOVE	C,@1(A)		;GET ATOM
	MOVEM	C,1(A)
	ADD	A,[2,,2]		;BUMP
	JUMPL	A,TYPLP
; CLOSE TTY CHANNELS
IFN ITS,[

	.CLOSE	1,
	.CLOSE	2,
]

;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS

;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL

	IRP	A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]
	IRP	B,C,[A]
	PUSH	TP,$!C
	PUSH	TP,CHQUOTE B
	.ISTOP
	TERMIN
	TERMIN

	MCALL	2,FOPEN		;OPEN THE OUT PUT CHANNEL
	MOVEM	B,TTOCHN+1(TVP)	;SAVE IT

;ASSIGN AS GLOBAL VALUE

	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OUTCHAN
	PUSH	TP,A
	PUSH	TP,B
	MOVE	A,[PUSHJ P,MTYO]	;MORE WINNING INS
	MOVEM	A,IOINS(B)	;CLOBBER
	MCALL	2,SETG

;SETUP A CALL TO OPEN THE TTY CHANNEL

	IRP	A,,[[READ,TCHSTR],[TTY:,TCHSTR]]
	IRP	B,C,[A]
	PUSH	TP,$!C
	PUSH	TP,CHQUOTE B
	.ISTOP
	TERMIN
	TERMIN

	MCALL	2,FOPEN		;OPEN INPUTCHANNEL
	MOVEM	B,TTICHN+1(TVP)	;SAVE IT
	PUSH	TP,$TATOM	;ASSIGN AS A GLOBAL VALUE
	PUSH	TP,IMQUOTE INCHAN
	PUSH	TP,A
	PUSH	TP,B
	MOVE	C,BUFRIN(B)	;GET AUX BUFFER PTR
	MOVE	A,[PUSHJ P,MTYI]
	MOVEM	A,IOIN2(C)	;MORE OF A WINNER
	MOVE	A,[PUSHJ P,MTYO]
	MOVEM	A,ECHO(C)	;ECHO INS
	MCALL	2,SETG

;GENERATE AN INITIAL PROCESS AND SWAP IT IN

	PUSHJ	P,ICR	;CREATE IT
	MOVEI	0,RUNING
	MOVEM	0,PSTAT"+1(B)
	MOVE	D,B	;SET UP TO CALL SWAP
	JSP	C,SWAP	;AND SWAP IN
	MOVEM	PVP,MAINPR"	;SAVE AS THE MAIN PROCESS
	PUSH	TP,[TENTRY,,TOPLEV]	;BUILD DUMMY FRAME
	PUSH	TP,[1,,0]
	MOVEI	A,-1(TP)
	PUSH	TP,A
	PUSH	TP,SP
	PUSH	TP,P
	MOVE	C,TP	;COPY TP
	ADD	C,[3,,3]	;FUDGE
	PUSH	TP,C	;TPSAV PUSHED
	PUSH	TP,[TOPLEV]
	HRRI	TB,(TP)	;SETUP TB
	HRLI	TB,2
	ADD	TB,[1,,1]
	MOVEM	TB,TBINIT+1(PVP)
	MOVSI	A,TSUBR
	MOVEM	A,RESFUN(PVP)
	MOVEI	A,LISTEN"
	MOVEM	A,RESFUN+1(PVP)
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE THIS-PROCESS
	PUSH	TP,$TPVP
	PUSH	TP,PVP
	MCALL	2,SETG

; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE

	MOVEI	A,MQUOTE T
	SUBI	A,(TVP)
TVTOFF==0
	ADDSQU	TVTOFF

	MOVEM	A,SQULOC-1

	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE TVTOFF,,MUDDLE
	PUSH	TP,$TFIX
	PUSH	TP,A
	MCALL	2,SETG

; HERE TO SETUP SQUOZE TABLE IN PURE CORE

	PUSHJ	P,SQSETU	; GO TO ROUTINE

	MOVEI	A,400000	; FENCE POST PURE SR VECTOR
	HRRM	A,PURVEC(TVP)
	MOVE	A,TP
	HLRE	B,A
	SUBI	A,-PDLBUF(B)	;POINT TO DOPE WORDS
	MOVEI	B,12	;GROWTH SPEC
	IORM	B,(A)
	MOVEI	0,ISTOST
	MOVEM	0,CODTOP
	PUSHJ	P,AAGC	;DO IT
	AOJL	A,.-1
	MOVE	A,TPBASE+1(PVP)
	SUB	A,[640.,,640.]
	MOVEM	A,TPBASE+1(PVP)

; CREATE LIST OF ROOT AND NEW OBLIST

	MOVEI	A,5
	PUSH	P,A

NAMOBL:	PUSH	TP,$TATOM
	PUSH	TP,@OBNAM-1(A)	; NAME
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OBLIST
	PUSH	TP,$TOBLS
	PUSH	TP,@OBTBL-1(A)
	MCALL	3,PUT		; NAME IT
	SOS	A,(P)
	PUSH	TP,$TOBLS
	PUSH	TP,@OBTBL(A)
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OBLIST
	PUSH	TP,$TATOM
	PUSH	TP,@OBNAM(A)
	MCALL	3,PUT
	SKIPE	A,(P)
	JRST	NAMOBL
	SUB	P,[1,,1]

;Define MUDDLE version number
	MOVEI	A,5
	MOVEI	B,0		;Initialize result
	MOVE	C,[440700,,MUDSTR+2]
VERLP:	ILDB	D,C		;Get next charcter digit
	CAIG	D,"9		;Non-digit ?
	CAIGE	D,"0
	JRST	VERDEF
	SUBI	D,"0		;Convert to number
	IMULI	B,10.
	ADD	B,D		;Include number into result
	SOJG	A,VERLP		;Finished ?
VERDEF:
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE MUDDLE
	PUSH	TP,$TFIX
	PUSH	TP,B
	MCALL	2,SETG		;Make definition
OPIPC:
IFN ITS,[
	PUSH	TP,$TCHSTR
	PUSH	TP,CHQUOTE IPC
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE IPC-HANDLER
	MCALL	1,GVAL
	PUSH	TP,A
	PUSH	TP,B
	PUSH	TP,$TFIX
	PUSH	TP,[1]
	MCALL	3,ON
	MCALL	0,IPCON
]

; Allocate inital template tables

	MOVEI	A,10
	PUSHJ	P,CAFRE1
	ADD	B,[10,,10]		; REST IT OFF
	MOVEM	B,TD.LNT+1(TVP)
	MOVEI	A,10
	PUSHJ	P,CAFRE1
	MOVEI	0,TUVEC		; SETUP UTYPE
	HRLM	0,10(B)
	MOVEM	B,TD.GET+1(TVP)
	MOVEI	A,10
	PUSHJ	P,CAFRE1
	MOVEI	0,TUVEC		; SETUP UTYPE
	HRLM	0,10(B)
	MOVEM	B,TD.PUT+1(TVP)

PTSTRT:	MOVEI	A,SETUP
	ADDI	A,1
	SUB	A,PARBOT	;FIND WHERE PAIRS SHOULD GO
	MOVEM	A,PARNEW
IFE ITS,[
	MOVEI	A,400000
	MOVE	B,[1,,START]
	SEVEC
]
	PUSH	P,[14.,,14.]	;PUSH A SMALL PRGRM ONTO P
	MOVEI	A,1(P)	;POINT TO ITS START
	PUSH	P,[JRST AAGC]	;GO TO AGC
	PUSH	P,[MOVE B,PSTO+1(PVP)]	;GET SAVED P
	PUSH	P,[SUB B,-13.(P)]	;FUDGE TO POP OFF PROGRAM
	PUSH	P,[MOVEM B,PSAV(TB)]	;INTO FRAME
	PUSH	P,[MOVE B,TPSTO+1(PVP)]	;GET TP
	PUSH	P,[MOVEM B,TPSAV(TB)]	;STORE IT
	PUSH	P,[MOVE B,SPSTO+1(PVP)]	;SP
	PUSH	P,[MOVEM B,SPSAV(TB)]
	PUSH	P,[MOVEI B,TOPLEV]	;WHERE TO GO
	PUSH	P,[MOVEM B,PCSAV(TB)]
IFN ITS,	PUSH	P,[MOVSI B,(.VALUE )]
IFE ITS,	PUSH	P,[MOVSI B,(JRST 4,)]
	PUSH	P,[HRRI B,C]
	PUSH	P,[JRST B]	;GO DO VALRET
	PUSH	P,[B]
	PUSH	P,A		; PUSH START ADDR
	MOVE	B,[JRST -11.(P)]
	MOVE	0,[JUMPA START]
	MOVE	C,[ASCII \0/9\]
	MOVE	D,[ASCII \B/1Q\]
	MOVE	E,[ASCIZ \
*
\]		;TERMINATE
	POPJ	P,		; GO

; CHECK PAIR SPACE

PAIRCH:	CAMG	A,B
	JRST	SETTV		;O.K.

DEATH1:	MOVEI	B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP
/]
	PUSHJ	P,MSGTYP
	.VALUE

;CHARACTER STRING HACKER

CHACK:	MOVE	A,(C)		;GET TYPE
	HLLZM	A,(D)		;STORE IN NEW HOME
	MOVE	B,1(C)		;GET POINTER
	HLRZ	E,B		;-LENGHT
	HRRM	E,(D)
	PUSH	P,E+1		; IDIVI WILL CLOBBER
	ADDI	E,4+5*2		; ROUND AND ACCOUNT FOR DOPE WORDS
	IDIVI	E,5		; E/ WORDS LONG
	PUSHJ	P,EBPUR		; MAKE A PURIFIED COPY
	POP	P,E+1
	HRLI	B,440700	;MAKE POINT BYTER
	MOVEM	B,1(D)		;AND STORE IT
	ANDI	A,-1	;CLEAR LH OF A
	JUMPE	A,SETLP	;JUMP IF NO REF
	MOVE	E,(P)		;GET OFFSET
	LSH	E,1
	HRRZ	B,-1(A)	;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR
	CAIE	B,$TCHSTR	;SKIP IF IT DOES
	JRST	CHACK1	;NO, JUST DO CHQUOTE PART
	HRRM	E,-1(A)	;CLOBBER
	MOVEI	B,TVP
	DPB	B,[220400,,-1(A)]	;CLOBBER INDEX FIELD
CHACK1:	ADDI	E,1
	HRRM	E,(A)		;STORE INTO REFERENCE
	JRST	SETLP

; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT

EBPUR:	PUSH	P,E
	PUSH	P,A
	ADD	E,HITOP		; GET NEW TOP
	CAMG	E,RHITOP	; SKIP IF TOO BIG
	JRST	EBPUR1

;  CODE TO GROW HI SEG 

	MOVEI	A,2000
	ADDB	A,RHITOP	; NEW TOP
IFN ITS,[
	ASH	A,-10.		; NUM OF BLOCKS
	SUBI	A,1		; BLOCK TO GET
	.CALL	HIGET
	.VALUE
]

EBPUR1:	MOVEI	A,-1(E)		; NEEDED TO TERMINATE BLT
	EXCH	E,HITOP
	HRLI	E,(B)
	MOVEI	B,(E)
	BLT	E,(A)
	POP	P,A
	POP	P,E
	POPJ	P,

GIVCOR:	SETZ
	SIXBIT /CORBLK/
	1000,,0
	1000,,-1
	SETZ	A

HIGET:	SETZ
	SIXBIT /CORBLK/
	1000,,100000
	1000,,-1
	A
	401000,,400001


; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T
; ALREADY THERE

ATOMHK:	PUSH	TP,$TOBLS	; SAVE OBLIST
	PUSH	TP,[0]		; FILLED IN LATER
	PUSH	TP,$TVEC	;SAVE TV POINTERS
	PUSH	TP,C
	PUSH	TP,$TVEC
	PUSH	TP,D
	MOVE	B,1(C)		;GET THE ATOM
	PUSH	TP,$TATOM	;AND SAVE
	PUSH	TP,B
	HRRZ	A,(B)		;GET OBLIST SPEC FROM ATOM
	LSH	A,1
	ADDI	A,1(TB)		;POINT TO ITS HOME
	PUSH	TP,$TOBLS
	PUSH	TP,(A)		;AND SAV IT
	MOVE	A,(A)
	MOVEM	A,-10(TP)	; CLOBBER
	HLRE	E,A
	MOVNS	E

	ADD	B,[3,,3]	;POINT TO ATOM'S PNAME
	MOVEI	A,0		;FOR HASHING
	XOR	A,(B)
	AOBJN	B,.-1
	TLZ	A,400000	;FORCE POSITIVE RESULT
	IDIV	A,E
	HRLS	B		;REMAINDER IN B IS BUCKET
	ADDB	B,(TP)		;UPDATE POINTER

	SKIPN	C,(B)		;GOBBLE BUCKET CONTENTS
	JRST	USEATM		;NONE, LEAVE AND USE THIS ATOM
OBLOO3:	MOVE	E,-2(TP)	;RE-GOBBLE ATOM
	ADD	E,[3,,3]	;POINT TO PNAME
	SKIPN	D,1(C)		;CHECK LIST ELEMNT
	JRST	NXTBCK		;0, CHECK NEXT IN THIS BUCKET
	ADD	D,[3,,3]	;POINT TO PNAME
OBLOO2:	MOVE	A,(D)		;GET A WORD
	CAME	A,(E)		;COMPARE
	JRST	NXTBCK		;THEY DIFFER, TRY NEX
OBLOOP:	AOBJP	E,CHCKD		;COULD BE A MATCH, GO CHECK
	AOBJN	D,OBLOO2	;HAVEN'T LOST YET

NXTBCK:	HRRZ	C,(C)		;CDR THE LIST
	JUMPN	C,OBLOO3	;IF NOT NIL, KEEP TRYING

;HERE IF THIS ATOM MUST BE PUT ON OBLIST

USEATM:	MOVE	B,-2(TP)		; GET ATOM
	HLRZ	0,(B)		; SEE IF PURE OR NOT
	TRNN	0,400000	; SKIP IF IMPURE
	JRST	PURATM
	MOVE	B,(TP)		;POINTER TO BUCKET
	HRRZ	C,(B)		;POINTER TO LIST IN THIS BUCKET
	PUSH	TP,$TATOM	;GENERATE CALL TO CONS
	PUSH	TP,-3(TP)
	PUSH	TP,$TLIST
	PUSH	TP,C
	MCALL	2,CONS		;CONS IT UP
	MOVE	C,(TP)		;REGOBBLE BUCKET POINTER
	HRRZM	B,(C)		;CLOBBER
	MOVE	B,-2(TP)	;POINT TO ATOM
	MOVE	C,-10(TP)		; GET OBLIST
	MOVEM	C,2(B)		; INTO ATOM
	PUSHJ	P,VALMAK	;MAKE A GLOBAL VALUE FOR THIS LOSER
PURAT2:	MOVE	C,-6(TP)	;RESET POINTERS
	MOVE	D,-4(TP)
	SUB	TP,[12,,12]
	MOVE	B,(C)		;MOVE THE ENTRY
	HLLZM	B,(D)		;DON'T WANT REF POINTER STORED
	MOVE	A,1(C)		;AND MOVE ATOM
	MOVEM	A,1(D)
	MOVE	A,(P)		;GET CURRENT OFFSET
	LSH	A,1
	ADDI	A,1
	ANDI	B,-1		;CHECK FOR REAL REF
	JUMPE	B,SETLP1	;DON'T SAVE THIS ATOM ON TVP
	HRRM	A,(B)		;CLOBBER CODE
	JRST	SETLP


; HERE TO MAKE A PURE ATOM

PURATM:	HRRZ	B,-2(TP)	; POINT TO IT
	HLRE	E,-2(TP)	; - LNTH
	MOVNS	E
	ADDI	E,2
	PUSHJ	P,EBPUR		; PURE COPY
	HRRM	B,-2(TP)	; AND STORE BACK
	HRRO	B,(TP)		; GET BUCKET BACK
PURAT1:	HRRZ	C,(B)		; GET CONTENTS
	JUMPE	C,HICONS	; AT END, OK
	CAIL	C,HIBOT		; SKIP IF IMPURE
	JRST	HICONS	; CONS IT ON
	MOVEI	B,(C)
	JRST	PURAT1

HICONS:	HRLI	C,TATOM
	PUSH	P,C
	PUSH	P,-2(TP)
	PUSH	P,B
	MOVEI	B,-2(P)
	MOVEI	E,2
	PUSHJ	P,EBPUR		; MAKE PURE LIST CELL

	MOVE	C,(P)
	SUB	P,[3,,3]
	HRRM	B,(C)		; STORE IT
	MOVE	B,1(B)		; ATOM BACK
	MOVE	C,-6(TP)	; GET TVP SLOT
	HRRM	B,1(C)		; AND STORE
	HLRZ	0,(B)		; TYPE OF VAL
	MOVE	C,B
	CAIN	0,TUNBOU	; NOT UNBOUND?
	JRST	PURAT3		; UNBOUND, NO VAL
	MOVEI	E,2		; COUNT AGAIN
	PUSHJ	P,EBPUR		; VALUE CELL
	MOVE	C,-2(TP)		; ATOM BACK
	HLLZS	(B)		; CLEAR LH
	MOVSI	0,TLOCI
	HLLM	0,(C)
	MOVEM	B,1(C)
PURAT3:	HRRZ	A,(C)		; GET OBLIST CODE
	MOVE	A,OBTBL2(A)
	MOVEM	A,2(C)		; STORE OBLIST SLOT
	HLLZS	(C)
	JRST	PURAT2

; A POSSIBLE MATCH ARRIVES HERE

CHCKD:	AOBJN	D,NXTBCK	;SIZES DIFFER, JUMP
	MOVE	D,1(C)		;THEY MATCH!,  GET EXISTING ATOM
	MOVEI	A,(D)		;GET TYPE OF IT
	MOVE	B,-2(TP)	;GET NEW ATOM
	HLRZ	0,(B)
	TRZ	A,377777	; SAVE ONLY 400000 BIT
	TRZ	0,377777
	CAIN	0,(A)		; SKIP IF WIN
	JRST	IM.PUR
	MOVSI	0,400000
	ANDCAM	0,(B)
	ANDCAM	0,(D)
	HLRZ	A,(D)
	CAIE	A,TUNBOU	;UNBOUND?
	JRST	A1VAL		;YES, CONTINUE
	MOVE	A,(B)		;MOVE VALUE
	MOVEM	A,(D)
	MOVE	A,1(B)
	MOVEM	A,1(D)
	MOVE	B,D		;EXISTING ATOM TO B
	MOVEI	0,(B)
	CAIL	0,HIBOT
	JRST	.+3
	PUSHJ	P,VALMAK	;MAKE A VALUE
	JRST	.+2
	PUSHJ	P,PVALM

;NOW FIND ATOMS OCCURENCE IN XFER VECTOR

OFFIND:	MOVE	D,-4(TP)	;GET CURRENT POINTER INTO TP
	MOVE	C,TVP		;AND A COPY OF TVP
	MOVEI	A,0		;INITIALIZE COUNTER
ALOOP:	CAMN	B,1(C)		;IS THIS IT?
	JRST	AFOUND
	ADD	C,[2,,2]	;BUMP COUNTER
	CAMGE	C,D		;HAVE WE HIT END
	AOJA	A,ALOOP		;NO, KEEP LOOKING

	MOVEI	B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED
/]
TYPIT:	PUSHJ	P,MSGTYP
	.VALUE

AFOUND:	LSH	A,1		;FOUND ATOM, GET REAL OFFSET
	ADDI	A,1
	MOVE	C,-6(TP)	;GET TV POINTER TO NEW ATOM
	HRRZ	B,(C)		;POINT TO REFERENCE
	SKIPE	B		;ANY THERE?
	HRRM	A,(B)		;YES, CLOBBER AWAY
	SUB	TP,[12,,12]
	JRST	SETLP1		;AND GO ON

A1VAL:	HLRZ	C,(B)		;GET VALUE'S TYPE
	MOVE	B,D		;NOW PUT EXISTING ATOM IN B
	CAIN	C,TUNBOU	;UNBOUND?
	JRST	OFFIND		;YES, WINNER

	MOVEI	B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES
/]
	JRST	TYPIT


IM.PUR:	MOVEI	B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE
/]
	JRST	TYPIT

PAGLOS:	MOVEI	B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT
/]
	JRST	TYPIT

;MAKE A VALUE IN SLOT ON GLOBAL SP

VALMAK:	HLRZ	A,(B)		;TYPE OF VALUE
	CAIE	A,400000+TUNBOU
	CAIN	A,TUNBOU	;VALUE?
	POPJ	P,		;NO, ALL DONE
	MOVE	A,GLOBSP+1(TVP)	;GET POINTER TO GLOBAL SP
	SUB	A,[4,,4]	;ALLOCATE SPACE
	CAMG	A,GLOBAS+1(TVP)	;CHECK FOR OVERFLOW
	JRST	SPOVFL
	MOVEM	A,GLOBSP+1(TVP)	;STORE IT BACK
	MOVE	C,(B)		;GET TYPE CELL
	TLZ	C,400000
	HLLZM	C,2(A)		;INTO TYPE CELL
	MOVE	C,1(B)		;GET VALUE
	MOVEM	C,3(A)		;INTO VALUE SLOT
	MOVSI	C,TGATOM	;GET TATOM,,0
	MOVEM	C,(A)
	MOVEM	B,1(A)		;AND POINTER TO ATOM
	MOVSI	C,TLOCI		;NOW CLOBBER THE ATOM
	MOVEM	C,(B)		;INTO TYPE CELL
	ADD	A,[2,,2]	;POINT TO VALUE
	MOVEM	A,1(B)
	POPJ	P,

SPOVFL:	MOVEI	B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW
/]
	JRST	TYPIT


PVALM:	HLRZ	0,(B)
	CAIE	0,400000+TUNBOU
	CAIN	0,TUNBOU
	POPJ	P,
	MOVEI	E,2
	PUSH	P,B
	PUSHJ	P,EBPUR
	POP	P,C
	MOVEM	B,1(C)
	MOVSI	0,TLOCI
	MOVEM	0,(C)
	MOVE	B,C
	POPJ	P,
;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER

VECTGO DUMMY1

IRP	A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1
ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER
IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR
MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS
CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ
CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN
CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG
CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR
OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY
CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO
CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT
CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C
CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL
CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC
CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1
CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS]
	.GLOBAL	A
	ADDSQU A
	MAKAT [A]TFIX,A,MUDDLE,0
TERMIN

VECRET

; ROUTINE TO SORT AND PURIFY SQUOZE TABLE

SQSETU:	MOVE	A,[SQUTBL-SQULOC+2,,SQUTBL]
	MOVEI	0,1
SQ2:	MOVE	B,(A)
	CAMG	B,2(A)
	JRST	SQ1
	MOVEI	0,0
	EXCH	B,2(A)
	MOVEM	B,(A)
	MOVE	B,1(A)
	EXCH	B,3(A)
	MOVEM	B,1(A)
SQ1:	ADD	A,[2,,2]
	JUMPL	A,SQ2
	JUMPE	0,SQSETU
	MOVEI	E,SQULOC-SQUTBL
	MOVEI	B,SQUTBL
	PUSHJ	P,EBPUR		; TO THE PURE WORLD
	HRLI	B,SQUTBL-SQULOC
	MOVEM	B,SQUPNT"
	POPJ	P,
	
RHITOP:	0

OBSZ:	151.
	151.
	151.
	151.
	317.

OBTBL2:	ROOT+1
	ERROBL+1
	INTOBL+1
	MUDOBL+1
	INITIAL+1

OBTBL:	INITIAL+1(TVP)
	MUDOBL+1(TVP)
	INTOBL+1(TVP)
	ERROBL+1(TVP)
	ROOT+1(TVP)
OBNAM:	MQUOTE INITIAL
	MQUOTE MUDDLE
	MQUOTE INTERRUPTS
	MQUOTE ERRORS
	MQUOTE ROOT

END SETUP