Trailing-Edge
-
PDP-10 Archives
-
decuslib20-06
-
decus/20-153/subscr.mac
There are 9 other files named subscr.mac in the archive. Click here to see a list.
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