sb.mac

TITLE	SB,<GENERAL SUBROUTINES>,08,06-SEP-80,TG/GPK

;	ENTRY POINTS TO ROUTINES IN THIS MODULE:

;+
; GETDSK	-
; RETDSK	-
; ERROR		- PRINT ERRORS
; CONVRT	- CONVERT NUMBERS FROM BASE X
; INDEX		-
; GETARY	-
; GETIT		-
; SAVSYS	-
; ALLOC1	-
; ALLOC2	-
; ALLOCS	-
;-

;	ROUTINES CALLED FROM THIS MODULE:

;+
; COM05		- CM -
; GETSPC	- ME -
; SYSTEM	- IO -
;+

	ORG	SB
.SBTTL	GETDSK - GET OVERLAY DISK ASSIGNMENT
;+
;	G E T D S K
;
; THIS ROUTINE ASSIGNS AN OVERLAY DISK ADDRESS FOR AN
; ARRAY ROW WHOSE SIZE IN WORDS IS PASSED IN R1.  THIS
; ASSIGNMENT IS UNIQUE FOR THAT ROW. THE BLOCK NUMBER
; OF THE OVERLAY ASSIGNMENT IS RETURNED IN R0.  THE
; NUMBER OF BLOCKS ALLOCATED IS RETURNED IN R1.
;
; CALLING SEQUENCE:
;
;	JSR	PC,GETDSK
;-

GETDSK::MOV	R1,-(SP)		;SAVE A REGISTER
	MOV	R2,-(SP)		;  AND ANOTHER
	MOV	R3,-(SP)		;    AND ANOTHER
	CLR	-(SP)			;MAKE A TEMPORARY ANSWER
	ADD	#BLKSIZ-1,R1		;ROUND UP FOR PARTIAL BLOCKS
	CLR	R0			;ZERO HIGH ORDER WORD
	DIV	#BLKSIZ,R0		;AND FIND NUMBER OF BLOCKS NEEDED
	CLR	R1			;INITIALIZE NUMBER OF BLOCKS FOUND
	MOV	#OVRMAP,R2		;GET POINTER TO ALLOCATION MAP
	CLR	R3			;AND NO DATA THE FIRST TIME AROUND
10$:	INC	R1			;LOOKING AT ONE MORE BLOCK
	ROL	R3			;MOVE TO NEXT BLOCK'S BIT
	BNE	20$			;UNLESS WE NEED THE NEXT WORD
	SEC				;MARK END OF WORD
	MOV	(R2)+,R3		;GET NEXT MAP WORD
	ROL	R3			;AND STRIP A BIT
20$:	BCC	10$			;IF AVAILABLE, WE CAN LOOP
	CMP	R1,R0			;DID WE FIND ENOUGH?
	BGT	30$			;SUCCESS!
	CMP	R2,#OVRMAP+24		;DID THIS LEAVE US AT THE END?
	BHI	40$			;YUP, THAT'S ALL FOLKS
	ADD	R1,(SP)			;MOVE UP START BLOCK NUMBER
	CLR	R1			;RESET BLOCK COUNT
	BR	10$			;GO LOOK SOME MORE
30$:	MOV	(SP)+,R0		;GET THE ANSWER FROM THE STACK
	MOV	(SP)+,R3		;UNSAVE A REGISTER
	MOV	(SP)+,R2		;  AND ANOTHER
	MOV	(SP)+,R1		;    AND ANOTHER
	BR	RETDSK			;GO UPDATE THE MAP

40$:	QUIT	<?Overlay overflow>
.SBTTL	RETDSK - RETURN OVERLAY DISK ASSIGNMENT
;+
;	R E T D S K
;
; THIS ROUTINE MARKS THE OVERLAY FILE ALLOCATION MAP
; FOR THE DISK BLOCKS WHICH ARE ALLOCATED BY GETDSK
; OR ARE REQUESTED TO BE DE-ALLOCATED BY A CALL TO
; RETDSK.  IT IS ASSUMED THAT THE MAP ACCURATELY
; REFLECTS THE STATUS OF THE BLOCKS IN QUESTION
; AS THE BIT ARE CHANGED WITH AN XOR INSTRUCTION.
; THE STARTING BLOCK NUMBER MUST BE IN R0 AND THE
; LENGTH OF THE OVERLAY AREA IN WORDS IN R1.
;
; CALLING SEQUENCE:
;
;	JSR	PC,RETDSK
;-

