TITLE	SUBSCR FOR RPGLIB %1
	SUBTTL	SUBSCRIPTING ROUTINES FOR RPGLIB

;
;	SUBSCR		GENERAL SUBSCRIPTING ROUTINES FOR RPGLIB
;
;	THIS MODULE CONTAINS VARIOUS SUBSCRIPTING ROUTINES USED
;	BY RPGLIB AND THE USER'S PROGRAM.
;
;	BOB CURRIER	FEBRUARY 25, 1976 21:21:35
;
;	ALL RIGHTS RESERVED, BOB CURRIER
;

	TWOSEG
	RELOC	400000

	ENTRY	SUBSCR			; UUO CALLED ROUTINE
	ENTRY	SUBS			; GENERAL RPGLIB ROUTINE
	ENTRY	SUBSC.			; ROUTINE FOR UNKNOWN INDEX

	SEARCH	RPGPRM, RPGSWI, RPGUNV, INTERM, UUOSYM, MACTEN

	DEBUG==:DEBUG

;SUBSCR		SUBSCRIPTING ROUTINE TO BE CALLED FROM USER PROGRAM
;
;CALLING SEQUENCE:
;
;		MOVE	PA,[Z AC,PARAM]
;		PUSHJ	PP,SUBSCR
;
;	PARAM:	BYTE POINTER TO START OF TABLE
;		TABLE-SIZE,,ENTRY-SIZE
;
;AC CONTAINS INDEX ON CALL, CONTAINS BYTE POINTER TO SELECTED TABLE
;ENTRY UPON RETURN.
;

SUBSCR:	LDB	TC,[POINT 4,PA,12]	; GET THE AC
	MOVE	TC,(TC)			; GET THE INDEX
	JUMPLE	TC,SUBOUT		; [110] make sure index is .GE. 0
	HLRZ	TD,1(PA)		; GET TABLE SIZE
	CAMLE	TC,TD			; IS SUBSCRIPT VALID?
	  JRST	SUBOUT			; NO - INDEX OUT OF BOUNDS
	SUBI	TC,1			; GET INDEX TO ORGIN 0
	SETZB	SZ,SZ+1			; ZERO OUT SIZE HOLDERS
	HRRZ	SZ,1(PA)		; GET SIZE OF ENTRY
	IMUL	SZ,TC			; MULTIPLY BY ENTRY-NUMBER
	MOVE	BP,(PA)			; GET STARTING BYTE POINTER
	LDB	TD,[POINT 6,BP,11]	; GET BYTE SIZE
	MOVEI	TC,^D36			; GOOD OL' 36 BIT WORDS
	IDIV	TC,TD			; COMPUTE BYTES/WORD
	IDIV	SZ,TC			; COMPUTE WORD OFFSET
	ADD	BP,SZ			; ADD WORD OFFSET TO EXISTING POINTER
	SOJL	SZ+1,SBSR.2		; BUMP POINTER REMAINDER TIMES
SBSR.1:	IBP	BP			; LIKE THIS
	SOJGE	SZ+1,SBSR.1		; KEEP ON LOOPINF 'TIL DONE

SBSR.2:	LDB	TC,[POINT 4,PA,12]	; GET RETURN AC
	MOVEM	BP,(TC)			; RETURN THAT BYTE POINTER
	POPJ	PP,			; EXIT
;SUBS		GENERAL SUBSCRIPTING ROUTINE FOR RPGLIB
;
;CALLING SEQUENCE:
;
;		MOVE	TA,[ICHTAB POINTER TO ARRAY]
;		MOVE	TB,[INDEX]
;		PUSHJ	PP,SUBS
;		  RETURN WITH POINTER IN TB
;
;

