/* TRASEC: LEIF SVALGAARD, 5 NOV 1990 */ ENTRY * (*PARMS) EXT; DCL SPCPTR *P1 PARM; /* MANDATORY FOR ALL FUNCTIONS */ DCL SPCPTR *P2 PARM; /* MANDATORY FOR ALL FUNCTIONS */ DCL SPCPTR *P3 PARM; /* OPTIONAL DEP. ON FUNCTION */ DCL SPCPTR *P4 PARM; /* OPTIONAL DEP. ON FUNCTION */ DCL SPCPTR *P5 PARM; /* OPTIONAL DEP. ON FUNCTION */ DCL SPCPTR *P6 PARM; /* OPTIONAL DEP. ON FUNCTION */ DCL OL *PARMS (*P1, *P2, *P3, *P4, *P5, *P6) EXT PARM MIN(2); DCL DD FUNCTION CHAR(1) BAS(*P1); /* ALL FUNCTIONS */ DCL DD RETCD CHAR(1) BAS(*P2); /* TRASEC (FUNCTION="T", RETCD, TAB1P, TAB2P, (TABRES)) */ DCL DD TAB1P CHAR(256) BAS(*P3); /* FOR TRATEST */ DCL DD TAB2P CHAR(256) BAS(*P4); DCL DD TABRES CHAR(256) BAS(*P5); /* OPTIONAL */ /* TRASEC (FUNCTION="I", RETCD, OPER, INIT, RECORDL) */ DCL DD OPER CHAR(1) BAS(*P3); /* FOR TRASINIT */ DCL DD DIRECT CHAR(1) DEF(OPER) POS(1); DCL DD INCODE CHAR(1) DEF(OPER) POS(2); DCL DD OUTCODE CHAR(1) DEF(OPER) POS(3); DCL DD INIT CHAR(8) BAS(*P4); DCL DD RECORDL ZND(5,0) BAS(*P5); /* TRASEC (FUNCTION="X", RETCD, RECORD, (RESULT)) */ DCL DD RECORD CHAR(32767) BAS(*P3); /* FOR TRASEXEC */ DCL DD RESULT CHAR(32) BAS(*P4); /* OPTIONAL */ /* TRASEC (FUNCTION="E", RETCD, T1, T2, T3, (RESF)) */ DCL DD T1 CHAR(10) BAS(*P3); /* FOR TRASEND */ DCL DD T2 CHAR(10) BAS(*P4); DCL DD T3 CHAR(10) BAS(*P5); DCL DD RESF CHAR(16) BAS(*P6); /* OPTIONAL */ DCL DD FIRST-RESET CHAR(1) INIT("Y"); DCL DD NBRPARMS BIN(2); DCL DD RECLENGTH BIN(2); DCL DD WHERE BIN(2); START: CPYBLA RETCD,"0"; STPLLEN NBRPARMS; CMPBLA(B) FUNCTION, "T"/EQ(TRATEST); CMPBLA(B) FUNCTION, "I"/EQ(TRASINIT); CMPBLA(B) FUNCTION, "X"/EQ(TRASEXEC); CMPBLA(B) FUNCTION, "E"/EQ(TRASEND); B ERROR1; ERROR4: ADDLC(S) RETCD,X'01'; ERROR3: ADDLC(S) RETCD,X'01'; ERROR2: ADDLC(S) RETCD,X'01'; ERROR1: ADDLC(S) RETCD,X'01'; FRESET: CPYBLA FIRST-RESET,"Y"; RETURN: RTX *; /******************************************************************/ /* */ /* TEST: FUNCTION = "T" */ /* OPTIONAL TAB1P (256) IF PRESENT, REPLACES INTERNAL TABLE 1 */ /* OPTIONAL TAB2P (256) IF PRESENT, REPLACES INTERNAL TABLE 2 */ /* OPTIONAL TABRES (256) LOW VALUES IF OK, POSITIONS NON-ZERO */ /* WHERE ERRORS ARE PRESENT */ /* IF TAB1P AND TAB2P ARE NOT GIVEN, THE INTERNAL TABLES */ /* ARE NOT CHANGED, BUT ONLY CHECKED */ /* RETCD = "0" OK */ /* "1" INVALID NUMBER OF PARAMETERS */ /* "2" TABLES DO NOT CHECK OUT */ /* */ /******************************************************************/ DCL DD TAB1 CHAR(256); DCL DD *(16) CHAR(16) DEF(TAB1) POS(1) INIT (X'729DBFCDEDB3CB3DE1377897BBB4835A', /* 00 - 0F */ X'29AF2F80B87AB12E24F23144DAC1E269', /* 10 - 1F */ X'45F5D618F3F098D1E7DDD966C0EEF632', /* 20 - 2F */ X'E4BCC255FF9AE3FB6BCF1756B2AA94CC', /* 30 - 3F */ X'EBE85D398ECA7958738C13C681A5149C', /* 40 - 4F */ X'F73475B54992208562279FC5A2B6AB11', /* 50 - 5F */ X'84B04FC97B1CA90AF191AD50DE3A40BE', /* 60 - 6F */ X'6E1EE9F8824388EC5FACD3869323B9D8', /* 70 - 7F */ X'4C3C5EEF71FDD0A0A6077D6722284201', /* 80 - 8F */ X'4602A82A76D248700E52A1DC256051F9', /* 90 - 9F */ X'BDC78D30EAD4410BD74E1B069B7FDFF4', /* A0 - AF */ X'53DB6C898B04E01047E5612CC8964AD5', /* B0 - BF */ X'FEE63F7E776F6D0D87BA953B1D7C7416', /* C0 - CF */ X'0F63990C051A646A09C4B7900326C3A3', /* D0 - DF */ X'9E3659CE5CFA38FC15123E008F574B33', /* E0 - EF */ X'655408215B2D1F19AE4D2B8AA7A46835');/* F0 - FF */ DCL DD TAB2 CHAR(256); DCL DD *(16) CHAR(16) DEF(TAB2) POS(1) INIT (X'E8DCABFDBB2E71C9C5B77CC6305BF2F9', /* 00 - 0F */ X'0EEAFC1C73400B2926324467768024D1', /* 10 - 1F */ X'F57858EC4BD839E0FA981FF4CF70E7B5', /* 20 - 2F */ X'05EF4D8141876AFE6E4F15EE85B3D9E9', /* 30 - 3F */ X'A795BDD483B93428E6F013E262CA3893', /* 40 - 4F */ X'E304353EE523A0CB6F25DDB4ADE1AE64', /* 50 - 5F */ X'185A118EB048AAD68A0092BAD39120C4', /* 60 - 6F */ X'035F969D532F02A2ACC265D031A48F94', /* 70 - 7F */ X'C737DE68B25D9BED3CD53FB17D6C226B', /* 80 - 8F */ X'CC16A15EFFC388BC42A62DF6D2F327A8', /* 90 - 9F */ X'519CFB74CE0CC1B81B7E6D3DF19ADB59', /* A0 - AF */ X'D7BE4309EB12DF990A014950825C0856', /* B0 - BF */ X'557A1721F89EA360BF7F471A1E61F775', /* C0 - CF */ X'A5339FAF63728D3A7B0789542B84194A', /* D0 - DF */ X'1D100F2A06B6577977363BE4DA6652C8', /* E0 - EF */ X'8C864ECD0D4C8B45972CC046A9901469');/* F0 - FF */ DCL DD TAB3 CHAR(256); DCL DD *(16) CHAR(16) DEF(TAB3) POS(1) INIT (X'96F3566166091AB310FEACBC50EB68DD', /* 00 - 0F */ X'9859B5C70A65BEE74B4EEF83897A0F00', /* 10 - 1F */ X'B94C8D26CD8C4233798407AA55528B4D', /* 20 - 2F */ X'06821723692D2A46BA7529A0436DFF1E', /* 30 - 3F */ X'E477E14F2247C26F9D7D1CA3370C73D2', /* 40 - 4F */ X'45412F12F0A1F55D11E0A89EFBDF3DEA', /* 50 - 5F */ X'B2D7937FD0767E7C86169AE31915A708', /* 60 - 6F */ X'20243697DED43CDA64F1AF9B5EEC017B', /* 70 - 7F */ X'6285AEC85F90A551C1C9A4D658FABDDC', /* 80 - 8F */ X'34AB1B1F029FE603F2359C2BD818042C', /* 90 - 9F */ X'5C606C053B6395C63A386771F6944A0D', /* A0 - AF */ X'3E54D3D5B1BB1D0E28B65ACFBF881372', /* B0 - BF */ X'1457E98FA2C4915BED49C3EE8031530B', /* C0 - CF */ X'F98EA6302E44B092B7F899CCFD392174', /* D0 - DF */ X'276A25F7ADC06EA940FCD9E86BCBE281', /* E0 - EF */ X'48E5C578B470D132DBCAF43FB8CE8A87');/* F0 - FF */ DCL DD WORK CHAR(256); TRATEST: CMPNV(B) NBRPARMS, 2/NEQ(TEST-TABS); TEST-INT: XLATEWT WORK, TAB1, TAB2; XOR(S) WORK, TAB3; VERIFY(B) WHERE, WORK, X'00'/NZER(ERROR2); B FRESET; TEST-TABS: CMPNV(B) NBRPARMS, 4/LO(ERROR1); XLATEWT WORK, TAB1P, TAB2P; XOR(S) WORK, TAB3; CMPNV(B) NBRPARMS, 5/LO(VERIFY-IT); CPYBLA TABRES, WORK; VERIFY-IT: VERIFY(B) WHERE, WORK, X'00'/NZER(ERROR2); INSTALL: CPYBLA TAB1, TAB1P; CPYBLA TAB2, TAB2P; B FRESET; /******************************************************************/ /* */ /* INIT: FUNCTION = "I" */ /* INCODE = "A", IF INPUT IS ASCII, "E" IF EBCDIC, */ /* OTHERWISE, INPUT WILL BE ACCEPTED AS IS */ /* INIT = EIGHT BYTES IN SET ("0"-"9", "A"-"F") */ /* TO BE USED IN PAIRS AS INIT CHARS */ /* RECORDL = RECORD LENGTH (256 <= LENGTH < 32K) */ /* RETCD = "0" OK */ /* "1" INVALID NUMBER OF PARAMETERS */ /* "2" INIT CHARS NOT VALID */ /* "3" RECORD SIZE INVALID */ /* */ /******************************************************************/ /*DCL EXCM CONVERSION-ERROR EXCID(H'1201') BP(ERROR2) CV('MCH');*/ DCL EXCM CONVERSION-ERROR EXCID(H'0C01') BP(ERROR2); DCL DD INIT-CHARS CHAR (4); DCL DD INIT1 CHAR (1) DEF(INIT-CHARS) POS(1); DCL DD INIT2 CHAR (1) DEF(INIT-CHARS) POS(2); DCL DD INIT3 CHAR (1) DEF(INIT-CHARS) POS(3); DCL DD INIT4 CHAR (1) DEF(INIT-CHARS) POS(4); DCL DD SAVED-OPER CHAR(3); DCL DD SEND-RECV CHAR(1) DEF(SAVED-OPER) POS(1); DCL DD INPUT-CODE CHAR(1) DEF(SAVED-OPER) POS(2); DCL DD OUTPUT-CODE CHAR(1) DEF(SAVED-OPER) POS(3); TRASINIT: CMPNV(B) NBRPARMS, 5/NEQ(ERROR1); CPYBLA SAVED-OPER, OPER; CVTCH INIT-CHARS, INIT; /* CONVERSION ERR */ CMPNV(B) RECORDL, 32767/HI(ERROR3); CPYNV RECLENGTH, RECORDL; CMPNV(B) RECLENGTH, 256/LO(ERROR3); B FRESET; /******************************************************************/ /* */ /* EXEC: FUNCTION = "X" */ /* RECORD CURRENT RECORD FROM INPUT STRING */ /* OPTIONAL RESULT 32 CHAR INTERMEDIATE RESULT */ /* RETCD = "0" OK */ /* "1" INVALID NUMBER OF PARAMETERS */ /* "4" INVALID CHARS FOUND */ /* */ /******************************************************************/ DCL DD GRES CHAR(256); DCL DD HRESL CHAR(128) DEF(GRES) POS(1); DCL DD IRESL CHAR(64) DEF(HRESL) POS(1); DCL DD RESL CHAR(32) DEF(IRESL) POS(1); DCL DD RESH CHAR(32) DEF(IRESL) POS(33); DCL DD IRESH CHAR(64) DEF(HRESL) POS(65); DCL DD HRESH CHAR(128) DEF(GRES) POS(129); DCL DD RES CHAR(32) DEF(RESL) POS(1); DCL DD RES[1-28] CHAR(28) DEF(RES) POS(1); DCL DD RES[29-32] CHAR(4) DEF(RES) POS(29); DCL DD RESFL CHAR(16) DEF(RES) POS(1); DCL DD BIT64L CHAR(8) DEF(RESFL) POS(1); DCL DD BIT64H CHAR(8) DEF(RESFL) POS(9); DCL DD RESFH CHAR(16) DEF(RES) POS(17); DCL INSPTR .RETURN; DCL DD REST BIN(2); DCL DD UPOS BIN(2); DCL DD ULEN BIN(2); DCL DD RPOS BIN(2); DCL DD SAVED-UNIT CHAR(256); DCL DD UNIT CHAR(256); DCL DD UNIT[1-28] CHAR(28) DEF(UNIT) POS(1); DCL DD UNIT[29-256] CHAR(228) DEF(UNIT) POS(29); TRASEXEC: CMPNV(B) NBRPARMS, 3/LO(ERROR1); CMPBLA(B) FIRST-RESET,"Y"/NEQ(NEXT-TIME); FIRST-TIME: CPYBLA FIRST-RESET,"N"; CPYNV RPOS, 1; CPYNV UPOS, 1; CPYNV ULEN, 256; CALLI LOAD, *,.RETURN; CALLI MIX, *,.RETURN; CPYBLA WORK, GRES; CALLI CONDENS, *,.RETURN; SUBN REST, RECLENGTH, 256; NEXT-UNIT: CPYNV UPOS, 29; CPYNV ULEN, 228; CPYBLA UNIT[1-28], RES[1-28]; CPYBLA INIT-CHARS, RES[29-32]; CMPNV(B) REST, 228/LO(LAST-CHUNK); LOAD-AND-MIX: CALLI LOAD, *,.RETURN; CPYBLA SAVED-UNIT, UNIT; CALLI MIX, *,.RETURN; CALLI CONDENS, *,.RETURN; SUBN(SB) REST,ULEN/NNEG(NEXT-UNIT); NEXT-TIME: CPYNV RPOS, 1; CPYNV REST, RECLENGTH; SUBN ULEN, 257, UPOS; B LOAD-AND-MIX; LAST-CHUNK: CPYNV ULEN, REST; CALLI LOAD, *,.RETURN; ADDN(S) UPOS, ULEN; CMPNV(B) NBRPARMS, 4/LO(RETURN); CPYBLA RESULT, RES; B RETURN; /******************************************************************/ /* */ /* END: FUNCTION = "E" */ /* T1 TOTAL1/CHECKDIGITS TTTTTTT/CD */ /* T2 TOTAL2/CHECKDIGITS TTTTTTT/CD */ /* T3 TOTAL3/CHECKDIGITS TTTTTTT/CD */ /* OPTIONAL RESF 16 HEX CHAR FINAL RESULT */ /* RETCD = "0" OK */ /* "1" INVALID NUMBER OF PARAMETERS */ /* */ /******************************************************************/ DCL DD B0132 CHAR(4) DEF(BIT64L) POS(1); DCL DD B1748 CHAR(4) DEF(BIT64L) POS(3); DCL DD B3364 CHAR(4) DEF(BIT64L) POS(5); DCL DD BITS CHAR(4) BDRY(4); DCL CON MASK22 CHAR(4) INIT(X'003FFFFF'); DCL CON MASK20 CHAR(4) INIT(X'000FFFFF'); DCL CON NULL-VALUE CHAR(4) INIT(X'00000000'); DCL CON SHIFT10 CHAR(2) INIT(X'000A'); DCL CON SHIFT4 CHAR(2) INIT(X'0004'); TRASEND: CMPNV(B) NBRPARMS, 5/LO(ERROR1); SUBN(B) ULEN, 257, UPOS/EQ(GET-TOTALS); CMPNV(B) ULEN, 228/EQ(GET-TOTALS); XOR(S) WORK(UPOS:ULEN), SAVED-UNIT(UPOS:ULEN); CPYBLA UNIT(UPOS:ULEN), WORK(UPOS:ULEN); CALLI MIX, *,.RETURN; CALLI CONDENS, *,.RETURN; GET-TOTALS: XOR(S) RESFL, RESFH; XOR(S) BIT64L, BIT64H; CPYBTRLS BITS, B0132, SHIFT10; SETSPP .TOTAL, T1; CALLI TOTAL, *,.RETURN; CPYBTRLS BITS, B1748, SHIFT4; AND(S) BITS, MASK22; SETSPP .TOTAL, T2; CALLI TOTAL, *,.RETURN; AND BITS, B3364, MASK20; SETSPP .TOTAL, T3; CALLI TOTAL, *,.RETURN; CMPNV(B) NBRPARMS, 6/LO(FRESET); CVTHC RESF, BIT64L; B FRESET; /* ----------------- INTERNAL SUBROUTINES ------------------*/ DCL DD VALID-ASCII CHAR(256); DCL DD *(16) CHAR(16) DEF(VALID-ASCII) POS(1) INIT (X'00000000000000000000000000000000', /* 00 - 0F */ X'00000000000000000000000000000000', /* 10 - 1F */ X'202122232425262728292A2B2C2D2E2F', /* 20 - 2F */ X'303132333435363738393A3B3C3D3E3F', /* 30 - 3F */ X'404142434445464748494A4B4C4D4E4F', /* 40 - 4F */ X'505052535455565758595A5B5C5D5E5F', /* 50 - 5F */ X'606162636465666768696A6B6C6D6E6F', /* 60 - 6F */ X'707172737475767778797A7B7C7D7E7F', /* 70 - 7F */ X'00000000000000000000000000000000', /* 80 - 8F */ X'00000000000000000000000000000000', /* 90 - 9F */ X'00000000000000000000000000000000', /* A0 - AF */ X'00000000000000000000000000000000', /* B0 - BF */ X'00000000000000000000000000000000', /* C0 - CF */ X'00000000000000000000000000000000', /* D0 - DF */ X'00000000000000000000000000000000', /* E0 - EF */ X'00000000000000000000000000000000');/* F0 - FF */ DCL DD VALID-EBCDIC CHAR(256); DCL DD *(16) CHAR(16) DEF(VALID-EBCDIC) POS(1) INIT (X'00000000000000070000000000000000', /* 00 - 0F */ X'00000000000000000000000000000000', /* 10 - 1F */ X'00000000000000000000000000000000', /* 20 - 2F */ X'00000000000000000000000000000000', /* 30 - 3F */ X'400000000000000000004A4B4C4D4E4F', /* 40 - 4F */ X'500000000000000000005A5B5C5D5E5F', /* 50 - 5F */ X'606100000000000000006A6B6C6D6E6F', /* 60 - 6F */ X'000000000000000000797A7B7C7D7E7F', /* 70 - 7F */ X'00818283848586878889000000000000', /* 80 - 8F */ X'00919293949596979899000000000000', /* 90 - 9F */ X'00A1A2A3A4A5A6A7A8A9000000000000', /* A0 - AF */ X'00000000000000000000000000000000', /* B0 - BF */ X'C0C1C2C3C4C5C6C7C8C9000000000000', /* C0 - CF */ X'D0D1D2D3D4D5D6D7D8D9000000000000', /* D0 - DF */ X'E000E2E3E4E5E6E7E8E9000000000000', /* E0 - EF */ X'F0F1F2F3F4F5F6F7F8F9000000000000');/* F0 - FF */ ENTRY LOAD INT; /* LOAD UNIT AND CHECK IF VALID */ CMPBLA(B) INPUT-CODE, "A"/EQ(CHECK-ASCII); CMPBLA(B) INPUT-CODE, "E"/EQ(CHECK-EBCDIC); CPYBLA UNIT(UPOS:ULEN), RECORD(RPOS:ULEN); UPD-RPOS: ADDN(S) RPOS, ULEN; B .RETURN; CHECK-ASCII: XLATEWT UNIT(UPOS:ULEN), RECORD(RPOS:ULEN), VALID-ASCII; CHECK: SCAN(B) WHERE, UNIT(UPOS:ULEN), X'00'/NZER(ERROR4); B UPD-RPOS; CHECK-EBCDIC: XLATEWT UNIT(UPOS:ULEN), RECORD(RPOS:ULEN), VALID-EBCDIC; B CHECK; /* ---------------------------------------------------------*/ DCL DD BIN-VALUE BIN(4) DEF(BITS) POS(1); DCL SPCPTR .TOTAL; DCL SPC * BAS(.TOTAL); DCL DD ZTOTAL ZND(7,0) DIR; DCL DD TSEP CHAR(01) DIR; DCL DD ZCD ZND(2,0) DIR; ENTRY TOTAL INT; /* COMPUTE TOTAL AND CHECKDIGITS */ ADDN ZTOTAL, BIN-VALUE, 1000000; SUBN BIN-VALUE, ZTOTAL, 1; REM(S) BIN-VALUE, 97; ADDN ZCD, BIN-VALUE, 1; CPYBLA TSEP, "/"; B .RETURN; /* ---------------------------------------------------------*/ DCL DD TRANS1 CHAR(256); DCL DD TRANS1C(256) CHAR(1) DEF(TRANS1) POS(1); DCL DD TRANS2 CHAR(256); DCL DD TRANS2C(256) CHAR(1) DEF(TRANS2) POS(1); DCL DD RXOR1$ CHAR(257); DCL DD RXOR1L(256) CHAR(1) DEF(RXOR1$) POS(1); DCL DD RXOR1 CHAR(256) DEF(RXOR1$) POS(2); DCL DD RXOR1C(256) CHAR(1) DEF(RXOR1) POS(1); DCL DD RXOR2$ CHAR(257); DCL DD RXOR2 CHAR(256) DEF(RXOR2$) POS(1); DCL DD RXOR2C(256) CHAR(1) DEF(RXOR2) POS(1); DCL DD RXOR2H(256) CHAR(1) DEF(RXOR2$) POS(2); DCL DD I BIN(2) BDRY(2); DCL DD T BIN(2) BDRY(2); ENTRY MIX INT; /* MIX THE UNIT */ XLATEWT RXOR1, TAB1, UNIT; XLATEWT TRANS1, RXOR1, TAB1; XLATEWT TRANS2, UNIT, TAB2; CPYNV I,1; CPYBLA RXOR1L(I), INIT1; SUBN T,257,I; CPYBLA RXOR2H(T), INIT2; ROLLXOR12: XOR RXOR1C(I), RXOR1L(I), TRANS1C(I); XOR RXOR2C(T), RXOR2H(T), TRANS2C(T); ADDN(S) I,1; SUBN(SB) T,1/HI(ROLLXOR12); XLATEWT TRANS1, RXOR1, TAB1; XLATEWT TRANS2, RXOR2, TAB2; CPYNV I,1; CPYBLA RXOR1L(I), INIT4; SUBN T,257,I; CPYBLA RXOR2H(T), INIT3; ROLLXOR43: XOR RXOR2C(T), RXOR2H(T), TRANS1C(T); XOR RXOR1C(I), RXOR1L(I), TRANS2C(I); ADDN(S) I,1; SUBN(SB) T,1/HI(ROLLXOR43); XLATEWT TRANS2, RXOR1, TAB2; XOR GRES , RXOR2, TRANS2; B .RETURN; /* ---------------------------------------------------------*/ ENTRY CONDENS INT;/* CONDENS TO 32 CHAR RESULT */ XOR(S) HRESL, HRESH; XLATEWT HRESL, HRESL, TAB2; XOR(S) IRESL, IRESH; XOR(S) RESL, RESH; B .RETURN; PEND;