RETDSK::MOV	R0,-(SP)		;SAVE A REGISTER
	MOV	R1,-(SP)		; AND ANOTHER
	MOV	R2,-(SP)		;  AND ANOTHER
	MOV	R0,R2			;COPY RECORD NUMBER
	CLR	R0			;ZERO HIGH ORDER
	ADD	#BLKSIZ-1,R1		;ROUND UP FOR ODD SIZES
	DIV	#BLKSIZ,R0		;FIND THE NUMBER OF RECORDS
	MOV	R2,R1			;GET RECORD NUMBER BACK
	ASH	#-4,R1			;LEAVE ONLY A WORD INDEX
	ASL	R1			; ...NOW IT IS ONE
	ADD	#OVRMAP,R1		;POINT TO MAP
	MOV	#17,-(SP)		;GET A USEFUL NUMBER ON THE STACK
	BIC	#^C<17>,R2		;REMOVE UNWANTED BITS
	SUB	R2,(SP)			;REVERSE INDEX
	MOV	#1,R2			;GET A STARTING BIT
	ASH	(SP)+,R2		;MOVE IT WHERE IT WANTS TO BE
10$:	XOR	R2,(R1)			;CHANGE ONE BIT
	CLC				;NO CARRIES IN PLEASE
	ROR	R2			;MOVE TO NEXT BIT
	BCC	20$			;UNLESS IT'S THE NEXT WORD
	ROR	R2			;NEED AND EXTRA ROTATE
	TST	(R1)+			;MOVE UP TO NEXT MAP WORD
20$:	SOB	R0,10$			;DO NEXT BIT
	MOV	(SP)+,R2		;RESTORE A REGISTER
	MOV	(SP)+,R1		; AND ANOTHER
	MOV	(SP)+,R0		;  AND ANOTHER
	RTS	PC			;AND EXIT
.SBTTL	ERROR -  GENERAL ERROR MESSAGE PRINTER
;+
;	E R R O R
;
; THIS ROUTINE PRINTS AN ERROR MESSAGE WHICH IS POINTED TO BY
; R2.  THEN IF WE ARE SOMEWHERE IN THE INTERPRETER (I.E. THERE
; IS A VALID STACK HISTORY), WE ALSO PRINT A STACK HISTORY.
;-

ERROR::	MOV	R5,-(SP)		;SAVE INTERPRETER'S PC
	SUB	PBASE,(SP)		; AND MAKE IT RELATIVE
	MOV	@PBASE,-(SP)		;NOW SAVE PROGRAM DESCRIPTOR
	MOV	R4,-(SP)		;AND FAKE A RETURN CONTROL WORD
	MOV	SP,R4			; ... AND THAT DOES IT
	MOV	#IOBUFF,R5		;NOW GET SOMEPLACE TO PUT IT
10$:	MOVB	(R2)+,(R5)+		;AND MOVE A BYTE OF MESSAGE
	BNE	10$			; UNTIL ALL DONE
	DEC	R5			;IGNORE THE NULL BYTE
	BR	50$			;AND PRINT IT OUT

20$:	MOV	#4,R2			;START OUT WITH 4 SPACES
30$:	MOVB	#' ,(R5)+		;MOVE ONE
	SOB	R2,30$			; UNTIL WE HAVE DONE THEM ALL
	MOVB	#'[,(R5)+		;PUT OUT A BRACKET
	MOV	(R4),R2			;GET TO NEXT RCW SO THAT
	MOV	-10(R2),R1		; WE CAN GET THE LEVEL
	DEC	-10(R2)			;SEE IF LEVEL 1 YET
	BNE	40$			;NOT YET
	CLR	ALGOL			;THAT'S THE SIGNAL
