You are invited to browse the list of mainframe-loving sites.
[ Join Now | Ring Hub | Random | << Prev | Next >> ]
SLFTST3A TITLE 'Driver for assignment 3 - Tax-deductible item'
***********************************************************************
* Start create : 12-04-2007
* 1st delivery : 12-04-2007
* Designer : AF Kornelis
* Programmer : AF Kornelis
***********************************************************************
*
* This program is a test-driver for the program the assignment asks
* you to create.
* Test invocations 1 through 9 have been commented out:
* these relate to aspects not requested in the assignment.
*
***********************************************************************
*
* Constants and definitions
*
***********************************************************************
MAXREASON EQU 6 * Max. reason code from program
LPP EQU 12 * Max. data lines per page
***********************************************************************
*
* Program entry and linkage
*
***********************************************************************
YREGS , * Define register equates
SLFTST3A CSECT , *
SLFTST3A AMODE 31
SLFTST3A RMODE 24
USING SLFTST3A,R15 * Establish addressability
B START * Skip header data
DC AL1(START-*),C'SLFTST3A &SYSDATE &SYSTIME'
START DS 0H
STM R14,R12,12(R13) * Save GPRs
LR R12,R15 * Copy base address
DROP R15 * No longer needed
USING SLFTST3A,R12 * Re-establish addressability
LA R2,SAVEAREA * Point new savearea
ST R2,8(,R13) * Set ptr to new savearea
ST R13,4(,R2) * Set ptr from ne to prev save
LR R13,R2 * Activate new savearea
***********************************************************************
*
* Obtain test results
*
***********************************************************************
OPEN (SYSOUT,OUTPUT)
MVC OUTREC,OUTREC-1 * Wipe entire print line
LA R8,1 * Init data line count
* * to force header on first put
* Testcase 1 - invalid pointer
XR R1,R1 * Destroy parm ptr
** BAS R14,CALL2B * Call ASSGN3
LA R1,PARMPTR * Set up parm ptr
* Testcase 2 - invalid pointer to parmarea
** BAS R14,CALL2B * Call ASSGN3
LA R15,PARMAREA
ST R15,PARMPTR
OI PARMPTR,X'80'
* Testcase 3 - missing pointer to printer record
LA R1,PARMPTR * Set up parm ptr
** BAS R14,CALL2B * Call ASSGN3
NI PARMPTR,X'7F'
* Testcase 4 - invalid pointer to printer record
LA R1,PARMPTR * Set up parm ptr
** BAS R14,CALL2B * Call ASSGN3
LA R15,OUTREC+1 * Pass only data area, no ASA
ST R15,PARMPTR+4
* Testcase 5 - too many parameters in parmarea
LA R1,PARMPTR * Set up parm ptr
** BAS R14,CALL2B * Call ASSGN3
OI PARMPTR+4,X'80'
* Testcase 6 - invalid pointer to percentage table
LA R1,PARMPTR * Set up parm ptr
** BAS R14,CALL2B * Call ASSGN3
LA R15,TABLE1
ST R15,TABPTR
* Testcase 7 - invalid reasoncode (too high)
LA R7,TEST7OK * Fake subrtn retaddr
IC R15,OUTREC * Save ASA char
MVC OUTREC,OUTREC-1 * Clear entire print line
STC R15,OUTREC * Restore ASA char
LA R15,12 * Set retcode=12
LA R0,MAXREASON+1 * Set reason too high
** B CHEAT * Pretend 2B did that
TEST7OK DS 0H
* Testcase 8 - invalid reasoncode (negative)
LA R7,TEST8OK * Fake subrtn retaddr
IC R15,OUTREC * Save ASA char
MVC OUTREC,OUTREC-1 * Clear entire print line
STC R15,OUTREC * Restore ASA char
LA R15,12 * Set retcode=12
LA R0,1 * Set reason to
LNR R0,R0 * Minus 1
** B CHEAT * Pretend 2B did that
TEST8OK DS 0H
* Testcase 9 - invalid returncode
LA R7,TEST9OK * Fake subrtn retaddr
IC R15,OUTREC * Save ASA char
MVC OUTREC,OUTREC-1 * Clear entire print line
STC R15,OUTREC * Restore ASA char
L R15,=X'7FFFFFFF' * Set retcode to max value
** B CHEAT * Pretend 2B did that
TEST9OK DS 0H
* Prepare next series of testcases
MVC NOMINAL,=CL6' '
MVC RESULT,=CL6' '
MVC GROSS,=CL6' '
MVC MINPERC,=CL6' '
MVC MINAMT,=CL6' '
MVC MAXPERC,=CL6' '
MVC MAXAMT,=CL6' '
MVC TABSIZE,=XL4'00'
MVC TABLEN,=XL4'00'
* Testcase 10 - NOMINAL not numeric
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP NOMINAL,=P'153999' * Nominal amount 1.539,99
* Testcase 11 - GROSS not numeric
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP GROSS,=P'2578900' * Gross income 25.789,--
* Testcase 12 - MINPERC not numeric
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP MINPERC,=P'10' * Perc lower threshold 1,0%
* Testcase 13 - MINAMT not numeric
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP MINAMT,=P'1500' * Lower threshold 15,--
* Testcase 14 - MAXPERC not numeric
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP MAXPERC,=P'750' * Perc upper threshold 75,0%
* Testcase 15 - MAXAMT niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP MAXAMT,=P'1800000' * Upper threshold 18.000,--
* Testcase 16 - TABSIZE = 0
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 17 - TABSIZE < 0
MVC TABSIZE,=H'-3' * Insert negative value
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
MVC TABSIZE,=H'3' * 3 elements initially
* Testcase 18 - TABLEN = 0
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 19 - TABLEN < 0
MVC TABLEN,=H'-16' * Insert negative value
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
MVC TABLEN,=H'16' * elementlengte = 16
* Testcase 20 - NOMINAL (>0) < MINAMT
ZAP NOMINAL,=P'47999' * Nominal amount 479,99
ZAP MINAMT,=P'48000' * Lower threshold 480,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 21 - NOMINAL (0) < MINAMT
ZAP NOMINAL,=P'0' * Nominal amount 0,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 22 - NOMINAL (<0) < MINAMT
ZAP NOMINAL,=P'-155500' * Nominal amount -1.550,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 23 - NOMINAL = MINAMT
ZAP NOMINAL,=P'48000' * Nominal amount 480,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 24 - NOMINAL > MINAMT
ZAP NOMINAL,=P'48001' * Nominal amount 480,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 25 - NOMINAL (>0) < PERC(GROSS) (no rounding)
ZAP NOMINAL,=P'54099' * Nominal amount 540,99
ZAP GROSS,=P'1082000' * Gross income 10.820,--
ZAP MINPERC,=P'50' * Min perc. 5,0%
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 26 - NOMINAL (>0) < PERC(GROSS) (rounded)
ZAP GROSS,=P'1083980' * Gross income 10.839,80
ZAP MINPERC,=P'50' * Min perc. 5,0%
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 27 - NOMINAL = PERC(BRUTO)
ZAP NOMINAL,=P'54100' * Nominal amount 541,--
ZAP GROSS,=P'1082000' * Gross income 10.820,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 28 - NOMINAL > PERC(GROSS)
ZAP NOMINAL,=P'54101' * Nominal amount 541,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 29 - GROSS = 0
ZAP GROSS,=P'0' * Gross income 0,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 30 - GROSS < 0
ZAP GROSS,=P'-1' * Gross income -0,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 30 - GROSS > 0
ZAP GROSS,=P'1082000' * Gross income 10.820,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 31 - Maximized at MAXAMT (>0)
ZAP MAXAMT,=P'48000' * Upper threshold 480,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 32 - Maximized at MAXBEDR (=0)
ZAP MAXAMT,=P'0' * Upper threshold 0,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 33 - Maximized at MAXPERC(GROSS)
ZAP NOMINAL,=P'216401' * Nominal amount 2.164,01
ZAP MAXAMT,=P'580000' * Upper threshold 5.800,--
ZAP MAXPERC,=P'200' * Max. percentage 20,0%
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 34 - Not maximized NOMINAL < MAXPERC(GROSS)
ZAP NOMINAL,=P'216399' * Nominal amount 2.163,99
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 35 - Not maximized NOMINAL = MAXPERC(GROSS)
ZAP NOMINAL,=P'216400' * Nominal amount 2.164,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 36 - Not maximized after rounding
ZAP GROSS,=P'1081501' * Gross income 10.815,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 37 - Maximized after rounding
ZAP GROSS,=P'1081499' * Gross income 10.814,99
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
ZAP GROSS,=P'1082000' * Gross income 10.820,--
*
* Prepare for table tests
LH R10,TABLEN
L R11,TABPTR * Point 1st entry
USING TABENT,R11 * Set addressable
* Testcase 38 - No applicable table entry
MVC TABSIZE,=H'1' * Only one element
ZAP TABMAX,=P'100' * Up to 1,-- inclusive
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 39 - No applicable table entry
MVC TABSIZE,=H'3' * Reset to 3 elements
LA R11,0(R10,R11) * Point entry 2
ZAP TABMAX,=P'200' * Up to 2,-- inclusive
LA R11,0(R10,R11) * Point entry 3
ZAP TABMAX,=P'300' * Up to 3,-- inclusive
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 40 - First table entry applicable
L R11,TABPTR * Point 1st entry
ZAP TABMAX,=P'500000' * Up to 5.000,-- inclusive
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 41 - Second table entry applicable
ZAP TABMAX,=P'150000' * Up to 1.500,-- inclusive
LA R11,0(R10,R11) * Point entry 2
ZAP TABMAX,=P'300000' * Up to 3.000,-- inclusive
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
* Testcase 42 - Different table, two elements, different length
* Last entry applicable, rounding required
MVC TABSIZE,=H'2' * Two entries
MVC TABLEN,=H'20' * of 20 bytes each
LA R11,TABLE2 * Point second table
ST R11,TABPTR * Set ptr in parmarea
LH R10,TABLEN * Correct element length
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call ASSGN3
PUT SYSOUT,TRAILER * Write trailer record
CLOSE (SYSOUT)
DROP R11 * Tabentry no longer in use
***********************************************************************
*
* Program exit, returncode already in R15
*
***********************************************************************
EXIT DS 0H * Workarea handling
L R13,4(,R13) * Get ptr to prev savearea
LM R14,R12,12(R13) * Reset all other registers
XR R15,R15 * Set returncode
BR R14 * Return
***********************************************************************
*
* Subroutine for calling subprogram ASSGN3
*
***********************************************************************
CALL2B DS 0H * Workarea handling
LR R7,R14 * Save return address
L R15,SUBPGM * Point ASSGN3
BASR R14,R15 * Call ASSGN3
CHEAT DS 0H * For testing errors in 2B
MVI OUTREC+1,C'0' * Assume RC=0
LTR R15,R15 * Retcode ok?
BZ CALL2BOK * Yes: continue
MVI OUTREC+1,C'4' * Assume RC=4
CH R15,=H'4' * Retcode 4?
BE CALL2BOK * Yes: continue
MVC RESULT,NORESULT * Force invalid value
MVI OUTREC+1,C'8' * Assume RC=8
CH R15,=H'8' * Retcode 8?
BE CALL2BOK * Yes: continue
MVC OUTREC+1(2),=C'12' * Assume RC=12
CH R15,=H'12' * For retcode 12
BE REASON12 * build error message
MVC OUTREC+1(2),=C' ' * Remove assumed RC
*
* invalid return code
CVD R15,WORKDEC * Show returncode
MVC OUTREC+1(L'CODEMASK),CODEMASK in decimal format
ED OUTREC+1(L'CODEMASK),WORKDEC as print data
MVC OUTREC+L'OUTREC-L'ERRMSG(L'ERRMSG),ERRMSG0
B CALL2BOK * Ja: ga verder
REASON12 DS 0H * Handle retcode 12
*
* RC=12, hence internal error, reasoncode in r0 determines which
* error message we need to create because ASSGN3 cannot produce an
* error message for internal errors
*
LA R15,MAXREASON * Max valid reasoncode
CLR R0,R15 * Valid reasoncode?
BNH REASONOK * Yes: ok
CVD R0,WORKDEC * Show reasoncode
MVC OUTREC+1(L'CODEMASK),CODEMASK in decimal format
ED OUTREC+1(L'CODEMASK),WORKDEC as print data
MVC OUTREC+1(2),=C'12' * Re-insert retcode
XR R0,R0 * issue general error message
REASONOK DS 0H *
LA R1,L'ERRMSG * Length of text entry
MR R0,R0 * R1 := 35*reasoncode
* * is offset into errmsg table
LA R15,ERRMSG(R1) * Point to correct error msg
MVC OUTREC+L'OUTREC-L'ERRMSG(L'ERRMSG),0(R15)
CALL2BOK DC 0H
*
* Call complete: print results - and header if needed
BCT R8,PRTDATA * R8 = residual line count
PUT SYSOUT,HEADER * Write header line
LA R8,LPP * Start with fresh count
MVI OUTREC,C'0' * Add blank line before data
PRTDATA DS 0H * Print a data line
PUT SYSOUT,OUTREC * Write report record
MVC OUTREC,OUTREC-1 * Clear entire print line
BR R7 * Return
DROP , * End all USINGs
***********************************************************************
*
* Data areas - constants
*
***********************************************************************
LTORG ,
SUBPGM DC V(ASSGN3)
SYSOUT DCB DDNAME=SYSOUT,DSORG=PS,MACRF=PM,LRECL=80,RECFM=FBA
HEADER DC CL81'1 Nominal amount Deductible amount'
TRAILER DC CL81'0*** End of Report *** '
ERRMSG0 DC CL35'Unknown returncode by ASSGN3! '
ERRMSG DC CL35'Unknown reasoncode by ASSGN3! '
DC CL35'ASSGN3 RSN=1 parmlist ptr wrong! ' Reason=1
DC CL35'ASSGN3 RSN=2 parmarea ptr wrong! ' Reason=2
DC CL35'ASSGN3 RSN=3 prtbuf ptr missing! ' Reason=3
DC CL35'ASSGN3 RSN=4 prtbuf ptr wrong! ' Reason=4
DC CL35'ASSGN3 RSN=5 superfluous parms! ' Reason=5
DC CL35'ASSGN3 RSN=6 table ptr wrong! ' Reason=6
NORESULT DC CL(L'RESULT)' ' * To invalidate RESULT field
MASK DC 4X'2020204B'
DC X'20212060'
CODEMASK EQU MASK,*-MASK
***********************************************************************
*
* Data areas - variables
*
***********************************************************************
SAVEAREA DC 18F'0' * Register savearea
WORKDEC DC D'0' * Workarea for CVD
DC CL1' ' * Blank for wiping OUTREC
OUTREC DC CL81' ' * Record area
*
PARMPTR DC A(0) * Ptr to Parmlist
LINEPTR DC A(0) * Ptr to print line
*
PARMAREA DS 0C *
NOMINAL DC PL6'154000' * Nominal amount 1.540,--
RESULT DC PL6'0' * Result amount
GROSS DC PL6'2578900' * Gross income 25.789,--
MINPERC DC PL2'50' * Perc lower threshold 5,0%
MINAMT DC PL6'50000' * Min. Lower threshold 500,--
MAXPERC DC PL2'250' * Perc upper threshold 25,0%
MAXAMT DC PL6'1800000' * Max. upper thres. 18.000,--
TABSIZE DC H'3' * nr of table elements
TABLEN DC H'16' * table element length
TABPTR DC A(0) * point to table
*
TABLE1 DC 0D
ENT1_1 DC PL6'500000' * 5.000,--
DC PL2'400' * 40,0%
DC XL8'00'
ENT1_2 DC PL6'1500000' * 15.000,--
DC PL2'500' * 50,0%
DC XL8'00'
ENT1_3 DC PL6'99999999999' *
DC PL2'750' * 75,0%
DC XL8'00'
*
TABLE2 DC 0D
ENT2_1 DC PL6'200000' * 2.000,--
DC PL2'183' * 18,3%
DC XL12'00'
ENT2_2 DC PL6'400000' * 4.000,--
DC PL2'217' * 21,7%
DC XL12'00'
*
PRINT NOGEN
DCBD DSORG=PS * Voor z390 variant of DCB
*
TABENT DSECT ,
TABMAX DS PL6'0' * Maximum amount
TABPERC DS PL2 * Percentage
DS 0X * Filler - size unknown
*
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.
|
|
|
|
||