TITLE ATOMHACKER FOR MUDDLE

RELOCATABLE

.INSRT MUDDLE >
.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE
.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP
.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY
.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG

.VECT.==40000		; BIT FOR GCHACK

; 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
	PUSH	TP,(AB)
	PUSH	TP,1(AB)
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OBLIST
	MCALL	2,GET		; CHECK IF IT EXISTS ALREADY
	CAMN	A,$TOBLS
	JRST	FINIS
MOBL2:	MOVE	A,OBLNT		;GET DEFAULT LENGTH
	CAML	AB,[-3,,0]	;IS LENGTH SUPPLIED
	JRST	MOBL1		;NO, USE STANDARD LENGTH
	GETYP	C,2(AB)		;GET ARG TYPE
	CAIE	C,TFIX
	JRST	WTYP2		;LOSE
	MOVE	A,3(AB)		;GET LENGTH
MOBL1:	PUSH	TP,$TFIX
	PUSH	TP,A
	MCALL	1,UVECTOR	;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
	PUSH	TP,$TOBLS
	PUSH	TP,B
	PUSH	TP,$TOBLS
	PUSH	TP,B
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OBLIST
	PUSH	TP,(AB)
	PUSH	TP,1(AB)
	MCALL	3,PUT	; PUT THE NAME ON THE OBLIST
	PUSH	TP,(AB)
	PUSH	TP,1(AB)
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE OBLIST
	PUSH	TP,(TB)
	PUSH	TP,1(TB)
	MCALL	3,PUT	; PUT THE OBLIST ON THE NAME

	POP	TP,B
	POP	TP,A
	JRST	FINIS

MFUNCTION GROOT,SUBR,ROOT
	ENTRY 0
	MOVE	A,ROOT(TVP)
	MOVE	B,ROOT+1(TVP)
	JRST	FINIS

MFUNCTION GINTS,SUBR,INTERRUPTS
	ENTRY 0
	MOVE	A,INTOBL(TVP)
	MOVE	B,INTOBL+1(TVP)
	JRST FINIS

MFUNCTION GERRS,SUBR,ERRORS
	ENTRY 0
	MOVE	A,ERROBL(TVP)
	MOVE	B,ERROBL+1(TVP)
	JRST	FINIS


COBLQ:	SKIPN	B,2(B)		; SKIP IF EXISTS
	JRST	IFLS
	MOVSI	A,TOBLS
	JUMPL	B,CPOPJ1
	ADDI	B,(TVP)
	MOVE	B,(B)
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)
	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
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
	HRRZ	C,(B)		; GET COUNT OF CHARS
	JUMPE	C,NULST	; FLUSH NULL STRING
	MOVE	B,1(B)		;GET BYTE POINTER

CLOOP1:	PUSH	P,[0]		; STORE CHARS ON STACK
	MOVSI	E,(<440700,,(P)>)	; SETUP BYTE POINTER
CLOOP:	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:	PUSH	P,A		;AND NUMBER OF WORDS
	JRST	(D)		;RETURN


NULST:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE NULL-STRING
	JRST	CALER1
; THIS FUNCTION LOOKS FOR ATOMS.  CALLED BY PUSHJ P,ILOOK
;	B/	OBLIST POINTER
;	-1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
;	CHAR STRING IS ON THE STACK

ILOOK:	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
	MOVEI	D,0		;HASH WORD
	XOR	D,(A)
	AOBJN	A,.-1		;XOR THEM ALL TOGETHER
	HLRE	A,B		;GET LENGTH OF OBLIST
	MOVNS	A
	TLZ	D,400000	; MAKE SURE + HASH CODE
	IDIVI	D,(A)		;DIVIDE
	HRLI	E,(E)		;TO BOTH HALVES
	ADD	B,E		;POINT TO BUCKET

	MOVEI	0,(B)		;IN CASE REMOVING 1ST
	SKIPN	C,(B)		;BUCKET EMPTY?
	JRST	NOTFND		;YES, GIVE UP
LOOK2:	SKIPN	A,1(C)		;NIL CAR ON LIST?
	JRST	NEXT		;YES TRY NEXT
	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	E,(D)		;GET A WORD
	CAME	E,(A)		;COMPARE
	JRST	NEXT		;THIS ONE DOESN'T MATCH
	AOBJP	D,CHECK		;ONE RAN OUT
	AOBJN	A,LOOK1		;JUMP IF STILL MIGHT WIN