40$:	MOV	#10.,R2			;CONVERT IN DECIMAL
	MOV	#2,-(SP)		;FOR A LENGTH OF TWO
	CALL	CONVRT			; AND DO IT
	MOVB	#'],(R5)+		;NOW A CLOSING BRACKET
	MOV	2(R4),R2		;GET POINTER TO PROGRAM DESCRIPTOR
	MOV	6(R2),R1		; AND GET THE SEGMENT NUMBER
	MOV	#8.,R2			;CONVERT THIS IN OCTAL
	MOV	#3,-(SP)		;FOR A LENGTH OF THREE
	CALL	CONVRT			; DO IT
	MOVB	#':,(R5)+		;PUT OUT A COLON
	MOV	4(R4),R1		;GET RELATIVE IPC
	ASR	R1			; DIVIDED BY TWO
	DEC	R1			;  MINUS ONE
	MOV	#4,-(SP)		;AND MAKE A LENGTH OF FOUR
	CALL	CONVRT			; AND CONVERT IT
	TST	ALGOL			;WAS THAT THE LAST ONE???
	BEQ	50$			;YEAH, PRINT IT OUT
	MOV	(R4),R4			;LINK TO NEXT RCW
	SOB	R3,20$			;LOOP AROUND
50$:	MOV	#XRB,R0			;GET A GOOD POINTER
	MOVB	#CR,(R5)+		;PUT A CARRIAGE RETURN OUT
	MOVB	#LF,(R5)+		; AND A LINE FEED
	SUB	#IOBUFF,R5		;AND MAKE A POINTER INTO A COUNT
	MOV	R5,(R0)+		;AND FILL UP THE XRB
	MOV	R5,(R0)+		; ...TWICE
	MOV	#IOBUFF,R5		;AND RESET THE BUFFER POINTER
	MOV	R5,(R0)+		;AND SET IT IN THE XRB
	CLR	(R0)+			;DO IT TO CHANNEL ZERO
	.WRITE				; ...AND DO IT
	MOV	#4,R3			;RESET THE LOOP COUNTER
	TST	ALGOL			;ARE WE FINISHED
	BNE	20$			;NO, LOOP AROUND
	JMPX	COM05			; AND GET OUT FAST

CONVRT::MOV	R3,-(SP)		;SAVE THIS REGISTER
	MOV	4(SP),R3		;GET LENGTH OF CONVERT
	ADD	R5,4(SP)		;THAT IS THE UPDATED POINTER
	ADD	R3,R5			;AND START FILLING THERE
10$:	CLR	R0			;ZERO HIGH ORDER WORD
	DIV	R2,R0			;DIVIDE BY BASE
	ADD	#'0,R1			;MAKE INTO ASCII
	MOVB	R1,-(R5)		;STICK IT IN THE BUFFER
	MOV	R0,R1			;GET READY FOR NEXT TIME
	SOB	R3,10$			;AND LOOP
	MOV	(SP)+,R3		;RESTORE REGISTER 3
	MOV	(SP)+,R5		;SET UP FOR TRICKY EXIT
	RTS	R5			;THAT DOES IT
.SBTTL	INDEX -  CHECK AND PERFORM ARRAY INDEXING
;+
;	I N D E X
;
; THIS ROUTINE CHECKS AND PERFORMS INDEXING OF ARRAYS.  THE
; MEMORY ADDRESS OF THE ARRAY ROW TO BE INDEXED IS PASSED IN
; R0.  THE INDEX IS PASSED ON THE STACK.  IF THE INDEX IS IN
; RANGE THEN THE ADDRESS OF THE INDEXED DATA ELEMENT IS
; RETURNED IN R0.  IF NOT, A FATAL ERROR IS GENERATED.
;
; CALLING SEQUENCE:
;
;	JSR	PC,INDEX
;-

