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

diff --git a/sumex/initm.mcr186 b/sumex/initm.mcr186
new file mode 100644
index 0000000..e200eca
--- /dev/null
+++ b/sumex/initm.mcr186
@@ -0,0 +1,785 @@
+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
+
+
+