NEXT:	MOVEI	0,(C)		;POINT TO PREVIOUS ELEMENT
	HRRZ	C,(C)		;STEP THROUGH
	JUMPN	C,LOOK2

NOTFND:	EXCH	C,B		;RETURN BUCKET IN B
	MOVSI	A,TFALSE
CPOPJT:	SUB	TP,[2,,2]	;REMOVE RANDOM TP STUFF
	POPJ	P,

CHECK0:	JUMPN	A,NEXT		;JUMP IF NOT ALSO EMPTY
	SKIPA
CHECK:	AOBJN	A,NEXT		;JUMP IF NO MATCH
	HLLZ	A,(C)
	MOVE	E,B		; RETURN BUCKET
	MOVE	B,1(C)		;GET ATOM
	JRST	CPOPJT


; 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)
	PUSHJ	P,ILOOK		;LOOK IT UP (BUCKET RETURNS IN C)
	JUMPN	B,ALRDY		;EXISTS, LOSE
	MOVE	D,-2(TP)	; GET OBLIST BACK
INSRT1:	PUSH	TP,$TOBLS	;SAVE BUCKET POINTER
	PUSH	TP,C
	PUSH	TP,$TOBLS
	PUSH	TP,D		; SAVE OBLIST
INSRT3:	PUSHJ	P,IATOM		; MAKE AN ATOM
	PUSHJ	P,LINKCK	; A LINK REALLY NEEDED ?
	MOVE	E,-2(TP)
	HRRZ	E,(E)		; GET BUCKET
	PUSHJ	P,ICONS
	MOVE	C,-2(TP)	;BUCKET AGAIN
	HRRM	B,(C)		;INTO NEW BUCKET
	MOVSI	A,TATOM
	MOVE	B,1(B)		;GET ATOM BACK
	MOVE	D,(TP)		; GET OBLIST
	MOVEM	D,2(B)		; AND CLOBBER
	MOVE	C,-4(TP)	;GET FLAG
	SUB	TP,[6,,6]	;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
	PUSHJ	P,ILOOK		;ALREADY THERE?
	JUMPN	B,ALRDY
	PUSH	TP,$TOBLS	;SAVE NECESSARY STUFF AWAY FROM CONS
	PUSH	TP,C		;WHICH WILL MAKE A LIST FROM THE ATOM
	MOVSI	C,TATOM
	MOVE	D,-4(TP)
	PUSHJ	P,INCONS
	MOVE	C,(TP)		;RESTORE
	HRRZ	D,(C)
	HRRM	B,(C)
	HRRM	D,(B)
	MOVE	C,-2(TP)
	MOVE	B,-4(TP)	; GET BACK ATOM
	MOVEM	C,2(B)		; CLOBBER OBLIST IN
	MOVSI	A,TATOM
	SUB	TP,[6,,6]
	POP	P,C
	HRLI	C,(C)
	SUB	P,C
	POPJ	P,

LINKCK:	HRRZ	C,FSAV(TB)	;CALLER'S NAME
	CAIN	C,LINK
	SKIPA	C,$TLINK	;LET US INSERT A LINK INSTEAD OF AN ATOM
	MOVSI	C,TATOM		;GET REAL ATOM FOR CALL TO ICONS
	MOVE	D,B
	POPJ	P,



ALRDY:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE ATOM-ALREADY-THERE
	JRST	CALER1

ONOBL:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE ON-AN-OBLIST-ALREADY
	JRST	CALER1

; INTERNAL INSERT CALL

INSRTX:	POP	P,0		; GET RET ADDR
	PUSH	TP,$TFIX	
	PUSH	TP,0
	PUSH	TP,$TOBLS
	PUSH	TP,B
	PUSH	TP,$TOBLS
	PUSH	TP,B
	PUSHJ	P,ILOOK
	JUMPN	B,INSRXT
	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

	SKIPN	D,2(B)		; SKIP IF ON OBLIST AND GET SAME
	JRST	IFALSE
	JUMPL	D,.+3
	ADDI	D,(TVP)
	MOVE	D,(D)
	JUMPE	C,GOTOBL
	CAME	C,D		; 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
	MOVEM	D,(TP)		; SAVE OBLIST
	JRST	RMV3