INDEX::	MOV	R0,MEMADD		;SAVE ADDRESS IN CASE OF WRITE
	MOV	(SP)+,R1		;REARRANGE THE STACK
	MOV	(SP),-(SP)		;TO INTERCHANGE THE INDEX
	MOV	R1,2(SP)		;AND THE RETURN ADDRESS
	MOV	(R0)+,R1		;GET ADDRESS OF ARRAY DESCRIPTOR
	SUB	A$LBND(R1),(SP)		;ADJUST INDEX FOR LOWER BOUND
	BMI	I.ERR			;NEGATIVE INDEX LOSES
	MOV	(R1),R1			;GET ARRAY INFO WORD
	BIC	#160000,R1		; LEAVING JUST THE SIZE
	CMP	R1,(SP)			;IS THE INDEX TOO LARGE???
	BLOS	I.ERR			;AFRAID SO!
	MOV	(SP)+,R1		;NOW GET THE INDEX (ADJUSTED)
	MOV	M$TYPE-M$DATA(R0),-(SP) ;GET THE MEMORY TYPE WORD
	ROR	(SP)			;IS THIS A REAL ARRAY
	BCC	10$			;NO, NO ADJUSTING
	ASL	R1			;YES, DOUBLE INDEX
10$:	ROR	(SP)+			;HOW ABOUT A DOPE VECTOR
	BCC	20$			;NO, ALMOST DONE
	ASL	R1			;YES, DOUBLE AGAIN
20$:	ASL	R1			;DOUBLE FOR BYTE INDEX
	ADD	R1,R0			;NOW INDEX IT
	RTS	PC			;AND EXIT

I.ERR:	QUIT	<?Invalid index>
.SBTTL	GETARY - GET ARRAY IN CORE
;+
;	G E T A R Y
;
; THIS ROUTINE BRINGS THE DESIRED ROW OF AN ARRAY INTO CORE.
; UPON ENTRY THE STACK CONTAINS THE PARAMETERS AS FOLLOWS:
;
;	(SP) -	ADDRESS OF ARRAY DESCRIPTOR
;	2(SP) -	INDEX OF A ONE DIMENSIONAL ARRAY, OR
;		SECOND INDEX OF A TWO DIMENSIONAL ARRAY
;	4(SP) -	FIRST INDEX OF A TWO DIMENSIONAL ARRAY
;
; THE ARRAY DESCRIPTOR AND THE FIRST INDEX OF A TWO DIMENSIONAL
; ARRAY ARE REMOVED FROM THE STACK.  THE ADDRESS OF THE PROPER
; ROW (-2) IS RETURNED IN R0.
;
; CALLING SEQUENCE:
;
;	JSR	PC,GETARY
;-

GETARY::MOV	2(SP),R0		;RETRIEVE DESCRIPTOR
	MOV	(SP)+,(SP)		;RE-STACK RETURN ADDRESS
	MOV	R1,-(SP)		;SAVE ONE REGISTER
10$:	TST	A$DISK(R0)		;SEE IF ARRAY IS ALLOCATED YET
	BGT	20$			;DISK ADDRESS>0 IF SO
	CALL	ALLOC1			; ALLOCATE A 1-DIM ARRAY
20$:	BIT	#60000,(R0)		;ARRAY RESTART; SEE IF 1-DIM.
	BEQ	60$			;IF ONE DIM THEN ALL SET
	MOV	R0,R1			;GET A COPY OF ADDRESS OF DESCRIPTOR
	MOV	A$PNTR(R0),R0		;GET ADDRESS OF DOPE VECTOR (NEW DESCRIPTOR)
	BIT	#A.SEG,(R1)		;SEE IF A SEGMENTED ARRAY
	BEQ	50$			;ALREADY SET UP FOR 2 DIM
	SUB	A$LBND(R1),4(SP) 	;INDEXING FOR SEGMENTED ARRAYS CHECKED HERE
	BMI	I.ERR			;GET ABS INDEX INTO ARRAY.
	MOV	4(SP),R1		;HAVE TO FAKE A SECOND DIM
	BIC	#177600,4(SP)		;CLEAR UPPER BITS FOR 2ND DIM
	BIC	#160000,R1		;TURN OFF UNWANTED BITS
	BIT	#M.RDPE,M$TYPE-M$PNTR(R0) ;IF REAL
	BEQ	30$			;THEN MOD 64 NOT 128
	BIC	#100,4(SP)
	ASL	R1			;WHICH IS (DIV 128) * 2
