You are invited to browse the list of mainframe-loving sites.
[ Join Now | Ring Hub | Random | << Prev | Next >> ]
© Copyright Edward Soto 2003-2006. All rights reserved.
This software is free; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either
version 2 of the License,
or (at your option) any later version.
More information is available from
the Free Software Foundation or
the Open Source Initiative.
This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with this software; if not, write to either of the following:
|
the Free Software Foundation, Inc. 59 Temple Place, Suite 330 Boston, MA 02111-1307 United States of America |
B.V. Bixoft Rogge 9 7261 JA Ruurlo The Netherlands |
|
email: bixoft@bixoft.nl phone: +31-6-22755401 |
Remark:
This software - and more programs and macros - are available in a format more
suitable for uploading to your mainframe. Please e-mail
B.V. Bixoft with your request
and you will receive a zipped IEBUPDTE job with the program sources.
* 00000100
* This program is free software; you can redistribute it and/or modify 00000200
* it under the terms of the GNU General Public License as published by 00000300
* the Free Software Foundation; either version 2 of the License 00000400
* or (at your option) any later version. 00000500
* The license text is available at the following internet addresses: 00000600
* - http://www.bixoft.com/english/gpl.htm 00000700
* - http://fsf.org 00000800
* - http://opensource.org 00000900
* 00001000
* This program is distributed in the hope that it will be useful, 00001100
* but WITHOUT ANY WARRANTY; without even the implied warranty of 00001200
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00001300
* See the GNU General Public License for more details. 00001400
* 00001500
* You should have received a copy of the GNU General Public License 00001600
* along with this program; if not, write to either of the following: 00001700
* the Free Software Foundation, Inc. B.V. Bixoft 00001800
* 59 Temple Place, Suite 330 Rogge 9 00001900
* Boston, MA 02111-1307 7261 JA Ruurlo 00002000
* United States of America The Netherlands 00002100
* 00002200
* e-mail: bixoft@bixoft.nl 00002300
* phone : +31-6-22755401 00002400
* 00002500
TITLE 'RE-ENTRANT FIND TABLE ENTRY VIA BINARY SEARCH'
*---------------------------------------------------------------------*
* IMPORTANT: PLEASE READ AND UNDERSTAND BEFORE USING.
* 1.INPUT TABLE MUST BE IN ASCENDING ORDER KEY SEQUENCE.
* 2.KEY LENGTH (KEYLEN) MAY NOT EXCEED 256 BYTES.
* 3.KEY OFFSET (KEYOFF) IS FROM ENTRY'S FIRST BYTE.
* 4.KEYOFF AND ENTRY LENGTH (ENTLEN) MAY EACH EXCEED 256 BYTES.
* 5.ENTRY COUNT (ENTCNT) MAY BE AN EVEN OR ODD NUMBER.
* 6.FOUND ENTRY'S ADDRESS OR HEX'00'S IS RETURNED VIA REGISTER ONE.
* 7.USER PARAMETERS AND TABLE ATTRIBUTES ARE ASSUMED VALID.
* 8.A LOGICAL COMPARE (CLC) IS USED IN FINDING ARGUMENT = KEY MATCH.
* 9.LAST TABLE ENTRY SHOULD HAVE AN HEX'FF'S KEY.
*---------------------------------------------------------------------*
* CALL BINSRCH,(TBPARMS,ARGUMENT)
* LTR R3,R1 Q,DESIRED ENTRY FOUND?
* BZ NOTFOUND NO,GO TO ENTRY NOT FOUND ROUTINE.
* USING TBDSECT,R3
*---------------------------------------------------------------------*
* R1 R2 R3 R4 R5
*TBPARMS DC A(INPTBL,ENTCNT,ENTLEN,KEYLEN,KEYOFF)
*---------------------------------------------------------------------*
SPACE 2
BINSRCH CSECT , RE-ENTRANT 2005OCT25ESOTO
USING *,R15
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B BEGIN
DC CL8'BINSRCH',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
BEGIN DS 0D
LM R11,R12,0(R1) LOAD USER PARAMETERS.
LM R1,R5,0(R11) LOAD INPUT TABLE ATTRIBUTES.
LM R6,R9,=A(BREG6,BREG7,BREG8,BREG9)
AR R1,R5 R1 NOW POINTS TO 1ST ENTRY'S KEY.
BCTR R4,R0 R4 NOW KEYLEN FOR EX/BTEST/CLC.
LR R11,R3 INITIALLY R1 POINTS TO ENTRY ZERO
BREG6 DS 0H
SR R1,R11 R1 NOW PREVIOUS INPTBL TEST ADR.
BREG7 DS 0H
SRA R2,1 DIVIDE CURRENT ENTCNT IN HALF.
BNPR R8 IF INITIALLY NOT FOUND, FAST FWD.
LR R11,R2 CREATING NEW INPTBL TEST KEY ADR.
MR R10,R3 R11 NOW NEW INPTBL TEST OFFSET.
AR R1,R11 R1 NOW CURRENT INPTBL TEST ADR.
EX R4,BTEST Q,ARGUMENT = ENTRY KEY, A MATCH?
BLR R6 USE PREVIOUS INPTBL TEST ADR.
BHR R7 USE CURRENT INPTBL TEST ADR.
BR R9 RETURN FOUND ENTRY ADR VIA R1.
BTEST DS 0H
CLC 0(0,R12),0(R1) Q,ARGUMENT = ENTRY KEY, A MATCH?
BREG8 DS 0H
AR R1,R3 R1 POINTS TO NEXT SEQUENTIAL ENTRY.
EX R4,BTEST Q,ARGUMENT = ENTRY KEY, A MATCH?
BHR R8 CONTINUE FAST FORWARD SEARCH.
BER R9 RETURN FOUND ENTRY ADR VIA R1.
LR R1,R5 ENTRY NOT FOUND; RETURN HEX'00'S.
BREG9 DS 0H
SR R1,R5 R1 NOW FOUND ENTRY ADR OR HEX'00'S.
LM R2,R12,28(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
END
TITLE 'RE-ENTRANT VALIDATE ASCENDING ORDER SEQUENCE TABLE'
*---------------------------------------------------------------------*
* CALL VALSEQ,(TBPARMS)
* LTR R15,R15 Q,TABLE IN ASCENDING ORDER SEQUENCE?
* BNZ ABORT NO,ABORT JOB.
*---------------------------------------------------------------------*
* R1 R2 R3 R4 R5
*TBPARMS DC A(INPTBL,ENTCNT,ENTLEN,KEYLEN,KEYOFF)
*---------------------------------------------------------------------*
SPACE 2
VALSEQ CSECT , RE-ENTRANT 2006JAN18ESOTO
USING *,R15
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B VAL000
DC CL8'VALSEQ',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
VAL000 DS 0D
L R1,0(,R1) LOAD USER PARAMETER (TBPARMS).
LM R1,R5,0(R1) LOAD INPUT TABLE ATTRIBUTES.
BCTR R2,R0 R2 NOW NUMBER OF TEST PAIRS.
BCTR R4,R0 R4 NOW KEY LENGTH FOR VAL300 (CLC).
AR R5,R1 R5 NOW POINTS TO 1ST ENTRY'S KEY.
BASR R6,R0 R6 NOW POINTS TO NEXT INSTR.
*
LR R1,R5 R1 NOW 1ST ENTRY KEY ADR.
AR R5,R3 R5 NOW 2ND ENTRY KEY ADR.
EX R4,VAL300 Q,ENTRY PAIR IN KEY SEQUENCE?
BH VAL200 NO, SEQ-ERROR,EXIT.
BCTR R2,R6 TEST NEXT PAIR OF TABLE ENTRIES.
*
XR R15,R15 RETURN CODE: GOOD; IN SEQUENCE.
VAL200 DS 0H
LM R0,R12,20(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
VAL300 DS 0H
CLC 0(0,R1),0(R5) Q,ENTRY PAIR IN KEY SEQUENCE?
*
END
TITLE 'RE-ENTRANT FROM 1BYTE(8BITS) TO 8-BYTES OF ZEROS/ONES'
*---------------------------------------------------------------------*
* CALL FROM1TO8,(8BITS,8BYTES)
*---------------------------------------------------------------------*
SPACE 2
FROM1TO8 CSECT , RE-ENTRANT 2005OCT25ESOTO
USING *,R15
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) SAVE USER REGISTERS.
B FROM000
DC CL8'FROM1TO8',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
FROM000 DS 0H
LM R1,R2,0(R1) LOAD USER INPUT/OUTPUT ADDRESSES.
IC R1,0(,R1) R1 NOW HAS 8 BITS TO EXPLODE.
LA R2,7(,R2) R2 POINTS TO LAST OUTPUT BYTE.
LA R3,8 NEEDED TO LOOP 8 TIMES.
BASR R4,R0 R4 NOW POINTS TO NEXT INSTR.
*
STC R1,0(,R2) MOVE LOW-ORDER BIT TO OUTPUT.
SRL R1,1 R1 NOW HAS NEW LOW ORDER BIT.
BCTR R2,R0 R2 NOW POINTS NEXT OUTPUT BYTE.
BCTR R3,R4 LOOP UNTIL ALL 8 BITS MOVED.
*
NC 1(8,R2),=8X'01' KEEP OUTPUT LOW ORDER BITS.
OC 1(8,R2),=8X'F0' OUTPUT NOW ZEROS/ONES.
LM R14,R12,12(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
END
TITLE 'RE-ENTRANT 8 BYTES(ZEROS/ONES) TO 8 BITS(ZEROS/ONES)'
*---------------------------------------------------------------------*
* CALL FROM8TO1,(8BYTES,8BITS)
*---------------------------------------------------------------------*
SPACE 2
FROM8TO1 CSECT , RE-ENTRANT 2005OCT25ESOTO
USING *,R15
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) SAVE USER REGISTERS.
B FROM000
DC CL8'FROM8TO1',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
FROM000 DS 0H
LM R2,R3,0(R1) LOAD USER INPUT/OUTPUT ADDRESSES.
LA R2,7(,R2) POINT TO LAST INPUT BYTE.
LA R4,8 NUMBER OF BYTES TO PROCESS.
BASR R5,R0 R5 POINTS TO NEXT INSTR.
*
IC R0,0(,R2) MOVE 1 BYTE TO LOW ORDER BYTE.
SRDL R0,1 MOVE 1 BIT TO R1 HIGH BIT.
BCTR R2,R0 POINT TO NEXT INPUT BYTE.
BCTR R4,R5 PROCESS NEXT INPUT BYTE.
*
STCM R1,B'1000',0(R3) MOVE DESIRED OUTPUT (8 BITS).
LM R14,R12,12(R13) RESTORE USER REGSITERS.
BR R14 RETURN TO USER CONTROL.
*
END
TITLE 'RE-ENTRANT MNEMONIC(AAA-Z99) TO REL-OFFSET(1-33696)'
*---------------------------------------------------------------------*
* CALL MNE2OFF,(MNECODE,RELOFF)
* LTR R15,R15 Q,GOOD CONVERSION?
* BNZ ERRMNE NO, HANDLE INVALID MNEMONIC.
*---------------------------------------------------------------------*
SPACE 2
MNE2OFF CSECT , RE-ENTRANT 2006JAN18ESOTO
USING *,R15
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B MNE000
DC CL8'MNE2OFF',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
MNE000 DS 0D
LM R4,R5,0(R1) LOAD USER INPUT/OUTPUT ADDRESSES.
CLI 0(R4),C'Z' Q, 1ST MNEMONIC CHARACTER INVALID?
BH MNE900 YES, EXIT; INVALID INPUT MNE.
XR R2,R2 TRT USES R2 (BITS 24-31).
TRT 0(1,R4),TRTMNE GET 1ST MNE CHAR REL-VALUE (1-26).
BZ MNE900 EXIT IF 1ST MNE CHARACTER INVALID.
BCTR R2,R0 R2 NOW 0-25.
MH R2,=Y(36*36) R2 NOW 0-32400.
LR R3,R2 BUILDING RELATIVE OFFSET IN R3.
XR R2,R2 TRT USES R2 (BITS 24-31).
TRT 1(1,R4),TRTMNE GET 2ND MNE CHAR REL-VALUE (1-36).
BZ MNE900 EXIT IF 2ND MNE CHARACTER INVALID.
BCTR R2,R0 R2 NOW 0-35.
MH R2,=Y(36) R2 NOW 0-1260.
AR R3,R2 R3 NOW 0-33660.
XR R2,R2 TRT USES R2 (BITS 24-31).
TRT 2(1,R4),TRTMNE GET 3RD MNE CHAR REL-VALUE (1-36).
BZ MNE900 EXIT IF 3RD MNE CHARACTER INVALID.
AR R3,R2 R3 NOW 1-33696.
STCM R3,B'0011',0(R5) RETURN RELATIVE OFFSET TO USER.
XR R15,R15 RETURN CODE: GOOD CONVERSION.
MNE900 DS 0H
LM R0,R12,20(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
TRTMNE DC 0D,256X'0'
ORG TRTMNE+C'A'
DC AL1(1,2,3,4,5,6,7,8,9) A-I
ORG TRTMNE+C'J'
DC AL1(10,11,12,13,14,15,16,17,18) J-R
ORG TRTMNE+C'S'
DC AL1(19,20,21,22,23,24,25,26) S-Z
ORG TRTMNE+C'0'
DC AL1(27,28,29,30,31,32,33,34,35,36) 0-9
*
END
TITLE 'RE-ENTRANT REL-OFFSET(1-33696) TO MNEMONIC(AAA-Z99)'
*---------------------------------------------------------------------*
* CALL OFF2MNE,(RELOFF,MNECODE)
* LTR R15,R15 Q,GOOD CONVERSION?
* BNZ ERROFF NO, HANDLE INVALID REL-OFFSET.
*---------------------------------------------------------------------*
SPACE 2
OFF2MNE CSECT , RE-ENTRANT 2006JAN18ESOTO
USING *,R15
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B OFF000
DC CL8'OFF2MNE',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
OFF000 DS 0D
LM R2,R3,0(R1) LOAD USER INPUT/OUTPUT ADDRESSES.
XR R1,R1 NEEDED TO DO ARITHMETIC.
ICM R1,B'0011',0(R2) R1 NOW REL-OFFSET (1-33696).
BZ OFF900 EXIT IF ZEROES, INVALID.
C R1,=A(26*36*36) Q, R1 GREATER THAN 33696?
BH OFF900 YES, EXIT, INVALID.
BCTR R1,R0 R1 NOW 0-33695.
XR R0,R0 NEEDED BY NEXT INSTR (DIVIDE).
D R0,=A(36*36) GET 1ST BYTE OF OUTPUT MNEMONIC.
STC R1,0(,R3) R1 (QUOTIENT) NOW 0-25. 1ST BYTE.
LR R1,R0 MAKE REMAINDER THE DIVIDEND.
XR R0,R0 NEEDED BY NEXT INSTR (DIVIDE).
D R0,=A(36) GET 2ND & 3RD BYTES OF OUTPUT MNE.
STC R1,1(,R3) R1 (QUOTIENT) NOW 0-35. 2ND BYTE.
STC R0,2(,R3) R0 (REMAINDER) NOW 0-35. 3RD BYTE.
TR 0(3,R3),=C'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'
XR R15,R15 RETURN CODE: GOOD CONVERSION.
OFF900 DS 0H
LM R0,R12,20(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
END
TITLE 'RE-ENTRANT PARSES VARIABLE LENGTH N/A RECORD'
*---------------------------------------------------------------------*
* CALL PARSNAD,(INPNAD,OUTNAD)
* LTR R15,R15 Q, N/A PARSING SUCCESSFUL?
* BNZ PARSERR NO, HANDLE INVALID N/A RECORD.
*---------------------------------------------------------------------*
SPACE 2
PARSNAD CSECT , RE-ENTRANT 2006JAN18ESOTO
USING *,R15
USING NADOUT,R6
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) SAVE USER REGISTERS.
B PARS000
DC CL8'PARSNAD',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
PARS000 DS 0D
LM R5,R6,0(R1) LOAD USER INPUT/OUTPUT ADDRESSES.
MVI 0(R6),C' ' NEEDED TO BLANK-OUT NADOUT.
MVC 1(NADLEN-1,R6),0(R6) MOVES BLANKS TO NADOUT.
LA R2,L'NADNUM R2 MAX LENGTH OF NADNUM.
BAS R14,FINDX40 GET ACTUAL LENGTH OF FIELD
EX R1,MVCNUM MOVE NADNUM (UP TO FIVE BYTES).
LA R5,2(R1,R5) R5 POINTS TO START OF NAME.
LA R2,L'NADNAME R2 MAX LENGTH OF NAME FIELD.
BAS R14,FINDX40 GET ACTUAL LENGTH OF NAME FIELD.
EX R1,MVNAME MOVE NADNAME (UP TO 15 BYTES)
LA R5,2(R1,R5) R5 POINTS TO START OF CITY.
LA R2,L'NADCITY R2 MAX LENGTH OF CITY FIELD.
BAS R14,FINDX40 GET ACTUAL LENGTH OF CITY.
EX R1,MVCITY MOVE NADCITY (UP TO 10 BYTES)
LA R5,2(R1,R5) R5 POINTS TO START OF STATE.
LA R2,L'NADSTAT R2 MAX LENGTH OF STATE FIELD.
BAS R14,FINDX40 GET ACTUAL LENGTH OF STATE.
EX R1,MVSTAT MOVE NADSTAT (UP TO 5 BYTES)
LA R5,2(R1,R5) R5 POINTS TO START OF ZIP CODE.
LA R2,L'NADZIP R2 MAX LENGTH OF ZIP CODE FIELD.
BAS R14,FINDX40 GET ACTUAL LENGTH OF ZIP CODE.
EX R1,MVZIP MOVE NADZIP (FIVE BYTES).
XR R15,R15 RETURN CODE: PARSING SUCCESSFUL.
PARS900 DS 0H
LM R0,R12,20(R13) RESTORE USER REGISTERS.
L R14,R12(,R13) RESTORE USER LINKING REGISTER.
BR R14 RETURN TO USER CONTROL.
*
FINDX40 DS 0H
EX R2,GETX40 FINDS BLANK FIELD SEPARATOR.
BZ PARS900 BLANK NOT FOUND, BAD INPUT DATA.
SR R1,R5 CREATING NEEDED LENGTH.
BCTR R1,R0 LENGTH NEEDED FOR EX/MVC.
BR R14 RETURN TO NEXT INSTR.
*
GETX40 TRT 0(0,R5),TRTX40
*
TRTX40 DC 0D,256X'0' 1x4
ORG TRTX40+C' ' 2x4
DC C' ' 3x4 SEARCH CHARACTER: BLANK.
ORG , 4x4
*
MVNUM MVC NADNUM(0),0(R5)
MVNAME MVC NADNAME(0),0(R5)
MVCITY MVC NADCITY(0),0(R5)
MVSTAT MVC NADSTAT(0),0(R5)
MVZIP MVC NADZIP(0),0(R5)
*
LTORG
*
NADOUT DSECT , OUTPUT PARSED NAD RECORD.
NADNUM DS CL5
NADNAME DS CL15
NADCITY DS CL10
NADSTAT DS CL5
NADZIP DS CL5
NADLEN EQU *-NADNUM
*
END
TITLE 'RE-ENTRANT TURN ZIP CODE BIT ON'
*---------------------------------------------------------------------*
* CALL ZIPFLAG,(ZIPCODE)
* LTR 15,15 Q,ZIP CODE BIT TURNED ON ?
* BNZ ERRZIP NO,HANDLE INVALID ZIP CODE.
*---------------------------------------------------------------------*
SPACE 2
ZIPFLAG CSECT , RE-ENTRANT 2005JUL13ESOTO
USING *,R15
USING SAVREGS,R13 USER RE-ENTRANT WORK AREA.
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B ZIP000
DC CL8'ZIPFLAG',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
ZIP000 DS 0D
L R1,0(,R1) LOAD USER ZIP CODE ADDRESS.
TRT 0(5,R1),TRTNUM Q,VALID ZIP CODE? NUMERIC?
BNZ ZIP200 NO, EXIT, INVALID, NOT NUMERIC.
PACK DWORK,0(5,R1)
CVB R3,DWORK
XR R2,R2 NEEDED BY NEXT (DIVIDE) INSTR.
D R2,=A(8) DIVIDE BY 8 (BITS TO A BYTE).
LA R3,ZIPTBL(R3) R3 NOW ADDR OF ZIP CODE BIT.
IC R2,ZIPMASK(R2) INSERT CORRECT BIT MASK.
EX R2,ZIP300 TURN ZIP CODE BIT ON.
XR R15,R15 RETURN CODE: GOOD; ZIP CODE BIT ON.
ZIP200 DS 0H
LM R0,R12,20(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
ZIP300 DS 0H
OI 0(R3),0 TURN ZIP CODE BIT ON.
*
LTORG
* 0 1 2 3 4 5 6 7 POSSIBLE REMAINDERS (0-7).
ZIPMASK DC X'8040201008040201'
*
ENTRY TRTNUM
TRTNUM DC 0D,240C' ',10X'0',6C' '
*
ENTRY ZIPTBL
ZIPTBL DC 0D,(100000/8)X'0'
*
SAVREGS DSECT
DS 0D,18A 1X2 USER SAVEREGS.
DWORK DS D 2X2 USER RE-ENTRANT WORK AREA.
*
END
TITLE 'RE-ENTRANT TURN ZIP CODE BIT OFF'
*---------------------------------------------------------------------*
* CALL ZIPOFF,(ZIPCODE)
* LTR R15,R15 Q,ZIP CODE BIT TURNED OFF ?
* BNZ ERRZIP NO,HANDLE INVALID ZIP CODE.
*---------------------------------------------------------------------*
SPACE 2
ZIPOFF CSECT , RE-ENTRANT 2005JUL13ESOTO
USING *,R15
USING SAVREGS,R13 USER RE-ENTRANT WORK AREA.
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B ZIP000
DC CL8'ZIPOFF',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
ZIP000 DS 0D
L R1,0(,R1) LOAD USER ZIP CODE ADDRESS.
L R2,=V(TRTNUM) POINT TO NUMERIC TRT TABLE.
TRT 0(5,R1),0(R2) Q,NUMERIC? VALID ZIP CODE?
BNZ ZIP200 NO,EXIT, INVALID ZIP CODE.
PACK DWORK,0(5,R1) PACK NUMERIC ZIP CODE.
CVB R3,DWORK CONVERT IT TO BINARY.
XR R2,R2 NEEDED FOR NEXT INSTR.
D R2,=A(8) DIVIDE BY 8 (BITS TO A BYTE).
A R3,=V(ZIPTBL) R3 NOW ADDR OF ZIP CODE BIT.
IC R2,ZIPMASK(R2) R2 NOW HAS CORRECT ZIP BIT MASK.
EX R2,ZIP300 TURN ZIP CODE BIT OFF.
XR R15,R15 RETURN CODE: GOOD; ZIP CODE BIT OFF.
ZIP200 DS 0H
LM R0,R12,20(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
ZIP300 DS 0H
NI 0(R3),0 TURN ZIP CODE BIT OFF.
*
LTORG
* 0 1 2 3 4 5 6 7
ZIPMASK DC AL1(255-128,255-64,255-32,255-16,255-8,255-4,255-2,255-1)
*
SAVREGS DSECT
DS 0D,18A 1X2 USER SAVEREGS.
DWORK DS D 2X2 USER RE-ENTRANT WORK AREA.
*
END
TITLE 'RE-ENTRANT TEST IF ZIP CODE BIT ON'
*---------------------------------------------------------------------*
* CALL ZIPTEST,(ZIPCODE)
* LTR R15,R15 Q,VALID ZIP CODE ?
* BNZ ERRZIP NO, HANDLE INVALID ZIP CODE.
* LTR R1,R1 Q,ZIP CODE BIT OFF?
* BZ ZIPOFF YES
*---------------------------------------------------------------------*
SPACE 2
ZIPTEST CSECT , RE-ENTRANT 2005JUL15ESOTO
USING *,R15
USING SAVREGS,R13 USER RE-ENTRANT WORK AREA.
PRINT NOGEN
YREGS , EQUATES REGISTERS 0-15 TO R0-R15.
STM R14,R12,12(R13) STORE USER REGISTERS.
B ZIP000
DC CL8'ZIPTEST',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
ZIP000 DS 0D
L R1,0(,R1) LOAD USER ZIP CODE ADR.
L R2,=V(TRTNUM) POINT TO NUMERIC TRT TABLE.
TRT 0(5,R1),0(R2) Q,NUMERIC ZIP CODE? VALID?
BNZ ZIP200 NO, EXIT, INVALID ZIP CODE.
PACK DWORK,0(5,R1)
CVB R3,DWORK R3 NOW BINARY ZIP CODE.
XR R2,R2 NEEDED BY NEXT (DIVIDE) INSTR.
D R2,=A(8) DIVIDE BY 8 (BITS TO A BYTE).
A R3,=V(ZIPTBL) R3 NOW ADDR OF VALID ZIP CODE BIT.
IC R2,ZIPMASK(R2) INSERT CORRECT BIT MASK.
EX R2,ZIP300 Q,ZIP CODE BIT ON.
BO ZIP100 YES.
XR R1,R1 NO.
ZIP100 DS 0H
XR R15,R15 RETURN CODE: GOOD (VALID ZIP CODE).
ZIP200 DS 0H
LM R2,R12,28(R13) RESTORE USER REGISTERS.
BR R14 RETURN TO USER CONTROL.
*
ZIP300 DS 0H
TM 0(R3),0 TEST IF ZIP CODE BIT ON.
*
LTORG
* 0 1 2 3 4 5 6 7 POSSIBLE REMAINDERS (0-7).
ZIPMASK DC X'8040201008040201'
*
SAVREGS DSECT
DS 0D,18A 1X2 USER SAVEREGS.
DWORK DS D 2X2 USER RE-ENTRANT WORK AREA.
*
END
|
This site is a member of WebRing. You are invited to browse the list of mainframe-loving sites. |
|
Dinos are not dead. They are alive and well and living in data centers all around you. They speak in tongues and work strange magics with computers. Beware the dino! And just in case you're waiting for the final demise of these dino's: remember that dinos ruled the world for 155-million years! |
|
Dinos and other anachronisms [ Join Now | Ring Hub | Random | << Prev | Next >> ] |
||
Below you find the logo of our sponsor and logos of the web-standards that this page adheres to.
|
|
|
|
||