; MACRO SUBROUTINE TO ISSUE ANY SYSTEM DIRECTIVE
;
; MAIN CALL
;	CALL "DIRECT"(A,S)
;
; WHERE
;	"A" IS THE 0TH ELEMENT OF A DIMENSIONED VARIABLE  CONTAINING
;	THE DIRECTIVE PARAMETER BLOCK.
;	TYPICALLY A "DIM A%(N) FACILITATES CREATING THE DIRECTIVE
;	PARAMETER BLOCK.
;
;	THE ROUTINE MAKES ROUTINE CHECKS OF THE VALIDITY OF THE DIRECTIVE
;	CODE, AND RETURNS A -99. IF THE DIRECTIVE FAILS. OTHERWISE THE
;	DIRECTIVE STATUS IS RETURNED IN "S"
;
;	TO ASSIST IN CREATING ADDRESSES IN DPB'S THE ENTRY POINT
;
;	CALL "GETADR"(A,B)
;
;	RETURNS THE ABSOLUTE ADDRESS OF VARIABLE "A" IN VARIABLE "B"
;	A & B ARE EXPECTED TO BE INTEGER VARIABLES
;
;
; IDENTIFYING INFO:
	.MCALL	ULODHD	;CALL MACRO
				;IDENTIFY START OF CODE, END OF CODE
				;AND ONE ENTRY POINT
	ULODHD	DIRECT,END,DIRECT,GETADR
;
AC0=%0
;
;
.PAGE
DIRECT:				;LABLE ACTUAL START OF CODE
	JSR	R4,@#GTRGPI	;GO GET ARGUMENTS IN PI FASHION
	.BYTE	2,2,0		;THIS IS ARG TYPE LIST
				;MAKE FIRST ONE OUTPUT NUMERIC SO WE CAN FIND
				;ITS ADDRESSS
				;2 OUTPUT, RETURNED STATUS
	.EVEN
				;WE NOW HAVE THIS DATA ON THE STACK
				;SP+12	5-WORD DESCRIPTOR FOR STATUS
				;SP>	5-WORD DESCRIPTOR FOR DPB
				;FORMAT	 2-WORD FLOATING POINT VALUE
				;	 2-WORD OFFSET (FP) TO ELEMENT
				;	 HEADER ADDRESS FOR VARIABLE
	JSR	PC,@#PARCHK	;CHECK FOR TRAILING RIGHT PAREN
	MOV	(SP)+,R0	;GET HEADER OFFSET
	MOV	(R0),R0		;AND HEADER
	BIC	#17777,R0	;ISOLATE TYPE BITS
	CMP	R0,#20000	;IS IT INTEGER VARIABLE
	BEQ	1$		;BR IF OK
	ADD	#4*2,SP		;CLEAN FIRST VARIABLE OFF STACK
	BR	BADDPB		;AND RETURN ERROR
1$:	LDF	(SP)+,AC0	;OFFSET INTO AC0
	CMP	(SP)+,(SP)+	;GET RID OF VALUE
	SETI			;SET INTEGER MODE
	STCFI	AC0,R0		;GET OFFSET IN R0
	ADD	@#STUDAT,R0	;MAKE R0 ADDRESS
	MOV	R0,-(SP)	;PUSH DPB ADDRESS ONTO STACK ONTO STACK
	MOV	(R0),R0		;GET DPB CODE AND SIZE
	BIT	#1,R0		;CODE BETTER BE ODD
	BEQ	BADTYP		;ELSE CODE IS BAD
	BIT	#200,R0		;LOWER BYTE CAN'T BE NEGATIVE
	BNE	BADTYP		;SO DO ERROR
	SWAB	R0		;GET SIZE IN LOWER BYTE
	BIC	#177400,R0	;CLEAR UPPER BYTE
	CMP	R0,#41.		;MAX SIZE IS 41 BYTES
	BGT	BADTYP		;ELSE ERROR
	EMT	377		;OK - - DO THE DIRECTIVE
	LDCIF	@#$DSW,AC0	;GET DIRECTIVE STATUS
	BR	RETURN		;AND RETURN STATUS
BADTYP:	TST	(SP)+		;POP DPB ADDRESS FROM STACK
BADDPB:	SETI			;SET INTEGER MODE
	LDCIF	#-99.,AC0	;PUT BAD STATUS IN AC0
RETURN:	MOV	SP,R5		;POINT R5 TO ARG TYP LIST ON STACK
	JSR	PC,@#NSTORE	;STORE THE RETURNED STATUS
	ADD	#5*2,SP		;RESTORE THE STACK
	RTS	PC
.PAGE
GETADR:				;LABLE ENTRY POINT
	JSR	R4,@#GTRGPI	;GO GET ARGUMENTS IN PI FASHION
	.BYTE	2,2,0		;THIS IS ARG TYPE LIST
				;MAKE FIRST ONE OUTPUT NUMERIC SO WE CAN FIND
				;ITS ADDRESSS
				;2 OUTPUT, RETURNED ADDRESS
	.EVEN
				;WE NOW HAVE THIS DATA ON THE STACK
				;SP+12	5-WORD DESCRIPTOR FOR ADDRESS
				;SP>	5-WORD DESCRIPTOR FOR VARIABLE
				;FORMAT	 2-WORD FLOATING POINT VALUE
				;	 2-WORD OFFSET (FP) TO ELEMENT
				;	 HEADER ADDRESS FOR VARIABLE
	JSR	PC,@#PARCHK	;CHECK FOR TRAILING RIGHT PAREN
	TST	(SP)+		;GET RID OF HEADER OFFSET
	LDF	(SP)+,AC0	;OFFSET INTO AC0
	CMP	(SP)+,(SP)+	;GET RID OF VALUE
	SETI			;SET INT MODE
	STCFI	AC0,R0		;GET OFFSET IN R0
	ADD	@#STUDAT,R0	;MAKE R0 ADDRESS
	LDCIF	R0,AC0		;CONVERT ADDRESS TO FLOATING
	MOV	SP,R5		;POINT R5 TO ARG TYP LIST ON STACK
	JSR	PC,@#NSTORE	;STORE THE RETURNED STATUS
	ADD	#5*2,SP		;RESTORE THE STACK
	RTS	PC
END:				;LABLE END OF CODE
	.END