30$:	ASL	R1			;WANT R1 DIV 128 SO MUL TIMES 2
	CLRB	R1			;AND
	SWAB	R1			;DIVIDE BY 256
40$:	MOV	R1,-(SP)		;SAVE 2ND DIM
	CALL	INDEX			; CHECK INDEXING (R0 SET UP FROM BEFORE)
	BR	10$			;THIS WAS SET UP TO FOR COMPATIBILITY
50$:	MOV	6(SP),R1		;HAVE TO SWITCH 1ST & 2ND INDICIES
	MOV	4(SP),6(SP)		;RE-STACK SECOND INDEX
	MOV	2(SP),4(SP)		;RE-STACK RETURN ADDRESS
	MOV	(SP)+,(SP)		;RE-STACK SAVED R1
	BR	40$
60$:	CALL	GETIT			; AND WE WANT IT IN CORE
	+	TYPEAY			;THIS MEMORY WILL BE DATA
	+	VMEMFD			;AND WE MIGHT HAVE TO READ IT IN
	MOV	(SP)+,R1		;RESTORE ONE REGISTER
	RTS	PC			;AND A CONVENTIONAL RETURN
.SBTTL	GETIT -  GET ARRAY ROW OR CODE SEGMENT IN CORE
;+
;	G E T I T
;
; THIS ROUTINE ENSURES THAT A PARTICULAR ARRAY ROW OR CODE
; SEGMENT IS PRESENT IN CORE.  IF THE SEGMENT IS NOT PRESENT
; THEN MEMORY SPACE IS FOUND FOR IT AND THE NECESSARY DATA
; IS READ FROM THE SPECIFIED FILE.  R0 ON ENTRY CONTAINS THE
; ADDRESS OF THE REQUISITE DESCRIPTOR (ARRAY OR PROGRAM).
;
; CALLING SEQUENCE:
;
;	JSR	PC,GETIT
;	+	MEMORY TYPE (TYPEAY OR TYPEPR)
;	+	FILE DESCRIPTOR (VMEMFD OR PROGFD);
;-

GETIT::	CALL	SAVSYS			;SAVE 'SYSTEM' XFER INFO
	MOV	R1,-(SP)		;SAVE A REGISTER
	MOV	R2,-(SP)		; AND ANOTHER
	ADD	#4,20(SP)		;ADJUST RETURN ADDRESS
	MOV	R0,R2			;GET A COPY OF THE DESCRIPTOR
	MOV	(R0),R0			;GET INFO WORD FROM DESCRIPTOR
	BMI	20$			;IT'S PRESENT, WHAT DO YOU KNOW?
	MOV	20(SP),R1		;GET ADDRESS OF PARAMETERS
	MOV	-(R1),SYS.FD		;GET FILE DESCRIPTOR
	MOV	-(R1),R1		;GET MEMORY TYPE
	BIC	#160000,R0		;LEAVE JUST THE SIZE
	MOV	A$DISK(R2),SYS.RN 	;GET IT'S DISK ADDRESS
	BIT	#A.REAL,SYS.RN		;IS IT A REAL ARRAY?
	BEQ	10$			;NO, THAT'S GOOD
	BIC	#A.REAL,SYS.RN		;THATS NOT PART OF THE ADDRESS
	BIS	#1,R1			;TURN ON 'REAL' BIT IN TYPE WORD
	ASL	R0			;AND ADJUST THE SIZE
10$:	ASL	R0			;CONVERT TO BYTE COUNT
	MOV	R0,SYS.CT		;SAVE XFER COUNT
	BIS	#PRESNT,(R2)		;MARK THE DATA AS PRESENT
	CALLX	GETSPC			; MAKE ROOM FOR US
	MOV	#IO.RD,@#SYS.IO		; WE WANT A READ PLEASE
	MOV	R0,A$PNTR(R2)		;LINK US IN THE LINKS
	MOV	R2,(R0)+		; BOTH WAYS
	MOV	R0,SYS.CA		;LOAD THE DATA THERE
	CALLX	SYSTEM			; DO THE DISK I/O
