.TITLE	ARRAY		
; JEFFREY KODOSKY	ARL	AUG76
;
; SUBR
; ENTRY:	2 ARGS		<LITATM>;<LIST>
; EXIT:		1 ARG		NIL
; ERRORS:	I1, ARRAY SPACE EXHAUSTED
;		I5, IMPROPER ARGUMENT TO ARRAY FUNCTION
; CALLS:	GET
;		REMPROP
;		CAR
;		CDR
;		ATM2N
;		RI
;		MLI
;		PUT
	.GLOBL	ARRAY,ZARRAY,QI5ERR,YARRAY,QGET,ASTART,AVAIL
	.GLOBL	FSTART,QREMPROP,QCAR,QCDR,QATM2N,QRI,QMLI
	.GLOBL	QI1ERR,QPUT
ARRAY:	ROOM	4
	MOV	@R5,R0	;ARG1 HAS TO BE A LITATM
	BIT	#2,(R0)+
	BNE	ARRERR
	BIT	#2,@R0
	BNE	ARRERR
	BIT	#1,@R0
	BNE	ARAY01
ARRERR:	QI5ERR
ARAY01:	MOV	YARRAY,-(R5)	;CHECK FOR EXISTING ARRAY PROPERTY
	MOV	2(R5),-(R5)
	QGET
	TST	(R5)+
	BEQ	1$
	JSR	PC,RELEASE	;RELEASE EXISTING ARRAY SPACE
	TST	2(R5)
	BNE	1$
	MOV	YARRAY,2(R5)	;IF ARG2 IS NIL, REMOVE ARRAY PROPERTY
	QREMPROP
	CLR	@R5
	JMP	@-(R4)
1$:	MOV	#1,-(SP)	;SIZE OF ARRAY NEEDED
	MOV	2(R5),-(R5)
	BEQ	41$
2$:	MOV	@R5,R3
	BEQ	ARAY05	;END OF DIMENSION SPEC
	QCDR
	MOV	R3,-(R5)
	QCAR
	MOV	@R5,-(R5)
	QCDR		;GET HIGH LIMIT OF NEXT INDEX
	QATM2N
	BCC	.+4
	QRI
	QCAR
	QATM2N		;GET LOW LIMIT
	BCC	.+4
	QRI
	SUB	(SP)+,@SP
	BPL	5$
4$:	TST	(R5)+	;HI MUST BE > LO
41$:	TST	(R5)+
	BR	ARRERR
5$:	INC	@SP
	QMLI
	BCS	4$	;ERROR IF TOO LARGE
	BR	2$
ARAY05:	MOV	(SP)+,R3
	ASL	R3	;NUMBER OF BYTES REQUIRED
	TST	(R5)+	;POP NIL
	JSR	PC,ENDFREE
	BCC	4$
1$:	QI1ERR		;NO ROOM
4$:	MOV	R1,R2	;DOES LAST BLOCK ABUT ASTART?
	ADD	@R1,R2
	CMP	R2,ASTART
	BNE	1$	;NO: NO ROOM
	CMP	(R3)+,(R3)+	;ADD 2 WORDS TO SPACE REQ'D
	CMP	R3,@R1
	BGT	1$	;NOT ENOUGH ROOM
	MOV	@R1,R2
	SUB	R3,R2
	CMP	R2,#16.
	BLE	7$	;RESERVE THE WHOLE BLOCK IF THERES JUST
			;A LITTLE CHUNK LEFT OVER
	SUB	R3,@R1	;OTHERWISE JUST REDUCE  THE SIZE
	ADD	@R1,R1	;OF THE LAST AVAIL BLOCK
	MOV	R3,@R1
	BR	9$
7$:	CMP	@R0,R1	;ONLY ONE BLOCK LEFT?
	BEQ	.+4	;IF SO R0 POINTS TO AVAIL ADDR
	TST	(R0)+	;OTHERWISE POINT IT TO LINK
	CLR	@R0
9$:	MOV	R1,ASTART
	MOV	@R5,2(R1)
	MOV	@R5,-(R5)
	MOV	YARRAY,2(R5)
	QPUT
	JMP	CLARRAY	;GO CLEAR THE ARRAY
;
;
;
RELEASE:JSR	PC,FIND	;RELEASE THE SPACE NOW HELD
	BCS	5$	;JUMP IF SPACE NOT FOUND!
	MOV	R0,R1	;R0=POINTER TO SIZE
	MOV	@R0,R3	;SAVE SIZE
	ADD	R3,R1	;SLIDE UP OTHER ARRAYS
1$:	CMP	R0,ASTART
	BLOS	2$	;JUMP WHEN DONE
	MOV	-(R0),-(R1)
	BR	1$
2$:	JSR	PC,ENDFREE	;FIND END OF AVAIL LIST
	BCS	3$	;JUMP IF NULL AVAIL LIST
	MOV	R1,R2	;RO POINTS TO NEXT TO LAST BLOCK
	ADD	@R1,R2	;R1 POINTS TO LAST BLOCK
	CMP	R2,ASTART	;DOES LAST BLOCK ABUT ARRAY SPACE?
	BNE	4$	;JUMP IF NOT
	ADD	R3,@R1	;IF SO, JUST INCREASE THE SIZE
	BR	45$
