.TITLE	INTERN		
; JEFFREY KODOSKY	ARL	NOV75
;
; SUBR
; ENTRY:	1 ARG		<STRING>
; EXIT:		1 ARG		<LITATM>
; ERRORS:	NONE
; CALLS:	ATMOBL
	.GLOBL	INTERN,ZINTERN
INTERN:	MOV	@R5,R0
	BIT	#2,(R0)+
	BNE	INTRN1	;JUMP IF ILLEGAL ARG
	BIT	#2,@R0
	BNE	INTRN3	;JUMP IF STRING ARG
	BIT	#1,@R0
	BNE	ATMOBL	;JUMP IF ALREADY LITATM TO INSTALL IT
INTRN1:	CLR	@R5	;ILLEGAL ARG: RETURN NIL
	JMP	@-(R4)
INTRN3:	MOV	#1,@R0	;MAKE A LITATM WITH NULL PROPERTY LIST
;
;
;
; UTILITY:	INSTALL ATOM ON OBLIST
; ENTRY:	1 ARG		<LITATM>
; EXIT:		1 ARG		<LITATM>
;		R1:= PORTION OF OBLIST BUCKET WHOSE CADR IS ARG
;		C BIT SET IF <LITATM> IS FIRST OBJECT IN BUCKET
;		IN WHICH CASE CAAR OF R1 IS <ARG>
; ERRORS:	NONE
; CALLS:	GETC, FETCH A FREE CELL
;		EQN, COMPARE PNAMES
;		HASH, HASH A PNAME
; NOTE: IF ARG ALREADY EXISTS ON OBLIST THE NEW ATOM
; IS DISCARDED AND A POINTER TO THE EXISTING ONE IS RETURNED.
	.GLOBL	ATMOBL,QHASH,QEQN,QGETC,$OBLST
ATMOBL:	QHASH		;HASH THE PNAME
	MOV	$OBLST,R1	;POINT TO START OF OBLIST
	ADD	(SP)+,R1;POINT TO BUCKET
	MOV	@R1,R0
	BEQ	AOB10	;JUMP IF BUCKET IS EMPTY
	ROOM	3	;CHECK FOR ADEQUATE STACK SPACE
AOB01:	MOV	R0,-(SP);SAVE POINTERS
	MOV	R1,-(SP)
	MOV	@R0,-(R5)	;PUSH NEXT ATOM IN BUCKET
	MOV	2(R5),-(R5)	;PUSH <LITATM>
	QEQN		;CHECK FOR EQUAL PNAMES
	MOV	(SP)+,R1;RESTORE POINTERS
	MOV	(SP)+,R0
	TST	(R5)+
	BNE	AOB20	;JUMP IF EQUAL PNAMES
	MOV	R0,R1	;BUMP DOWN THE BUCKET
	MOV	2(R0),R0
	BNE	AOB01	;LOOP BACK IF MORE OBJECTS
	MOV	R1,-(SP);OTHERWISE SAVE POINTER TO LAST CELL
	QGETC		;OF BUCKET AND FETCH A NEW ONE
	CLC
	MOV	(R5)+,R0;PUT <LITATM> POINTER IN CAR
	MOV	@R5,@R0
	MOV	(SP)+,R1	;POP POINTER TO PREVIOUS LAST
	MOV	R0,2(R1);CELL AND CHAIN NEW ONE TO IT
	JMP	@-(R4)
AOB10:	MOV	R1,-(SP);SAVE POINTER TO BUCKET
	QGETC		;FETCH A NEW CELL
	SEC		;INDICATE FIRST OBJECT IN BUCKET
	MOV	(R5)+,R0
	MOV	@R5,@R0	;PUT <LITATM> POINTER IN CAR
	MOV	(SP)+,R1	;GET POINTER TO BUCKET
	MOV	R0,@R1	;INSERT NEW ATOM IN BUCKET
	JMP	@-(R4)
AOB20:	CMP	@R1,R0	;CAR OF CELL AT R1 = R0 ONLY IF OBJECT
	BEQ	AOB21	;IS FIRST ON OBLIST BUCKET
	CLC
	BR	.+4
AOB21:	SEC		;SET C BIT IF OBJECT IS FIRST
	MOV	@R0,@R5	;RETURN POINTER TO EXISTING ATOM
	JMP	@-(R4)
ZINTERN=.-INTERN
	.END