20$:	MOV	A$PNTR(R2),R0		;GET DATA ADDRESS - 2
	MOV	(SP)+,R2		;RESTORE A REGISTER
	MOV	(SP)+,R1		;AND ANOTHER
	RTS	PC			;AND OUT
.SBTTL	SAVSYS - SAVE SYSTEM I/O BLOCK COROUTINE
;+
;	S A V S Y S
;
; THIS COROUTINE SAVES THE FIVE DATA ITEMS IN THE SYSTEM
; TRANSFER BLOCK (SYS.IO THROUGH SYS.RN).  IT THEN DOES
; A COROUTINE CALL BACK TO THE CALLING ROUTINE.  ON EXIT
; FROM THE CALLING ROUTINE, CONTROL RETURNS HERE TO
; RESTORE THE TRANSFER BLOCK.
;
; CALLING SEQUENCE:
;
;	JSR	PC,SAVSYS
;-

SAVSYS::MOV	SYS.FD,-(SP)		;SAVE ONE
	MOV	SYS.CA,-(SP)		; AND ANOTHER
	MOV	SYS.CT,-(SP)		;  AND ANOTHER
	MOV	SYS.RN,-(SP)		;   AND ANOTHER
	MOV	10(SP),-(SP)		;RE-STACK RETURN ADDRESS
	MOV	SYS.IO,12(SP)		;STICK IN THE LAST ONE
	JSR	PC,@(SP)+		;COROUTINE CALL BACK
	MOV	(SP)+,SYS.RN		;RESTORE ONE
	MOV	(SP)+,SYS.CT		; AND ANOTHER
	MOV	(SP)+,SYS.CA		;  AND ANOTHER
	MOV	(SP)+,SYS.FD		;   AND ANOTHER
	MOV	(SP)+,SYS.IO		;    AND ANOTHER
	RTS	PC			;AND REALLY EXIT


.SBTTL	SAVE4 -  SAVE 4 REGISTERS COROUTINE
;+
;	S A V E 4
;
; THIS COROUTINE SAVES FOUR REGISTERS (R0-R3) ON THE STACK
; AND THEN DOES A COROUTINE CALL BACK TO THE CALLING
; ROUTINE.  UPON RETURN FROM THE CALLING ROUTINE, THE
; REGISTERS ARE RESTORED AND THE ROUTINE IS EXITED.
;
; CALLING SEQUENCE:
;
;	JSR	R3,SAVE4
;-

SAVE4:	MOV	R2,-(SP)		;R3 IS ON THE STACK FROM THE CALL
	MOV	R1,-(SP)		;SAVE ANOTHER REGISTER
	MOV	R0,-(SP)		;GOT THEM ALL NOW
	MOV	R3,-(SP)		;PUT RETURN ADDRESS ON THE STACK
	MOV	10(SP),R3		;RESTORE REGISTER THREE
	JSR	PC,@(SP)+		;COROUTINE CALL BACK
	MOV	(SP)+,R0		;RESTORE A REGISTER
	MOV	(SP)+,R1		; AND ANOTHER
	MOV	(SP)+,R2		;  AND ANOTHER
	MOV	(SP)+,R3		;   AND ANOTHER
	RTS	PC			;    AND EXIT
.SBTTL	ALLOC1 - ALLOCATE A 1-DIMENSIONAL ARRAY ROW
;+
;	A L L O C 1
;
; THIS ROUTINE ALLOCATES A ONE DIMENSIONAL NON-
; SEGMENTED ARRAY ROW.  THE ARRAY DESCRIPTOR IS
; MARKED PRESENT AND THE ROW IS ZEROED.  THE
; ADDRESS OF THE ARRAY DESCRIPTOR IS PASSED IN
; R0.  ALL REGISTERS ARE PRESERVED.
;
; CALLING SEQUENCE:
;
;	JSR	PC,ALLOC1
;-

