PDP-10.its/src/mudsys/atomhk.151

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
.GLOBAL NOATMS

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
	HLRE	A,B
	SUBM	B,A
	MOVE	A,(A)
	TRNE	A,LNKBIT
	 SKIPA	A,$TLINK
	  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