RMV1:	JUMPE	C,TFA
	CAIE	0,TCHRS
	CAIN	0,TCHSTR
	SKIPA	A,0
	JRST	WTYP1
	MOVEI	B,-3(TP)
	PUSHJ	P,CSTAK
RMV3:	MOVE	B,(TP)
	PUSHJ	P,ILOOK
	POP	P,D
	HRLI	D,(D)
	SUB	P,D
	JUMPE	B,RMVDON
	HRRZ	D,0		;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)
	HRRZ	C,(C)		;GET NEXT OF LOSING PAIR
	MOVEI	0,(B)
	CAIGE	0,HIBOT		; SKIP IF PURE
	JRST	RMV2
	PUSHJ	P,IMPURIFY
	MOVE	A,-3(TP)
	MOVE	B,-2(TP)
	MOVE	C,(TP)
	JRST	IRMV1
RMV2:	HRRM	C,(D)		;AND SPLICE
	SETZM	2(B)		; CLOBBER OBLIST SLOT
RMVDON:	SUB	TP,[4,,4]
	POPJ	P,


;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)

	CAMN	A,$TOBLS	;IS IT ONE OBLIST?
	JRST	RLOOK1
	CAME	A,$TLIST	;IS IT A LIST
	JRST	BADOBL

	JUMPE	B,BADLST
	PUSH	TP,$TOBLS	; SLOT FOR REMEBERIG
	PUSH	TP,[0]
	PUSH	TP,$TOBLS
	PUSH	TP,[0]
	PUSH	TP,A
	PUSH	TP,B

RLOOK2:	GETYP	A,(B)		;CHECK THIS IS AN OBLIST
	MOVE	B,1(B)		;VALUE
	CAIE	A,TOBLS
	JRST	DEFALT
	PUSHJ	P,ILOOK		;LOOK IT UP
	JUMPN	B,RLOOK3	;WIN
	SKIPE	-2(TP)		; SKIP IF DEFAULT NOT STORED
	JRST	RLOOK4
	HRRZ	D,(TP)		; GET CURRENT
	MOVE	D,1(D)		; OBLIST
	MOVEM	D,-2(TP)
	MOVEM	C,-4(TP)	; FOR INSERT IF NEEDED
RLOOK4:	INTGO
	HRRZ	B,@(TP)		;CDR THE LIST
	HRRZM	B,(TP)
	JUMPN	B,RLOOK2
	SKIPN	D,-2(TP)	; RESTORE FOR INSERT
	JRST	BADDEF		; NO DEFAULT, USER LOST ON SPECIFICATION
	MOVE	C,-4(TP)
	SUB	TP,[6,,6]	; FLUSH CRAP
	JRST	INSRT1

DEFFLG==1	;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED
DEFALT:	CAIN	A,TATOM		;SPECIAL DEFAULT INDICATING ATOM ?
	CAME	B,MQUOTE DEFAULT
	JRST	BADDEF		;NO, LOSE
	MOVSI	A,DEFFLG
	XORB	A,-6(TP)	;SET AND TEST FLAG
	TLNN	A,DEFFLG	; HAVE WE BEEN HERE BEFORE ?
	JRST	BADDEF		; YES, LOSE
	SETZM	-2(TP)		;ZERO OUT PREVIOUS DEFAULT
	SETZM	-4(TP)
	JRST	RLOOK4		;CONTINUE

RLOOK1:	PUSH	TP,$TOBLS
	PUSH	TP,B		; SAVE OBLIST
	PUSHJ	P,ILOOK	;LOOK IT UP THERE
	MOVE	D,(TP)		; GET OBLIST
	SUB	TP,[2,,2]
	JUMPE	B,INSRT1	;GO INSET IT


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:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF
	JRST	CALER1

BADDEF:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
	JRST	CALER1

ONOTH:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST
	JRST	CALER1
;SUBROUTINE TO MAKE AN ATOM