ALLOC1::BIT	#A.SEG,(R0)		;REALLY A SEGMENTED ARRAY?
	BNE	ALLOCS			;CALL THE PROPER ROUTINE
	CALL	SAVE4,R3		; SAVE SOME REGISTERS
	BIS	#PRESNT,(R0)		;MARK US PRESENT
	MOV	R0,R2			;COPY THE DESCRIPTOR ADDRESS
	MOV	(R0),R0			;GET THE SIZE AND INFO WORD
	BIC	#160000,R0		; BUT LEAVE JUST THE SIZE
	MOV	#TYPE1N,R1		;MAKE MEMORY NON-SEGMENTED ARRAY
	TST	A$DISK(R2)		;BUT IS THIS A 'REAL' ARRAY?
	BEQ	10$			;NOPE, ALL SET
	INC	R1			;MAKE MEMORY TYPE REAL
	ASL	R0			; AND DOUBLE THE SIZE
10$:	MOV	R0,R3			;SAVE THE SIZE FOR LATER
	ASL	R0			;CONVERT TO BYTES
	CALLX	GETSPC			; MAKE US SOME ROOM
	MOV	R0,A$PNTR(R2)		;LINK US TO THE DESCRIPTOR
	MOV	R2,(R0)+		; AND TO THE MEMORY SEGMENT
	MOV	R3,R1			;SAVE THE SIZE AGAIN
	BEQ	30$			;NO ZEROING IF ZERO
20$:	CLR	(R0)+			;ZERO A WORD
	SOB	R3,20$			; UNTIL WE GET THEM ALL
30$:	CALL	GETDSK			; GET AN OVERLAY SLOT
	MOV	R0,A$DISK(R2)		;AND STICK IT IN
	RTS	PC			;NOW RESTORE THE REGISTERS
.SBTTL	ALLOC2 - ALLOCATE A 2-DIMENSIONAL DOPE VECTOR
;+
;	A L L O C 2
;
; THIS ROUTINE ALLOCATES THE DOPE VECTOR FOR A TWO
; DIMENSIONAL ARRAY.  THIS ENTAILS GETTING ENOUGH
; MEMORY TO HOLD AS MANY ARRAY DESCRIPTORS AS ARE
; NEEDED FOR THE FIRST DIMENSION.  THE DOPE VECTOR
; IS STORED IN SAVE MEMORY.  ALL THE ROWS THAT THE
; DOPE VECTOR POINTS TO ARE LEFT UNALLOCATED.  THE
; ADDRESS OF THE ARRAY DESCRIPTOR IS PASSED IN R0.
; ALL REGISTERS ARE PRESERVED.
;
; CALLING SEQUENCE:
;
;	JSR	PC,ALLOC2
;-

ALLOC2::CALL	SAVE4,R3		; SAVE THE REGISTERS
	BIC	#14000,(R0)		;SIZE CAN'T EXCEED 3777 (2047)
	BIS	#PRESNT,(R0)		;BUT WE WILL BE PRESENT
	MOV	R0,R2			;COPY DESCRIPTOR ADDRESS
	MOV	(R0),R0			;AND GET THE SIZE
	BIC	#160000,R0		; JUST THE SIZE!
	MOV	R0,R3			;COPY THE SIZE
	ASL	R0			;MULTIPLY BY EIGHT SINCE
	ASL	R0			;DOPE VECTORS ARE LONGER
	ASL	R0
	MOV	#TYPEDV,R1		;MAKE MEMORY TYPE DOPE VECTOR
	TST	A$DISK(R2)		;BUT IS IT REAL?
	BEQ	10$			;NOPE, NOT THIS TIME
	BIS	#M.RDPE,R1		;YES, SET THE BIT
10$:	CALLX	GETSPC			; MAKE US ROOM
	MOV	R0,-(SP)		;SAVE POINTER FOR LATER
	MOV	R2,(R0)+		; AND TO THE MEMORY
	MOV	R3,R1			;SAVE THE SIZE AGAIN
	BEQ	30$			;NOTHING TO DO IF SMALL
	MOV	PRT,R3			;GET US A DATA POINTER
