X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=%3Cmdl.int%3E%2Fatomhk.mid.149;fp=%3Cmdl.int%3E%2Fatomhk.mid.149;h=1fe87faf79d2f1b1997a697be55c3ec4dc2a876d;hp=0000000000000000000000000000000000000000;hb=bab072f950a643ac109660a223b57e635492ac25;hpb=233a3c5245f8274882cc9d27a3c20e9b3678000c

diff --git a/<mdl.int>/atomhk.mid.149 b/<mdl.int>/atomhk.mid.149
new file mode 100644
index 0000000..1fe87fa
--- /dev/null
+++ b/<mdl.int>/atomhk.mid.149
@@ -0,0 +1,1193 @@
+
+TITLE ATOMHACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
+
+LPVP==SP
+TYPNT==AB
+LNKBIT==200000
+
+; FUNCTION TO GENERATE AN EMPTY OBLIST
+
+MFUNCTION MOBLIST,SUBR
+
+	ENTRY
+	CAMGE	AB,[-5,,0]	;CHECK NUMBER OF ARGS
+	JRST	TMA
+	JUMPGE	AB,MOBL2		; NO ARGS
+	MOVE	A,(AB)
+	MOVE	B,1(AB)
+	MOVSI	C,TATOM
+	MOVE	D,IMQUOTE OBLIST
+	PUSHJ	P,IGET		; CHECK IF IT EXISTS ALREADY
+	CAMN	A,$TOBLS
+	JRST	FINIS
+MOBL2:	
+	MOVEI	A,1
+	PUSHJ	P,IBLOCK	;GET A UNIFORM VECTOR
+	MOVSI	C,TLIST+.VECT.	;IT IS OF TYPE LIST
+	HLRE	D,B		;-LENGTH TO D
+	SUBM	B,D		;D POINTS TO DOPE WORD
+	MOVEM	C,(D)		;CLOBBER TYPE IN
+	MOVSI	A,TOBLS
+	JUMPGE	AB,FINIS	; IF NO ARGS, DONE
+	GETYP	A,(AB)
+	CAIE	A,TATOM
+	JRST	WTYP1
+	MOVSI	A,TOBLS
+	PUSH	TP,$TOBLS
+	PUSH	TP,B
+	MOVSI	C,TATOM
+	MOVE	D,IMQUOTE OBLIST
+	PUSH	TP,(AB)
+	PUSH	TP,1(AB)
+	PUSHJ	P,IPUT	; PUT THE NAME ON THE OBLIST
+	MOVE	A,(AB)
+	MOVE	B,1(AB)
+	MOVSI	C,TATOM
+	MOVE	D,IMQUOTE OBLIST
+	PUSH	TP,(TB)
+	PUSH	TP,1(TB)
+	PUSHJ	P,IPUT	; PUT THE OBLIST ON THE NAME
+
+	POP	TP,B
+	POP	TP,A
+	JRST	FINIS
+
+MFUNCTION GROOT,SUBR,ROOT
+	ENTRY 0
+	MOVE	A,ROOT
+	MOVE	B,ROOT+1
+	JRST	FINIS
+
+MFUNCTION GINTS,SUBR,INTERRUPTS
+	ENTRY 0
+	MOVE	A,INTOBL
+	MOVE	B,INTOBL+1
+	JRST FINIS
+
+MFUNCTION GERRS,SUBR,ERRORS
+	ENTRY 0
+	MOVE	A,ERROBL
+	MOVE	B,ERROBL+1
+	JRST	FINIS
+
+
+COBLQ:	SKIPN	B,2(B)		; SKIP IF EXISTS
+	JRST	IFLS
+	MOVSI	A,TOBLS
+
+	ANDI	B,-1
+	CAMG	B,VECBOT	; TVP IS IN FROZEN SPACE, NEVER OBLISTS
+	MOVE	B,(B)
+	HRLI	B,-1
+
+CPOPJ1:	AOS	(P)
+	POPJ	P,
+
+IFLS:	MOVEI	B,0
+	MOVSI	A,TFALSE
+	POPJ	P,
+
+MFUNCTION OBLQ,SUBR,[OBLIST?]
+
+	ENTRY	1
+	GETYP	A,(AB)
+	CAIE	A,TATOM
+	JRST	WTYP1
+	MOVE	B,1(AB)		; GET ATOM
+	PUSHJ	P,COBLQ
+	JFCL
+	JRST	FINIS
+
+; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
+
+MFUNCTION LOOKUP,SUBR
+
+	ENTRY	2
+	PUSHJ	P,ILOOKU	;CALL INTERNAL ROUTINE
+	JRST	FINIS
+
+CLOOKU:	SUBM	M,(P)
+	PUSH	TP,A
+	PUSH	TP,B
+	MOVEI	B,-1(TP)
+	PUSH	TP,$TOBLS
+	PUSH	TP,C
+	GETYP	A,A
+	PUSHJ	P,CSTAK
+	MOVE	B,(TP)
+	MOVSI	A,TOBLS		; THIS IS AN OBLIST
+	PUSHJ	P,ILOOK
+	POP	P,D
+	HRLI	D,(D)
+	SUB	P,D
+	SKIPE	B
+	SOS	(P)
+	SUB	TP,[4,,4]
+	JRST	MPOPJ
+
+ILOOKU:	PUSHJ	P,ARGCHK	;CHECK ARGS
+	PUSHJ	P,CSTACK	;PUT CHARACTERS ON THE STACK
+
+CALLIT:	MOVE	B,3(AB)		;GET OBLIST
+	MOVSI	A,TOBLS
+ILOOKC:	PUSHJ	P,ILOOK		;LOOK IT UP
+	POP	P,D		;RESTORE COUNT
+	HRLI	D,(D)		;TO BOTH SIDES
+	SUB	P,D
+	POPJ	P,
+
+;THIS ROUTINE CHECKS ARG TYPES
+
+ARGCHK:	GETYP	A,(AB)		;GET TYPES
+	GETYP	C,2(AB)
+	CAIE	A,TCHRS		;IS IT EITHER CHAR STRING
+	CAIN	A,TCHSTR
+	CAIE	C,TOBLS		;IS 2ND AN OBLIST
+	JRST	WRONGT		;TYPES ARE WRONG
+	POPJ	P,
+
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
+
+
+CSTACK:	MOVEI	B,(AB)
+CSTAK:	POP	P,D		;RETURN ADDRESS TO D
+	CAIE	A,TCHRS		;IMMEDIATE?
+	JRST	NOTIMM		;NO, HAIR
+	MOVE	A,1(B)		; GET CHAR
+	LSH	A,29.		; POSITION
+	PUSH	P,A		;ONTO P
+	PUSH	P,[1]		;WITH NUMBER
+	JRST	(D)		;GO CALL SEARCHER
+
+NOTIMM:	MOVEI	A,1		; CLEAR CHAR COUNT
+	MOVE	C,(B)		; GET COUNT OF CHARS
+	TRNN	C,-1
+	JRST	NULST		; FLUSH NULL STRING
+	MOVE	PVP,PVSTOR+1
+	MOVEM	C,BSTO(PVP)
+	ANDI	C,-1
+	MOVE	B,1(B)		;GET BYTE POINTER
+
+CLOOP1:	PUSH	P,[0]		; STORE CHARS ON STACK
+	MOVSI	E,(<440700,,(P)>)	; SETUP BYTE POINTER
+CLOOP:	SKIPL	INTFLG		; SO CAN WIN WITH INTERRUPTS
+	 JRST	CLOOP2
+	MOVE	PVP,PVSTOR+1
+	HRRM	C,BSTO(PVP)	;SAVE STRING LENGTH
+	JSR	LCKINT
+CLOOP2:	ILDB	0,B		;GET A CHARACTER
+	IDPB	0,E		;STORE IT
+	SOJE	C,CDONE		; ANY MORE?
+	TLNE	E,760000	; WORD FULL
+	JRST	CLOOP		;NO CONTINUE
+	AOJA	A,CLOOP1	;AND CONTINUE
+
+CDONE:
+CDONE1:	MOVE	PVP,PVSTOR+1
+	SETZM	BSTO(PVP)
+	PUSH	P,A		;AND NUMBER OF WORDS
+	JRST	(D)		;RETURN
+
+
+NULST:	ERRUUO	EQUOTE NULL-STRING
+; THIS FUNCTION LOOKS FOR ATOMS.  CALLED BY PUSHJ P,ILOOK
+;	A,B/	OBLIST POINTER (CAN BE LIST OF SAME)
+;	-1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
+;	CHAR STRING IS ON THE STACK
+;	IF ATOM EXISTS RETURNS:
+;		B/	THE ATOM
+;		C/	THE BUCKET
+;		0/	THE PREVIOUS BUCKET
+;
+;	IF NOT
+;		B/ 0
+;		0/ PREV IF ONE WITH SAME PNAME, ELSE 0
+;		C/ BUCKET
+
+ILOOK:	PUSH	TP,A
+	PUSH	TP,B
+
+	MOVN	A,-1(P)		;GET -LENGTH
+	HRLI	A,-1(A)		;<-LENGTH-1>,,-LENGTH
+	PUSH	TP,$TFIX	;SAVE
+	PUSH	TP,A
+	ADDI	A,-1(P)		;HAVE AOBJN POINTER TO CHARS
+	MOVE	0,[202622077324]		;HASH WORD
+	ROT	0,1
+	TSC	0,(A)
+	AOBJN	A,.-2		;XOR THEM ALL TOGETHER
+	HLRE	A,HASHTB+1
+	MOVNS	A
+	MOVMS	0		; MAKE SURE + HASH CODE
+	IDIVI	0,(A)		;DIVIDE
+	HRLI	A,(A)		;TO BOTH HALVES
+	ADD	A,HASHTB+1
+
+	MOVE	C,A
+	HRRZ	A,(A)		; POINT TO FIRST ATOM
+	SETZB	E,0		; INDICATE NO ATOM
+
+	JUMPE	A,NOTFND
+LOOK2:	HLRZ	E,1(A)		; PREPARE TO BUILD AOBJN
+	ANDI	E,377777	; SIGN MIGHT BE ON IF IN PURIFY ETC.
+	SUBI	E,2
+	HRLS	E
+	SUBB	A,E
+
+	ADD	A,[3,,3]	;POINT TO ATOMS PNAME
+	MOVE	D,(TP)		;GET PSEUDO AOBJN POINTER TO CHARS
+	ADDI	D,-1(P)		;NOW ITS A REAL AOBJN POINTER
+	JUMPE	D,CHECK0	;ONE IS EMPTY
+LOOK1:
+	MOVE	SP,(D)
+	CAME	SP,(A)
+
+	JRST	NEXT1		;THIS ONE DOESN'T MATCH
+	AOBJP	D,CHECK		;ONE RAN OUT
+	AOBJN	A,LOOK1		;JUMP IF STILL MIGHT WIN
+
+NEXT1:	HRRZ	A,-1(TP)	; SEE IF WE'VE ALREADY SEEN THIS NAME
+	GETYP	D,-3(TP)	; SEE IF LIST OF OBLISTS
+	CAIN	D,TLIST
+	JUMPN	A,CHECK3	; DON'T LOOK FURTHER
+	JUMPN	A,NOTFND
+NEXT:
+	MOVE	0,E
+	HLRZ	A,2(E)		; NEXT ATOM
+	JUMPN	A,LOOK2
+	HRRZ	A,-1(TP)
+	JUMPN	A,NEXT1
+
+	SETZB	E,0
+
+NOTFND:
+	MOVEI	B,0
+	MOVSI	A,TFALSE
+CPOPJT:
+
+	SUB	TP,[4,,4]
+	POPJ	P,
+
+CHECK0:	JUMPN	A,NEXT1		;JUMP IF NOT ALSO EMPTY
+	SKIPA
+CHECK:	AOBJN	A,NEXT1		;JUMP IF NO MATCH
+
+CHECK5:	HRRZ	A,-1(TP)	; SEE IF FIRST SHOT AT THIS GUY?
+	SKIPN	A
+	MOVE	B,0		; REMEMBER ATOM FOR FALL BACK
+	HLLOS	-1(TP)		; INDICATE NAME MATCH HAS OCCURRED
+	HRRZ	A,2(E)		; COMPUTE OBLIST POINTER
+	CAMGE	A,VECBOT
+	MOVE	A,(A)
+	HRROS	A
+	GETYP	D,-3(TP)	; SEE IF LIST OF OBLISTS OR
+	CAIE	D,TOBLS
+	JRST	CHECK1
+	CAME	A,-2(TP)	; DO OBLISTS MATCH?
+	JRST	NEXT
+
+CHECK2:	MOVE	B,E		; RETURN ATOM
+	MOVSI	A,TATOM
+	JRST	CPOPJT
+
+CHECK1:	MOVE	D,-2(TP)	; ANY LEFT?
+	CAMN	A,1(D)		; MATCH
+	JRST	CHECK2
+	JRST	NEXT
+
+CHECK3:	MOVE	D,-2(TP)
+	HRRZ	D,(D)
+	MOVEM	D,-2(TP)
+	JUMPE	D,NOTFND
+	JUMPE	B,CHECK6
+	HLRZ	E,2(B)
+CHECK7:	HLRZ	A,1(E)
+	ANDI	A,377777	; SIGN MIGHT BE ON IF IN PURIFY ETC.
+	SUBI	A,2
+	HRLS	A
+	SUBB	E,A
+	JRST	CHECK5
+
+CHECK6:	HRRZ	E,(C)
+	JRST	CHECK7
+
+; FUNCTION TO INSERT AN ATOM ON AN OBLIST
+
+MFUNCTION INSERT,SUBR
+
+	ENTRY	2
+	GETYP	A,2(AB)
+	CAIE	A,TOBLS
+	JRST	WTYP2
+	MOVE	A,(AB)
+	MOVE	B,1(AB)
+	MOVE	C,3(AB)
+	PUSHJ	P,IINSRT
+	JRST	FINIS
+
+CINSER:	SUBM	M,(P)
+	PUSHJ	P,IINSRT
+	JRST	MPOPJ
+
+IINSRT:	PUSH	TP,A
+	PUSH	TP,B
+	PUSH	TP,$TOBLS
+	PUSH	TP,C
+	GETYP	A,A
+	CAIN	A,TATOM
+	JRST	INSRT0
+
+;INSERT WITH A GIVEN PNAME
+
+	CAIE	A,TCHRS
+	CAIN	A,TCHSTR
+	JRST	.+2
+	JRST	WTYP1
+
+	PUSH	TP,$TFIX	;FLAG CALL
+	PUSH	TP,[0]
+	MOVEI	B,-5(TP)
+	PUSHJ	P,CSTAK		;COPY ONTO STACK
+	MOVE	B,-2(TP)
+	MOVSI	A,TOBLS
+	PUSHJ	P,ILOOK		;LOOK IT UP (BUCKET RETURNS IN C)
+	SETZM	-4(TP)
+	SETZM	-5(TP)		; KILL STRING POINTER TO KEEP FROM CONFUSING GC
+	JUMPN	B,ALRDY		;EXISTS, LOSE
+	MOVE	D,-2(TP)	; GET OBLIST BACK
+INSRT1:	PUSH	TP,$TATOM
+	PUSH	TP,0		; PREV ATOM
+	PUSH	TP,$TUVEC	;SAVE BUCKET POINTER
+	PUSH	TP,C
+	PUSH	TP,$TOBLS
+	PUSH	TP,D		; SAVE OBLIST
+INSRT3:	PUSHJ	P,IATOM		; MAKE AN ATOM
+	HLRE	A,B		; FIND DOPE WORD
+	SUBM	B,A
+	ANDI	A,-1
+	SKIPN	E,-4(TP)	; AFTER AN ATOM?
+	 JRST	INSRT7		; NO, FIRST IN BUCKET
+	MOVEI	0,(E)		; CHECK IF PURE
+	CAIG	0,HIBOT
+	 JRST	INSRNP
+	PUSH	TP,$TATOM	; SAVE NEW ATOM
+	PUSH	TP,B
+	MOVE	B,E
+	PUSHJ	P,IMPURIF
+	MOVE	B,(TP)
+	MOVE	E,-6(TP)
+	SUB	TP,[2,,2]
+	HLRE	A,B		; FIND DOPE WORD
+	SUBM	B,A
+	ANDI	A,-1
+
+INSRNP:	HLRZ	0,2(E)		; NEXT
+	HRLM	A,2(E)		; SPLICE
+	HRLM	0,2(B)
+	JRST	INSRT8
+
+INSRT7:	MOVE	E,-2(TP)
+	EXCH	A,(E)
+	HRLM	A,2(B)		; IN CASE OLD ONE
+
+INSRT8:	MOVE	E,(TP)		; GET OBLIST
+	HRRM	E,2(B)		; STORE OBLIST
+	MOVE	E,(E)		; POINT TO LIST OF ATOMS
+	PUSHJ	P,LINKCK
+	PUSHJ	P,ICONS
+	MOVE	E,(TP)
+	HRRM	B,(E)		;INTO NEW BUCKET
+	MOVSI	A,TATOM
+	MOVE	B,1(B)		;GET ATOM BACK
+	MOVE	C,-6(TP)	;GET FLAG
+	SUB	TP,[8,,8]	;POP STACK
+	JUMPN	C,(C)
+	SUB	TP,[4,,4]
+	POPJ	P,
+
+;INSERT WITH GIVEN ATOM
+INSRT0:	MOVE	A,-2(TP)	;GOBBLE PNAME
+	SKIPE	2(A)		; SKIP IF NOT ON AN OBLIST
+	JRST	ONOBL
+	ADD	A,[3,,3]
+	HLRE	C,A
+	MOVNS	C
+	PUSH	P,(A)		;FLUSH PNAME ONTO P STACK
+	AOBJN	A,.-1
+	PUSH	P,C
+	MOVE	B,(TP)		; GET OBLIST FOR LOOKUP
+	MOVSI	A,TOBLS
+	PUSHJ	P,ILOOK		;ALREADY THERE?
+	JUMPN	B,ALRDY
+	MOVE	D,-2(TP)
+
+	HLRE	A,-2(TP)	; FIND DOPE WORD
+	SUBM	D,A		; TO A
+	JUMPE	0,INSRT9	; NO CURRENT ATOM
+	MOVE	E,0
+	MOVEI	0,(E)
+	CAIGE	0,HIBOT		; PURE?
+	 JRST	INSRPN
+	PUSH	TP,$TATOM
+	PUSH	TP,E
+	PUSH	TP,$TATOM
+	PUSH	TP,D
+	MOVE	B,E
+	PUSHJ	P,IMPURIF
+	MOVE	D,(TP)
+	MOVE	E,-2(TP)
+	SUB	TP,[4,,4]
+	HLRE	A,D
+	SUBM	D,A
+
+
+INSRPN:	HLRZ	0,2(E)		; POINT TO NEXT
+	HRLM	A,2(E)		; CLOBBER NEW GUY IN
+	HRLM	0,2(D)		; FINISH SLPICE
+	JRST	INSRT6
+
+INSRT9:	ANDI	A,-1
+	EXCH	A,(C)		; INTO BUCKET
+	HRLM	A,2(D)
+
+INSRT6:	HRRZ	E,(TP)
+	HRRZ	E,(E)
+	MOVE	B,D
+	PUSHJ	P,LINKCK
+	PUSHJ	P,ICONS
+	MOVE	C,(TP)		;RESTORE OBLIST
+	HRRZM	B,(C)
+	MOVE	B,-2(TP)	; GET BACK ATOM
+	HRRM	C,2(B)		; CLOBBER OBLIST IN
+	MOVSI	A,TATOM
+	SUB	TP,[4,,4]
+	POP	P,C
+	HRLI	C,(C)
+	SUB	P,C
+	POPJ	P,
+
+LINKCK:	HRRZ	C,FSAV(TB)	;CALLER'S NAME
+	MOVE	D,B
+	CAIE	C,LINK
+	SKIPA	C,$TATOM	;LET US INSERT A LINK INSTEAD OF AN ATOM
+	SKIPA	C,$TLINK	;GET REAL ATOM FOR CALL TO ICONS
+	POPJ	P,
+	HLRE	A,D
+	SUBM	D,A
+	MOVEI	B,LNKBIT
+	IORM	B,(A)
+	POPJ	P,
+
+
+ALRDY:	ERRUUO	EQUOTE ATOM-ALREADY-THERE
+
+ONOBL:	ERRUUO	EQUOTE ON-AN-OBLIST-ALREADY
+
+; INTERNAL INSERT CALL
+
+INSRTX:	POP	P,0		; GET RET ADDR
+	PUSH	TP,$TFIX
+	PUSH	TP,0
+	PUSH	TP,$TATOM
+	PUSH	TP,[0]
+	PUSH	TP,$TUVEC
+	PUSH	TP,[0]
+	PUSH	TP,$TOBLS
+	PUSH	TP,B
+	MOVSI	A,TOBLS
+	PUSHJ	P,ILOOK
+	JUMPN	B,INSRXT
+	MOVEM	0,-4(TP)
+	MOVEM	C,-2(TP)
+	JRST	INSRT3		; INTO INSERT CODE
+
+INSRXT:	PUSH	P,-4(TP)
+	SUB	TP,[6,,6]
+	POPJ	P,
+	JRST	IATM1
+
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
+
+MFUNCTION REMOVE,SUBR
+
+	ENTRY
+
+	JUMPGE	AB,TFA
+	CAMGE	AB,[-5,,]
+	JRST	TMA
+	MOVEI	C,0
+	CAML	AB,[-3,,]	; SKIP IF OBLIST GIVEN
+	JRST	.+5
+	GETYP	0,2(AB)
+	CAIE	0,TOBLS
+	JRST	WTYP2
+	MOVE	C,3(AB)
+	MOVE	A,(AB)
+	MOVE	B,1(AB)
+	PUSHJ	P,IRMV
+	JRST	FINIS
+
+CIRMV:	SUBM	M,(P)
+	PUSHJ	P,IRMV
+	JRST	MPOPJ
+
+IRMV:	PUSH	TP,A
+	PUSH	TP,B
+	PUSH	TP,$TOBLS
+	PUSH	TP,C
+IRMV1:	GETYP	0,A		; CHECK 1ST ARG
+	CAIN	0,TLINK
+	JRST	.+3
+	CAIE	0,TATOM		; ATOM, TREAT ACCORDINGLY
+	JRST	RMV1
+
+	HRRZ	D,2(B)		; SKIP IF ON OBLIST AND GET SAME
+	JUMPE	D,RMVDON
+	CAMG	D,VECBOT	; SKIP IF REAL OBLIST
+	HRRZ	D,(D)		; NO, REF, GET IT
+
+	JUMPGE	C,GOTOBL
+	CAIE	D,(C)		; BETTER BE THE SAME
+	JRST	ONOTH
+
+GOTOBL:	ADD	B,[3,,3]	; POINT TO PNAME
+	HLRE	A,B
+	MOVNS	A
+	PUSH	P,(B)		; PUSH PNAME
+	AOBJN	B,.-1
+	PUSH	P,A
+	HRROM	D,(TP)		; SAVE OBLIST
+	JRST	RMV3
+
+RMV1:	JUMPGE	C,TFA
+	CAIE	0,TCHRS
+	CAIN	0,TCHSTR
+	SKIPA	A,0
+	JRST	WTYP1
+	MOVEI	B,-3(TP)
+	PUSHJ	P,CSTAK
+RMV3:	MOVE	B,(TP)
+	MOVSI	A,TOBLS
+	PUSHJ	P,ILOOK
+	POP	P,D
+	HRLI	D,(D)
+	SUB	P,D
+	JUMPE	B,RMVDON
+
+	MOVEI	A,(B)
+	CAIGE	A,HIBOT		; SKIP IF PURE
+	JRST	RMV2
+	PUSH	TP,$TATOM
+	PUSH	TP,0
+	PUSHJ	P,IMPURIFY
+	MOVE	0,(TP)
+	SUB	TP,[2,,2]
+	MOVE	A,-3(TP)
+	MOVE	B,-2(TP)
+	MOVE	C,(TP)
+	JRST	IRMV1
+
+RMV2:	JUMPN	0,RMV9		; JUMP IF FIRST NOT IN BUCKET
+	HLRZ	0,2(B)		; POINT TO NEXT
+	MOVEM	0,(C)
+	JRST	RMV8
+
+RMV9:	MOVE	C,0		; C IS PREV ATOM
+	HLRZ	0,2(B)		; NEXT
+	HRLM	0,2(C)
+
+RMV8:	SETZM	2(B)		; CLOBBER OBLIST SLOT
+	MOVE	C,(TP)		; GET OBLIST FOR SPLICE OUT
+	MOVEI	0,-1
+	HRRZ	E,(C)
+
+RMV7:	JUMPE	E,RMVDON
+	CAMN	B,1(E)		; SEARCH OBLIST
+	JRST	RMV6
+	MOVE	C,E
+	HRRZ	E,(C)
+	SOJG	0,RMV7
+
+RMVDON:	SUB	TP,[4,,4]
+	MOVSI	A,TATOM
+	POPJ	P,
+
+RMV6:	HRRZ	E,(E)
+	HRRM	E,(C)		; SMASH IN
+	JRST	RMVDON
+
+
+;INTERNAL CALL FROM THE READER
+
+RLOOKU:	PUSH	TP,$TFIX	;PUSH A FLAG
+	POP	P,C		;POP OFF RET ADR
+	PUSH	TP,C		;AND USE AS A FLAG FOR INTERNAL
+	MOVE	C,(P)		; CHANGE CHAR COUNT TO WORD
+	ADDI	C,4
+	IDIVI	C,5
+	MOVEM	C,(P)
+	GETYP	D,A
+
+	CAIN	D,TOBLS		;IS IT ONE OBLIST?
+	JRST	.+3
+	CAIE	D,TLIST		;IS IT A LIST
+	JRST	BADOBL
+
+	JUMPE	B,BADLST
+	PUSH	TP,$TUVEC	; SLOT FOR REMEBERIG
+	PUSH	TP,[0]
+	PUSH	TP,$TOBLS
+	PUSH	TP,[0]
+	PUSH	TP,A
+	PUSH	TP,B
+	CAIE	D,TLIST
+	JRST	RLOOK1
+
+	PUSH	TP,$TLIST
+	PUSH	TP,B
+RLOOK2:	GETYP	A,(B)		;CHECK THIS IS AN OBLIST
+	CAIE	A,TOBLS
+	JRST	DEFALT
+
+	SKIPE	-4(TP)		; SKIP IF DEFAULT NOT STORED
+	JRST	RLOOK4
+	MOVE	D,1(B)		; OBLIST
+	MOVEM	D,-4(TP)
+RLOOK4:	INTGO
+	HRRZ	B,@(TP)		;CDR THE LIST
+	HRRZM	B,(TP)
+	JUMPN	B,RLOOK2
+	SUB	TP,[2,,2]
+	JRST	.+3
+
+RLOOK1:	MOVE	B,(TP)
+	MOVEM	B,-2(TP)
+	MOVE	A,-1(TP)
+	MOVE	B,(TP)
+	PUSHJ	P,ILOOK
+	JUMPN	B,RLOOK3
+	SKIPN	D,-2(TP)	; RESTORE FOR INSERT
+	JRST	BADDEF		; NO DEFAULT, USER LOST ON SPECIFICATION
+	SUB	TP,[6,,6]	; FLUSH CRAP
+	SKIPN	NOATMS
+	 JRST	INSRT1
+	  JRST	INSRT1
+
+DEFFLG==1	;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
+		; SPECIFIED
+DEFALT:	MOVE	0,1(B)
+	CAIN	A,TATOM		;SPECIAL DEFAULT INDICATING ATOM ?
+	CAME	0,MQUOTE DEFAULT
+	JRST	BADDEF		;NO, LOSE
+	MOVEI	A,DEFFLG
+	XORB	A,-11(TP)	;SET AND TEST FLAG
+	TRNN	A,DEFFLG	; HAVE WE BEEN HERE BEFORE ?
+	JRST	BADDEF		; YES, LOSE
+	SETZM	-6(TP)		;ZERO OUT PREVIOUS DEFAULT
+	SETZM	-4(TP)
+	JRST	RLOOK4		;CONTINUE
+
+
+INSRT2:	JRST	.+2		;
+RLOOK3:	SUB	TP,[6,,6]	;POP OFF LOSSAGE
+	PUSHJ	P,ILINK		;IF THIS IS A LINK FOLLOW IT
+	PUSH	P,(TP)		;GET BACK RET ADR
+	SUB	TP,[2,,2]	;POP TP
+	JRST	IATM1		;AND RETURN
+
+
+BADOBL:	ERRUUO	EQUOTE BAD-OBLIST-OR-LIST-THEREOF
+
+BADDEF:	ERRUUO	EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
+
+ONOTH:	ERRUUO	EQUOTE ATOM-ON-DIFFERENT-OBLIST
+;SUBROUTINE TO MAKE AN ATOM
+
+IMFUNCTION ATOM,SUBR
+
+	ENTRY	1
+
+	MOVE	A,(AB)
+	MOVE	B,1(AB)
+	PUSHJ	P,IATOMI
+	JRST	FINIS
+
+CATOM:	SUBM	M,(P)
+	PUSHJ	P,IATOMI
+	JRST	MPOPJ
+
+IATOMI:	GETYP	0,A		;CHECK ARG TYPE
+	CAIE	0,TCHRS
+	CAIN	0,TCHSTR
+	JRST	.+2		;JUMP IF WINNERS
+	JRST	WTYP1
+
+	PUSH	TP,A
+	PUSH	TP,B
+	MOVEI	B,-1(TP)
+	MOVE	A,0
+	PUSHJ	P,CSTAK		;COPY ONTO STACK
+	PUSHJ	P,IATOM		;NOW MAKE THE ATOM
+	SUB	TP,[2,,2]
+	POPJ	P,
+
+;INTERNAL ATOM MAKER
+
+IATOM:	MOVE	A,-1(P)		;GET WORDS IN PNAME
+	ADDI	A,3		;FOR VALUE CELL
+	PUSHJ	P,IBLOCK	; GET BLOCK
+	MOVSI	C,<(GENERAL)>+SATOM	;FOR TYPE FIELD
+	MOVE	D,-1(P)		;RE-GOBBLE LENGTH
+	ADDI	D,3(B)		;POINT TO DOPE WORD
+	MOVEM	C,(D)
+	SKIPG	-1(P)		;EMPTY PNAME ?
+	JRST	IATM0		;YES, NO CHARACTERS TO MOVE
+	MOVE	E,B		;COPY ATOM POINTER
+	ADD	E,[3,,3]	;POINT TO PNAME AREA
+	MOVEI	C,-1(P)
+	SUB	C,-1(P)		;POINT TO STRING ON STACK
+	MOVE	D,(C)		;GET SOME CHARS
+	MOVEM	D,(E)		;AND COPY THEM
+	ADDI	C,1
+	AOBJN	E,.-3
+IATM0:	MOVSI	A,TATOM	;TYPE TO ATOM
+IATM1:	POP	P,D		;RETURN ADR
+	POP	P,C
+	HRLI	C,(C)
+	SUB	P,C
+	JRST	(D)		;RETURN
+
+;SUBROUTINE TO GET AN ATOM'S PNAME
+
+MFUNCTION PNAME,SUBR
+
+	ENTRY 1
+
+	GETYP	A,(AB)
+	CAIE	A,TATOM		;CHECK TYPE IS ATOM
+	JRST	WTYP1
+	MOVE	A,1(AB)
+	PUSHJ	P,IPNAME
+	JRST	FINIS
+
+CIPNAM:	SUBM	M,(P)
+	PUSHJ	P,IPNAME
+	JRST	MPOPJ
+
+IPNAME:	ADD	A,[3,,3]
+	HLRE	B,A
+	MOVM	B,B
+	PUSH	P,(A)		;FLUSH PNAME ONTO P
+	AOBJN	A,.-1
+	MOVE	0,(P)		; LAST WORD
+	PUSHJ	P,PNMCNT
+	PUSH	P,B
+	PUSHJ	P,CHMAK		;MAKE A STRING
+	POPJ	P,
+
+PNMCNT:	IMULI	B,5		; CHARS TO B
+	MOVE	A,0
+	SUBI	A,1		; FIND LAST 1
+	ANDCM	0,A		; 0 HAS 1ST 1
+	JFFO	0,.+1
+	HRREI	0,-34.(A)	; FIND HOW MUCH TO ADD
+	IDIVI	0,7
+	ADD	B,0
+	POPJ	P,
+
+MFUNCTION SPNAME,SUBR
+
+	ENTRY	1
+
+	GETYP	0,(AB)
+	CAIE	0,TATOM
+	JRST	WTYP1
+
+	MOVE	B,1(AB)
+	PUSHJ	P,CSPNAM
+	JRST	FINIS
+
+CSPNAM:	ADD	B,[3,,3]
+	MOVEI	D,(B)
+	HLRE	A,B
+	SUBM	B,A
+	MOVE	0,-1(A)
+	HLRES	B
+	MOVMS	B
+	PUSHJ	P,PNMCNT
+	MOVSI	A,TCHSTR
+	HRRI	A,(B)
+	MOVSI	B,010700
+	HRRI	B,-1(D)
+	POPJ	P,
+
+; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
+
+IMFUNCTION BLK,SUBR,BLOCK
+
+	ENTRY	1
+
+	GETYP	A,(AB)	;CHECK TYPE OF ARG
+	CAIE	A,TOBLS	;IS IT AN OBLIST
+	CAIN	A,TLIST	;OR A LIAT
+	JRST	.+2
+	JRST	WTYP1
+	MOVSI	A,TATOM	;LOOK UP OBLIST
+	MOVE	B,IMQUOTE OBLIST
+	PUSHJ	P,IDVAL	;GET VALUE
+	PUSH	TP,A
+	PUSH	TP,B
+	MOVE	PVP,PVSTOR+1
+	PUSH	TP,.BLOCK(PVP)	;HACK THE LIST
+	PUSH	TP,.BLOCK+1(PVP)
+	MCALL	2,CONS	;CONS THE LIST
+	MOVE	PVP,PVSTOR+1
+	MOVEM	A,.BLOCK(PVP)	;STORE IT BACK
+	MOVEM	B,.BLOCK+1(PVP)
+	PUSH	TP,$TATOM
+	PUSH	TP,IMQUOTE OBLIST
+	PUSH	TP,(AB)
+	PUSH	TP,1(AB)
+	MCALL	2,SET	;SET OBLIST TO ARG
+	JRST	FINIS
+
+MFUNCTION ENDBLOCK,SUBR
+
+	ENTRY	0
+
+	MOVE	PVP,PVSTOR+1
+	SKIPN	B,.BLOCK+1(PVP)	;IS THE LIST NIL?
+	JRST	BLKERR	;YES, LOSE
+	HRRZ	C,(B)	;CDR THE LIST
+	HRRZM	C,.BLOCK+1(PVP)
+	PUSH	TP,$TATOM	;NOW RESET OBLIST
+	PUSH	TP,IMQUOTE OBLIST
+	HLLZ	A,(B)	;PUSH THE TYPE OF THE CAR
+	PUSH	TP,A
+	PUSH	TP,1(B)	;AND VALUE OF CAR
+	MCALL	2,SET
+	JRST	FINIS
+
+BLKERR:	ERRUUO	EQUOTE UNMATCHED
+
+BADLST:	ERRUUO	EQUOTE NIL-LIST-OF-OBLISTS
+;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
+
+CHMAK:	MOVE	A,-1(P)
+	ADDI	A,4
+	IDIVI	A,5
+	PUSHJ	P,IBLOCK
+	MOVEI	C,-1(P)		;FIND START OF CHARS
+	HLRE	E,B		; - LENGTH
+	ADD	C,E		;C POINTS TO START
+	MOVE	D,B		;COPY VECTOR RESULT
+	JUMPGE	D,NULLST	;JUMP IF EMPTY
+	MOVE	A,(C)		;GET ONE
+	MOVEM	A,(D)
+	ADDI	C,1		;BUMP POINTER
+	AOBJN	D,.-3		;COPY
+NULLST:	MOVSI	C,TCHRS+.VECT.		;GET TYPE
+	MOVEM	C,(D)		;CLOBBER IT IN
+	MOVE	A,-1(P)		; # WORDS
+	HRLI	A,TCHSTR
+	HRLI	B,010700
+	MOVMM	E,-1(P)		; SO IATM1 WORKS
+	SOJA	B,IATM1		;RETURN
+
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.
+;   TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
+
+NXTDCL:	GETYP	B,(A)		;CHECK TYPE
+	CAIE	B,TDEFER		;LOSE IF NOT DEFERRED
+	POPJ	P,
+
+	MOVE	B,1(A)		;GET REAL BYTE POINTER
+CHRWRD:	PUSH	P,C
+	GETYP	C,(B)		;CHECK IT IS CHSTR
+	CAIE	C,TCHSTR
+	JRST	CPOPJC		;NO, QUIT
+	PUSH	P,D
+	PUSH	P,E
+	PUSH	P,0
+	MOVEI	E,0		;INITIALIZE DESTINATION
+	HRRZ	C,(B)		; GET CHAR COUNT
+	JUMPE	C,GOTDCL	; NULL, FINISHED
+	MOVE	B,1(B)		;GET BYTE POINTER
+	MOVE	D,[440700,,E]	;BYTE POINT TO E
+CHLOOP:	ILDB	0,B		; GET A CHR
+	IDPB	0,D		;CLOBBER AWAY
+	SOJE	C,GOTDCL	; JUMP IF DONE
+	TLNE	D,760000	; SKIP IF WORD FULL
+	JRST	CHLOOP		; MORE THAN 5 CHARS
+	TRO	E,1		; TURN ON FLAG
+
+GOTDCL:	MOVE	B,E		;RESULT TO B
+	AOS	-4(P)		;SKIP RETURN
+CPOPJ0:	POP	P,0
+	POP	P,E
+	POP	P,D
+CPOPJC:	POP	P,C
+	POPJ	P,
+
+;ROUTINES TO DEFINE AND HANDLE LINKS
+
+MFUNCTION LINK,SUBR
+	ENTRY
+	CAML	AB,[-6,,0]	;NO MORE THAN 3 ARGS
+	CAML	AB,[-2,,0]	;NO LESS THAN 2 ARGS
+	JRST	WNA
+	CAML	AB,[-4,,0]	;ONLY TWO ARGS SUPPLIED ?
+	JRST	GETOB		;YES, GET OBLIST FROM CURRENT PATH
+	MOVE	A,2(AB)
+	MOVE	B,3(AB)
+	MOVE	C,5(AB)
+	JRST	LINKIN
+GETOB:	MOVSI	A,TATOM
+	MOVE	B,IMQUOTE OBLIST
+	PUSHJ	P,IDVAL
+	CAMN	A,$TOBLS
+	JRST	LINKP
+	CAME	A,$TLIST
+	JRST	BADOBL
+	JUMPE	B,BADLST
+	GETYPF	A,(B)
+	MOVE	B,(B)+1
+LINKP:	MOVE	C,B
+	MOVE	A,2(AB)
+	MOVE	B,3(AB)
+LINKIN:	PUSHJ	P,IINSRT
+	CAMN	A,$TFALSE	;LINK NAME ALREADY USED ?
+	JRST	ALRDY		;YES, LOSE
+	MOVE	C,B
+	MOVE	A,(AB)
+	MOVE	B,1(AB)
+	PUSHJ	P,CSETG
+	JRST	FINIS
+
+
+ILINK:	HLRE	A,B
+	SUBM	B,A		;FOUND A LINK ?
+	MOVE	A,(A)
+	TRNE	A,LNKBIT
+	 JRST	.+3
+	MOVSI	A,TATOM
+	POPJ	P,		;NO, FINISHED
+	MOVSI	A,TATOM
+	PUSHJ	P,IGVAL		;GET THE LINK'S DESTINATION
+	CAME	A,$TUNBOUND	;WELL FORMED LINK ?
+	POPJ	P,		;YES
+	ERRUUO	EQUOTE BAD-LINK
+
+
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPURIFY:
+	PUSH	TP,$TATOM
+	PUSH	TP,B
+	MOVE	C,B
+	MOVEI	0,(C)
+	CAIGE	0,HIBOT
+	JRST	RTNATM		; NOT PURE, RETURN
+	JRST	IMPURX
+
+; ROUTINE PASSED TO GCHACK
+
+ATFIX:	CAME	D,(TP)
+	 CAMN	D,-2(TP)
+	  JRST	.+2
+	POPJ	P,
+
+	ASH	C,1
+	ADD	C,TYPVEC+1	; COMPUTE SAT
+	HRRZ	C,(C)
+	ANDI	C,SATMSK
+	CAIE	C,SATOM
+CPOPJ:	POPJ	P,
+
+	SUB	D,-2(TP)
+	ADD	D,-4(TP)
+	SKIPE	B
+	MOVEM	D,1(B)
+	POPJ	P,
+
+
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
+
+BYTDOP:	PUSH	P,B		; SAVE SOME ACS
+	PUSH	P,D
+	PUSH	P,E
+	MOVE	B,1(C)		; GET BYTE POINTER
+	LDB	D,[360600,,B]	; POSITION TO D
+	LDB	E,[300600,,B]	; AND BYTE SIZE
+	MOVEI	A,(E)		; A COPY IN A
+	IDIVI	D,(E)		; D=> # OF BYTES IN WORD 1
+	HRRZ	E,(C)		; GET LENGTH
+	SUBM	E,D		; # OF BYTES IN OTHER WORDS
+	JUMPL	D,BYTDO1	; NEAR DOPE WORD
+	MOVEI	B,36.		; COMPUTE BYTES PER WORD
+	IDIVM	B,A
+	ADDI	D,-1(A)		; NOW COMPUTE WORDS
+	IDIVI	D,(A)		; D/ # NO. OF WORDS PAST 1ST
+	ADD	D,1(C)		; D POINTS TO DOPE WORD
+	MOVEI	A,2(D)
+
+BYTDO2:	POP	P,E
+	POP	P,D
+	POP	P,B
+	POPJ	P,
+BYTDO1:	MOVEI	A,2(B)
+	JRST	BYTDO2
+
+; 1) IMPURIFY ITS OBLIST LIST
+
+IMPURX:	HRRZ	B,2(C)		; PICKUP OBLIST IF IT EXISTS
+	JUMPE	B,IMPUR0	; NOT ON ONE, IGNORE THIS CODE
+
+	HRRO	E,(B)
+	PUSH	TP,$TOBLS	; SAVE BUCKET
+	PUSH	TP,E
+
+	MOVE	B,(E)		; GET NEXT ONE
+IMPUR4:	MOVEI	0,(B)
+	MOVE	D,1(B)
+	CAME	D,-2(TP)
+	JRST	.+3
+	SKIPE	GPURFL		; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
+				;   ATOM
+	HRRM	D,1(B)
+	CAIGE	0,HIBOT		; SKIP IF PURE
+	JRST	IMPUR3		; FOUND IMPURE NESS, SKIP IT
+	HLLZ	C,(B)		; SET UP ICONS CALL
+	HRRZ	E,(B)
+IMPR1:	PUSHJ	P,ICONS		; CONS IT UP
+IMPR2:	HRRZ	E,(TP)		; RETRV PREV
+	HRRM	B,(E)		; AND CLOBBER
+IMPUR3:	MOVE	D,1(B)
+	CAMN	D,-2(TP)	; HAVE GOTTEN TO OUR SLOT?
+	JRST	IMPPR3
+	MOVSI	0,TLIST
+	MOVEM	0,-1(TP)	; FIX TYPE
+	HRRZM	B,(TP)		; STORE GOODIE
+	HRRZ	B,(B)		; CDR IT
+	JUMPN	B,IMPUR4	; LOOP
+IMPPR3:	SUB	TP,[2,,2]	; FLUSH TP CRUFT
+
+; 1.5)	IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
+
+IMPUR0:	MOVE	C,(TP)		; GET ATOM
+
+	HRRZ	B,2(C)
+	MOVE	B,(B)
+	ADD	C,[3,,3]	; POINT TO PNAME
+	HLRE	A,C		; GET LNTH IN WORDS OF PNAME
+	MOVNS	A
+;	PUSH	P,[SETZ IMPUR2]	; FAKE OUT ILOOKC
+	XMOVEI	0,IMPUR2
+	PUSH	P,0
+	PUSH	P,(C)		; PUSH UP THE PNAME
+	AOBJN	C,.-1
+	PUSH	P,A		; NOW THE COUNT
+	MOVSI	A,TOBLS
+	JRST	ILOOKC		; GO FIND BUCKET
+
+IMPUR2:	JUMPE	B,IMPUR1
+	JUMPE	0,IMPUR1		; YUP, DONE
+	HRRZ	C,0
+	CAIG	C,HIBOT		; SKIP IF PREV IS PURE
+	JRST	IMPUR1
+
+	MOVE	B,0
+	PUSH	P,GPURFL	; PRERTEND OUT OF PURIFY
+	HLRE	C,B
+	SUBM	B,C
+	HRRZ	C,(C)		; ARE WE ON PURIFY LIST
+	CAIG	C,HIBOT		; IF SO, WE ARE STILL PURIFY
+	SETZM	GPURFL
+	PUSHJ	P,IMPURIF	; RECURSE
+	POP	P,GPURFL
+	MOVE	B,(TP)		; AND RETURN ORIGINAL	
+
+; 2) GENERATE A DUPLICATE ATOM
+
+IMPUR1:	SKIPE	GPURFL		; SEE IF IN PURIFY
+	JRST	IMPUR7
+	HLRE	A,(TP)		; GET LNTH OF ATOM
+	MOVNS	A
+	PUSH	P,A
+	PUSHJ	P,IBLOCK	; GET NEW BLOCK FOR ATOM
+	PUSH	TP,$TATOM
+	PUSH	TP,B
+	HRL	B,-2(TP)		; SETUP BLT
+	POP	P,A
+	ADDI	A,(B)		; END OF BLT
+	BLT	B,(A)		; CLOBBER NEW ATOM
+	MOVSI	B,.VECT.	; TURN ON BIT FOR GCHACK
+	IORM	B,(A)
+
+; 3) NOW COPY GLOBAL VALUE
+
+IMPUR7:	MOVE	B,(TP)		; ATOM BACK
+	GETYP	0,(B)
+	SKIPE	A,1(B)		; NON-ZER POINTER?
+	CAIN	0,TUNBOU	; BOUND?
+	JRST	IMPUR5		; NO, DONT COPY GLOB VAL
+	PUSH	TP,(A)
+	PUSH	TP,1(A)		
+	PUSH	TP,$TATOM
+	PUSH	TP,B
+	SETZM	(B)
+	SETZM	1(B)
+	SKIPN	GPURFL		; HERE IS SOME CODE NEEDED FOR PURIFY
+	JRST	IMPUR8
+	PUSH	P,LPVP
+	MOVE	PVP,PVSTOR+1
+	PUSH	P,AB		; GET AB BACK
+	MOVE	AB,ABSTO+1(PVP)
+IMPUR8:	PUSHJ	P,BSETG		; SETG IT
+	SKIPN	GPURFL
+	JRST	.+3		; RESTORE SP AND AB FOR PURIFY
+	POP	P,TYPNT
+	POP	P,SP
+	SUB	TP,[2,,2]	; KILL ATOM SLOTS ON TP
+	POP	TP,C		;POP OFF VALUE SLOTS
+	POP	TP,A
+	MOVEM	A,(B)		; FILL IN SLOTS ON GLOBAL STACK
+	MOVEM	C,1(B)
+IMPUR5:	SKIPE	GPURFL		; FINISH OFF DIFFERENTLY FOR PURIFY
+	JRST	IMPUR9
+
+	PUSH	TP,$TFIX	;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
+	PUSH	TP,-3(TP)
+	PUSH	TP,$TFIX	; OTHER KIND OF POINTER ALSO
+	HLRE	0,-1(TP)
+	HRRZ	A,-1(TP)
+	SUB	A,0
+	PUSH	TP,A
+
+; 4) UPDATE ALL POINTERS TO THIS ATOM
+
+	MOVE	A,[PUSHJ P,ATFIX]	; INS TO PASS TO GCHACK
+	MOVEI	PVP,1		; SAY MIGHT BE NON-ATOMS
+	PUSHJ	P,GCHACK
+	SUB	TP,[6,,6]
+
+RTNATM:	POP	TP,B
+	POP	TP,A
+	POPJ	P,
+
+IMPUR9:	SUB	TP,[2,,2]
+	POPJ	P,		; RESTORE AND GO
+
+
+
+END