3$:	TST	-(R1)	;POINT TO ADDRESS BEFORE AVAIL HEADER
4$:	MOV	ASTART,R2	;MAKE ANOTHER BLOCK
	MOV	R2,2(R1)
	MOV	R3,(R2)+	;SIZE OF NEW BLOCK
	CLR	@R2	;NULL LINK
45$:	ADD	R3,ASTART
5$:	RTS	PC
;
;
;
FIND:	MOV	ASTART,R0	;FIND ARRAY BELONGING TO ATOM @R5
1$:	CMP	R0,FSTART
	BHIS	3$	;JUMP IF NOT FOUND
	CMP	2(R0),@R5
	BEQ	2$	;JUMP IF FOUND
	ADD	@R0,R0
	BR	1$	;CONTINUE SEARCH
2$:	CLC		;R0 POINTS TO ARRAY
	RTS	PC
3$:	SEC
	RTS	PC
;
;
;
ENDFREE:MOV	#AVAIL,R1	;LOCATE END OF FREE LIST
	MOV	R1,R0
	TST	@R1
	BNE	1$
	SEC		;IF NULL AVAIL, RETURN C BIT AND R0,R1
	RTS	PC	;POINT TO ADDRESS OF AVAIL HEADER WORD
1$:	TST	-(R1)	;ELSE ALWAYS RETURN R0,R1 SUCH THAT
2$:	MOV	R1,R0	;2(R0)=R1
	MOV	2(R1),R1
	TST	2(R1)
	BNE	2$
	RTS	PC	;R1 POINTS TO LAST BLOCK, R0 TO PREVIOUS
	.PAGE
; UTILITY:	RETURN ADDRESS OF ARRAY ELEMENT
; ENTRY:	2 ARGS		(<LITATM><N1><N2>...);<SUBSCRIPT PROPERTY>
; EXIT:		NO ARGS
;		R0 HAS ADDR OF ARRAY ELEMENT
; ERRORS:	I5, IMPROPER ARGUMENT TO ARRAY FUNCTION
; CALLS:	CAR
;		CDR
;		ATM2N
;		RI
;		MLI
	.GLOBL	INDEX
INDEX:	ROOM	3
	MOV	@R5,-(R5)
	QCDR
	CLR	-(SP)	;INDEX
	CLR	-(SP)	;INDEX MULTIPLIER
INDX02:	MOV	@R5,R3	;GET NEXT SUBSCRIPT
	BEQ	INDX04	;JUMP IF NO MORE SUBSCRIPTS
	QCDR
	MOV	R3,-(R5)
	QCAR
	QATM2N
	BCC	.+4
	QRI
	MOV	4(R5),R3	;GET NEXT SUBSCRIPT RANGE
	BEQ	IDXERR	;JUMP IF NO MORE RANGES
	MOV	R3,-(R5)
	QCDR
	MOV	(R5)+,4(R5)
	MOV	R3,-(R5)
	QCAR
	MOV	@R5,-(R5)
	QCDR		;GET HI LIMIT
	QATM2N
	BCC	.+4
	QRI
	QCAR		;GET LO LIMIT
	QATM2N
	BCC	.+4
	QRI
	MOV	(SP)+,R0;LO
	MOV	(SP)+,R1;HI
	MOV	(SP)+,R2;SUBSCRIPT
	CMP	R2,R0
	BLT	IDXERR	;INDEX OUT OF RANGE
	CMP	R2,R1
	BGT	IDXERR
	SUB	R0,R2
	MOV	R2,(PC)+
IDXADD:	.WORD	0	;ADDITIVE PORTION
	SUB	R0,R1
	INC	R1
	MOV	R1,(PC)+
IDXMUL:	.WORD	0	;MULTIPLICATIVE PORTION
	QMLI		;MULTIPLY LAST MULT & INDEX
	ADD	IDXADD,@SP	;ADD IN SUBSCRIPT OFFSET
	MOV	IDXMUL,-(SP)	;NEW MULTIPLIER
	BR	INDX02
INDX04:	TST	4(R5)
	BEQ	INDX06
IDXERR:	TST	(R5)+	;TOO FEW SUBSCRIPTS, TOO MANY, ILLEGAL
	QI5ERR		;SUBSCRIPTS, OR ARRAY WAS LOST!
INDX06:	CMP	(SP)+,(R5)+	;POP INDEX MULTIPLIER AND NIL
	MOV	@R5,-(R5)	;GET LITATM
	QCAR
	JSR	PC,FIND
	BCS	IDXERR	;JUMP IF ARRAY WAS LOST!
	CMP	(R0)+,(R0)+	;POINT TO START OF ARRAY DATA
	ASL	@SP	;BYTE OFFSET INTO ARRAY
	ADD	(SP)+,R0
	ADD	#6,R5	;POP STUFF
	JMP	@-(R4)
ZARRAY=.-ARRAY
	.PAGE
; SUBR:		CLARRAY
; ENTRY:	1 ARG		<LITATM>
; EXIT:		1 ARG		NIL
; ERRORS:	I5, IMPROPER ARG TO ARRAY FUNCTION
; CALLS:	NONE
	.GLOBL	CLARRAY,ZCLARRAY
CLARRAY:JSR	PC,FIND
	BCS	CLERR
	MOV	R0,R1
	ADD	(R0)+,R1
	TST	(R0)+
1$:	CMP	R0,R1
	BHIS	2$
	CLR	(R0)+
	BR	1$
2$:	CLR	@R5
	JMP	@-(R4)
CLERR:	QI5ERR
ZCLARRAY=.-CLARRAY
	.END