SUBS:	LDB	TC,IC.OCC##		; GET "NUMBER OF OCCURS"
	CAMLE	TB,TC			; IS INDEX IN BOUNDS?
	  JRST	SUBOUT			; NOPE - ERROR
	SUBI	TB,1			; MAKE INDEX ORGIN ZED
	SETZB	SZ,SZ+1			; ZERO THOSE COUNTERS
	LDB	SZ,IC.SIZ##		; GET SIZE OF ARRAY ENTRY
	IMUL	SZ,TB			; MULTIPLY BY INDEX
	LDB	BP,IC.DES##		; GET BYTE POINTER
	LDB	TA,IC.FMT##		; GET TABLE FORMAT
	MOVE	TA,STAB(TA)		; GET BYTE SIZE
	DPB	TA,[POINT 6,BP,11]	; STASH IN BYTE POINTER
	MOVEI	TB,^D36			; GET THAT CONSTANT
	IDIV	TB,TA			; GET BYTES/WORD
	IDIV	SZ,TB			; GET WORD OFFSET
	ADD	BP,SZ			; ADD TO OLD BYTE POINTER
	SOJL	SZ+1,SUBS.1		; SKIP OVER IF WE CAN
SUBS.0:	IBP	BP			; ELSE INCREMENT POINTER
	SOJGE	SZ+1,SUBS.0		; LOOP UNTIL DONE

SUBS.1:	MOVE	TB,BP			; GET INTO PROPER AC
	POPJ	PP,			; EXIT

STAB:	DEC	6			; SIXBIT
	DEC	7			; ASCII
	DEC	9			; EBCDIC

;SUBSC.		SUBSCRIPTING ROUTINE FOR USE WHEN INDEX MUST BE CALCULATED
;
;CALLING SEQUENCE:
;
;		MOVE	TB,[ICHTAB POINTER TO SUBSCRIPT]
;		MOVE	TC,[ICHTAB POINTER TO ARRAY]
;		PUSHJ	PP,SUBSC.
;		  RETURN WITH BYTE-POINTER IN TB
;

SUBSC.:	PUSH	PP,TC			; SAVE POINTER
	MOVE	TA,TB			; GET POINTER INTO OK AC
	LDB	TB,IC.FLD##		; GET FIELD TYPE
	CAIN	TB,2			; BINARY?
	  JRST	SUBC.1			; YES -
	PUSH	PP,TA			; [065] no - save subscript pointer
	LDB	AC3,IC.DES##		; GET BYTE POINTER TO SUBSCRIPT
	LDB	TC,IC.SIZ##		; GET SIZE OF ENTRY
	DPB	TC,[POINT 11,AC3,17]	; STASH SIZE IN POINTER
	LDB	TC,IC.FMT		; GET FORMAT
	MOVE	PA,[Z 1,AC3]		; GET THAT WORD
	PUSHJ	PP,@STAB1(TC)		; CONVERT FROM STRANGE TO REAL
	POP	PP,TA			; GET BACK SUBSCRIPT POINTER
	LDB	TC,IC.SIZ		; GET SIZE
	MOVE	TB,1			; GET FIRST WORD
	CAILE	TC,^D10			; IS IT DOUBLE PRECISION?
	  MOVE	TB,2			; YES - USE SECOND WORD
	POP	PP,TA			; RESTORE POINTER TO ARRAY
	JUMPLE	TB,SUBMIN		; IF INDEX NOT > 0 ERROR
	PJRST	SUBS			; GO FINISH UP ELSEWHERE

SUBC.1:	LDB	TB,IC.DES		; GET POINTER
	LDB	TC,IC.SIZ		; GET SIZE
	CAIG	TC,^D10			; DOUBLE PRECISION?
	  SKIPA	TB,(TB)			; NO -
	MOVE	TB,1(TB)		; YES -
	POP	PP,TA			; GET BACK POINTER
	JUMPLE	TB,SUBMIN		; ERROR IF NOT > 0
	PJRST	SUBS			; GO FINISH

STAB1:	EXP	GD6.##			; SIXBIT
	EXP	GD7.##			; ASCII
	EXP	ULOSE.##		; EBCDIC (not implemented)

;ERROR ROUTINES FOR SUBSCRIPTING ROUTINES
;

SUBOUT:
SUBMIN:	PUSHJ	PP,%%H.14##		; invalid index
	POPJ	PP,			; in case of continue



	AC3==3
	TA==4
	TB==5
	TC==6
	TD==7
	TE==10
	TF==11
	TG==12
	PA==16
	PP==17

	SZ==TE				; TWO AC'S
	BP==TG				; JUST ONE









	END