20$:	MOV	A$PNTR(R2),(R0)+ 	;PUT IN ROW SIZE
	CLR	(R0)+			;CLEAR THE CORE ADDRESS
	MOV	A$DISK(R2),(R0)+ 	;STICK IN THE REAL TOG
	MOV	24(R3),(R0)+		;AND THE LOWER BOUND
	SOB	R1,20$			;AND LOOP TIL DONE
30$:	MOV	(SP)+,A$PNTR(R2) 	;NOW LINK UP THE MEMORY
	MOV	#1,A$DISK(R2)		;AND SAY WE ARE ALLOCATED.
	RTS	PC			;AND EXIT
.SBTTL	ALLOCS - ALLOCATE A SEGMENTED ARRAY DOPE VECTOR
;+
;	A L L O C S
;
; THIS ROUTINE ALLOCATES THE DOPE VECTOR FOR A ONE
; DIMENSIONAL SEGMENTED ARRAY.  THE DOPE VECTOR CONTAINS
; ARRAY DESCRIPTORS FOR ROWS BLKSIZ WORDS LONG.  THESE
; WILL CONTAIN BLKSIZ INTEGERS OR BLKSIZ/2 REALS.  THE
; LAST ARRAY DESCRIPTOR IN THE DOPE VECTOR MAY BE SMALLER
; THAN THE OTHERS.  THE ADDRESS OF THE ARRAY DESCRIPTOR
; IS PASSED IN RO.  ALL REGISTERS ARE PRESERVED.
;
; CALLING SEQUENCE:
;
;	JSR	PC,ALLOCS
;-

ALLOCS::CALL	SAVE4,R3		; SAVE THE REGS PLEASE
	BIS	#PRESNT,(R0)		;MAKE IT PRESENT
	MOV	R0,R2			;COPY THE DESCRIPTOR ADDRESS
	MOV	A$PNTR(R0),R1		;GET THE ARRAY SIZE
	CLR	R0			;ZERO THE HIGH ORDER PART
	MOV	#BLKSIZ,R3		;GET THE SEGMENT SIZE
	TST	A$DISK(R2)		;IS IT A REAL ARRAY
	BEQ	10$			;NOPE
	ASR	R3			;YES, SEGMENTS ARE HALF THAT SIZE
10$:	DIV	R3,R0			;FIND OUT HOW MANY ROWS
	MOV	R1,-(SP)		;SAVE THE REMAINDER
	BEQ	20$			;NO ADJUSTMENT IF ZERO
	INC	R0			;THIS MAKES THE LAST SEGMENT
20$:	BIS	R0,(R2)			;SAVE THE DOPE VECTOR LENGTH
	MOV	R0,-(SP)		;SAVE THE NUMBER OF SEGMENTS
	ASL	R0			;MAKE EIGHT TIMES BECAUSE
	ASL	R0			;IT'S A DOPE VECTOR
	ASL	R0
	MOV	#TYPEDV,R1		;SET TYPE FOR DOPE VECTOR
	TST	A$DISK(R2)		;IS IT A REAL DOPE VECTOR
	BEQ	30$			;NO
	BIS	#M.RDPE,R1		;YEP
30$:	CALLX	GETSPC			; MAKE ROOM
	MOV	R0,A$PNTR(R2)		;LINK US UP
	MOV	R2,(R0)+		; IN BOTH DIRECTIONS
	MOV	(SP)+,R1		;GET BACK THE COUNT
	BEQ	50$			;UNLESS THERE IS NONE
40$:	MOV	R3,(R0)+		;SIZE OF ROW HERE
	CLR	(R0)+			;NO CORE ADDRESS
	MOV	A$DISK(R2),(R0)+ 	;KEEP REAL TOG
	CLR	(R0)+			;ZERO LOWER BOUND
	SOB	R1,40$			;LOOP TIL DONE
	MOV	(SP)+,R1		;GET LAST SIZE
	BEQ	50$			;UNLESS THERE IS NONE
	MOV	R1,-10(R0)		;STICK IT IN
50$:	MOV	#1,A$DISK(R2)		;SAY WE HAVE ALLOCATED
	RTS	PC			;AND EXIT

	.END