MFUNCTION 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
	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+.VECT.	;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
	IMULI	B,5		; CHARS TO B
	MOVE	0,(P)		; LAST WORD
	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
	PUSH	P,B
	PUSHJ	P,CHMAK		;MAKE A STRING
	POPJ	P,

; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE

MFUNCTION 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
	PUSH	TP,.BLOCK(PVP)	;HACK THE LIST
	PUSH	TP,.BLOCK+1(PVP)
	MCALL	2,CONS	;CONS THE LIST
	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

	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:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE UNMATCHED
	JRST	CALER1

BADLST:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE NIL-LIST-OF-OBLISTS
	JRST	CALER1
;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,440700
	MOVMM	E,-1(P)		; SO IATM1 WORKS
	JRST	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,

; 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,1(B)
	CAME	D,[-5]
	AOJA	A,BYTDO2
	JRST	BYTDO2
;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:	CAME	A,$TLINK	;FOUND A LINK ?
	POPJ	P,		;NO, FINISHED
	MOVSI	A,TATOM
	PUSHJ	P,IGVAL		;GET THE LINK'S DESTINATION
	CAME	A,$TUNBOUND	;WELL FORMED LINK ?
	POPJ	P,		;YES
	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE BAD-LINK
	JRST	CALER1


; 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

; 1) IMPURIFY ITS OBLIST BUCKET

	SKIPN	B,2(C)		; PICKUP OBLIST IF IT EXISTS
	JRST	IMPUR1		; NOT ON ONE, IGNORE THIS CODE

	ADDI	B,(TVP)		; POINT TO SLOT
	MOVE	B,(B)		; GET THE REAL THING
	ADD	C,[3,,3]	; POINT TO PNAME
	HLRE	A,C		; GET LNTH IN WORDS OF PNAME
	MOVNS	A
	PUSH	P,[IMPUR2]	; FAKE OUT ILOOKC
	PUSH	P,(C)		; PUSH UP THE PNAME
	AOBJN	C,.-1
	PUSH	P,A		; NOW THE COUNT
	JRST	ILOOKC		; GO FIND BUCKET

IMPUR2:	JUMPE	B,IMPUR1	; NOT THERE, GO
	PUSH	TP,$TOBLS		; SAVE BUCKET
	PUSH	TP,E

	MOVE	B,(E)		; GET NEXT ONE
IMPUR4:	MOVEI	0,(B)
	CAIGE	0,HIBOT		; SKIP IF PURE
	JRST	IMPUR3		; FOUND IMPURE NESS, SKIP IT
	HLLZ	C,(B)		; SET UP ICONS CALL
	HRRZ	E,(B)
	MOVE	D,1(B)
	PUSHJ	P,ICONS		; CONS IT UP
	HRRZ	E,(TP)		; RETRV PREV
	HRRM	B,(E)		; AND CLOBBER
IMPUR3:	MOVSI	0,TLIST
	MOVEM	0,-1(TP)	; FIX TYPE
	HRRZM	B,(TP)		; STORE GOODIE
	HRRZ	B,(B)		; CDR IT
	JUMPN	B,IMPUR4	; LOOP
	SUB	TP,[2,,2]	; FLUSH TP CRUFT

; 2) GENERATE A DUPLICATE ATOM

IMPUR1:	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

	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,$TATOM
	PUSH	TP,B
	PUSH	TP,(A)
	PUSH	TP,1(A)		
	SETZM	(B)
	SETZM	1(B)
	MCALL	2,SETG
IMPUR5:	PUSH	TP,$TFIX	;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
	PUSH	TP,-3(TP)

; 4) UPDATE ALL POINTERS TO THIS ATOM

	MOVE	A,[PUSHJ P,ATFIX]	; INS TO PASS TO GCHACK
	PUSHJ	P,GCHACK
	SUB	TP,[4,,4]

RTNATM:	POP	TP,B
	POP	TP,A
	POPJ	P,

; ROUTINE PASSED TO GCHACK

ATFIX:	CAIE	C,TGATOM	; GLOBAL TYPE ATOM
	CAIN	C,TATOM
	CAME	D,(TP)		; SKIP IF WINNER
	POPJ	P,
	MOVE	D,-2(TP)
	SKIPE	B
	MOVEM	D,1(B)
	POPJ	P,


END