Bekijkt u gerust de lijst van mainframe-gerelateerde sites.
[ Aanmelden | Ring Overzicht | Willekeurig | << Vorige | Volgende >> ]
SLFTST3A TITLE 'Driver voor toets-opgave 3 Aftrekpost'
***********************************************************************
* Start create : 12-04-2007
* 1st delivery : 12-04-2007
* Designer : AF Kornelis
* Programmer : AF Kornelis
***********************************************************************
*
* Dit programma is een test-driver voor het programma dat in de
* opgave gevraagd is te maken.
* De test-aanroepen 1 t/m 9 zijn afgesterd:
* dit betreft diverse testen die niet gevraagd zijn in de opgave.
*
***********************************************************************
*
* Constants and definitions
*
***********************************************************************
MAXREASON EQU 6 * Max. reason code from TOETS3
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 TOETS3
LA R1,PARMPTR * Set up parm ptr
* Testcase 2 - invalid pointer to parmarea
** BAS R14,CALL2B * Call TOETS3
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 TOETS3
NI PARMPTR,X'7F'
* Testcase 4 - invalid pointer to printer record
LA R1,PARMPTR * Set up parm ptr
** BAS R14,CALL2B * Call TOETS3
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 TOETS3
OI PARMPTR+4,X'80'
* Testcase 6 - invalid pointer to percentage table
LA R1,PARMPTR * Set up parm ptr
** BAS R14,CALL2B * Call TOETS3
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 NOMINAAL,=CL6' '
MVC RESULT,=CL6' '
MVC BRUTO,=CL6' '
MVC MINPERC,=CL6' '
MVC MINBEDR,=CL6' '
MVC MAXPERC,=CL6' '
MVC MAXBEDR,=CL6' '
MVC TABSIZE,=XL4'00'
MVC TABLEN,=XL4'00'
* Testcase 10 - NOMINAAL niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP NOMINAAL,=P'153999' * Nominaal bedrag 1.539,99
* Testcase 11 - BRUTO niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP BRUTO,=P'2578900' * Bruto inkomen 25.789,--
* Testcase 12 - MINPERC niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP MINPERC,=P'10' * Perc ondergrens 1,0%
* Testcase 13 - MINBEDR niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP MINBEDR,=P'1500' * Abs. ondergrens 15,--
* Testcase 14 - MAXPERC niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP MAXPERC,=P'750' * Perc bovengrens 75,0%
* Testcase 15 - MAXBEDR niet numeriek
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP MAXBEDR,=P'1800000' * Abs. bovengrens 18.000,--
* Testcase 16 - TABSIZE = 0
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
MVC TABSIZE,=H'-3' * 3 elementen initieel
* Testcase 17 - TABSIZE < 0
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
MVC TABSIZE,=H'3' * 3 elementen initieel
* Testcase 18 - TABLEN = 0
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
MVC TABLEN,=H'-16' * elementlengte = 16
* Testcase 19 - TABLEN < 0
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
MVC TABLEN,=H'16' * elementlengte = 16
* Testcase 20 - NOMINAAL (>0) < MINBEDR
ZAP NOMINAAL,=P'47999' * Nominaal bedrag 479,99
ZAP MINBEDR,=P'48000' * Abs. ondergrens 480,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 21 - NOMINAAL (0) < MINBEDR
ZAP NOMINAAL,=P'0' * Nominaal bedrag 0,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 22 - NOMINAAL (<0) < MINBEDR
ZAP NOMINAAL,=P'-155500' * Nominaal bedrag -1.550,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 23 - NOMINAAL = MINBEDR
ZAP NOMINAAL,=P'48000' * Nominaal bedrag 480,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 24 - NOMINAAL > MINBEDR
ZAP NOMINAAL,=P'48001' * Nominaal bedrag 480,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 25 - NOMINAAL (>0) < PERC(BRUTO) (zonder afronden)
ZAP NOMINAAL,=P'54099' * Nominaal bedrag 540,99
ZAP BRUTO,=P'1082000' * Bruto inkomen 10.820,--
ZAP MINPERC,=P'50' * Min perc. 5,0%
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 26 - NOMINAAL (>0) < PERC(BRUTO) (met afronden)
ZAP BRUTO,=P'1083980' * Bruto inkomen 10.839,80
ZAP MINPERC,=P'50' * Min perc. 5,0%
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 27 - NOMINAAL = PERC(BRUTO)
ZAP NOMINAAL,=P'54100' * Nominaal bedrag 541,--
ZAP BRUTO,=P'1082000' * Bruto inkomen 10.820,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 28 - NOMINAAL > PERC(BRUTO)
ZAP NOMINAAL,=P'54101' * Nominaal bedrag 541,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 29 - BRUTO = 0
ZAP BRUTO,=P'0' * Bruto inkomen 0,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 30 - BRUTO < 0
ZAP BRUTO,=P'-1' * Bruto inkomen -0,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 30 - BRUTO > 0
ZAP BRUTO,=P'1082000' * Bruto inkomen 10.820,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 31 - Gemaximeerd op MAXBEDR (>0)
ZAP MAXBEDR,=P'48000' * Max. bedrag 480,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 32 - Gemaximeerd op MAXBEDR (=0)
ZAP MAXBEDR,=P'0' * Max. bedrag 0,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 33 - Gemaximeerd op MAXPERC(BRUTO)
ZAP NOMINAAL,=P'216401' * Nominaal bedrag 2.164,01
ZAP MAXBEDR,=P'580000' * Max. bedrag 5.800,--
ZAP MAXPERC,=P'200' * Max. percentage 20,0%
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 34 - Niet gemaximeerd NOMINAAL < MAXPERC(BRUTO)
ZAP NOMINAAL,=P'216399' * Nominaal bedrag 2.163,99
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 35 - Niet gemaximeerd NOMINAAL = MAXPERC(BRUTO)
ZAP NOMINAAL,=P'216400' * Nominaal bedrag 2.164,--
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 36 - Niet gemaximeerd na afronding
ZAP BRUTO,=P'1081501' * Bruto inkomen 10.815,01
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 37 - Gemaximeerd na afronding
ZAP BRUTO,=P'1081499' * Bruto inkomen 10.814,99
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
ZAP BRUTO,=P'1082000' * Bruto inkomen 10.820,--
*
* Prepare for table tests
LH R10,TABLEN
L R11,TABPTR * Point 1st entry
USING TABENT,R11 * Set addressable
* Testcase 38 - Geen tabel entry van toepassing
MVC TABSIZE,=H'1' * Slechts een element
ZAP TABMAX,=P'100' * T/m 1,00 Euro
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 39 - Geen tabel entry van toepassing
MVC TABSIZE,=H'3' * Slechts een element
LA R11,0(R10,R11) * Point entry 2
ZAP TABMAX,=P'200' * T/m 2,00 Euro
LA R11,0(R10,R11) * Point entry 3
ZAP TABMAX,=P'300' * T/m 3,00 Euro
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 40 - Eerste tabel entry van toepassing
L R11,TABPTR * Point 1st entry
ZAP TABMAX,=P'500000' * T/m 5.000,-- Euro
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 41 - Tweede tabel entry van toepassing
ZAP TABMAX,=P'150000' * T/m 1.500,-- Euro
LA R11,0(R10,R11) * Point entry 2
ZAP TABMAX,=P'300000' * T/m 3.000,-- Euro
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
* Testcase 42 - Andere tabel van twee elementen, andere lengte
* Laatste tabel entry van toepassing en afronden
MVC TABSIZE,=H'2' * Twee entries
MVC TABLEN,=H'20' * van 20 bytes
LA R11,TABLE2 * Point tweede tabel
ST R11,TABPTR * Set ptr in parmarea
LH R10,TABLEN * Corrigeer element-lengte
LA R1,PARMPTR * Set up parm ptr
BAS R14,CALL2B * Call TOETS3
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 voor aanroepen subprogramma
*
***********************************************************************
CALL2B DS 0H * Workarea handling
LR R7,R14 * Save return address
L R15,SUBPGM * Point naar TOETS3
BASR R14,R15 * Call TOETS3
CHEAT DS 0H * For testing errors in 2B
MVI OUTREC+1,C'0' * Assume RC=0
LTR R15,R15 * Retcode ok?
BZ CALL2BOK * Ja: ga verder
MVI OUTREC+1,C'4' * Assume RC=4
CH R15,=H'4' * Retcode 4?
BE CALL2BOK * Ja: ga verder
MVC RESULT,NORESULT * Forceer ongeldige waarde
MVI OUTREC+1,C'8' * Assume RC=8
CH R15,=H'8' * Retcode 8?
BE CALL2BOK * Ja: ga verder
MVC OUTREC+1(2),=C'12' * Assume RC=12
CH R15,=H'12' * Bij retcode 12
BE REASON12 * error message bouwen
MVC OUTREC+1(2),=C' ' * Remove assumed RC
*
* ongeldige 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, dus interne fout, reasoncode in r0 bepaalt welke
* Error message moeten we hier opbouwen omdat TOETS3 bij
* interne fouten geen print-data kan produceren
*
LA R15,MAXREASON * Max geldige reasoncode
CLR R0,R15 * Geldige reasoncode?
BNH REASONOK * Ja: Akkoord
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 * geef algmene foutmelding
REASONOK DS 0H *
LA R1,L'ERRMSG * Lengte tekst-entry
MR R0,R0 * R1 := 35*reasoncode
* * is offset in errmsg tabel
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(TOETS3)
SYSOUT DCB DDNAME=SYSOUT,DSORG=PS,MACRF=PM,LRECL=80,RECFM=FBA
HEADER DC CL81'1 Nominaal bedrag Aftrekbaar bedrag'
TRAILER DC CL81'0*** Einde Overzicht *** '
ERRMSG0 DC CL35'Onbekende returncode van TOETS3! '
ERRMSG DC CL35'Onbekende reasoncode van TOETS3! '
DC CL35'TOETS3 RSN=1 parmlist ptr fout! ' Reason=1
DC CL35'TOETS3 RSN=2 parmarea ptr fout! ' Reason=2
DC CL35'TOETS3 RSN=3 prtbuf ptr ontbreekt!' Reason=3
DC CL35'TOETS3 RSN=4 prtbuf ptr fout! ' Reason=4
DC CL35'TOETS3 RSN=5 overtollige parms! ' Reason=5
DC CL35'TOETS3 RSN=6 tabel ptr fout! ' 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 *
NOMINAAL DC PL6'154000' * Nominaal bedrag 1.540,--
RESULT DC PL6'0' * Resultaat-bedrag
BRUTO DC PL6'2578900' * Bruto inkomen 25.789,--
MINPERC DC PL2'50' * Perc ondergrens 5,0%
MINBEDR DC PL6'50000' * Abs. ondergrens 500,--
MAXPERC DC PL2'250' * Perc bovengrens 25,0%
MAXBEDR DC PL6'1800000' * Abs. bovengrens 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 van DCB
*
TABENT DSECT ,
TABMAX DS PL6'0' * Maximum bedrag
TABPERC DS PL2 * Percentage
DS 0X * Filler - size unknown
*
END
|
Deze site is aangesloten bij WebRing. Bekijkt u gerust de lijst van mainframe-gerelateerde sites. |
|
Dino's zijn niet dood. Ze zijn gezond en wel en leven in computer-centra overal om ons heen. Zij spreken in tongen en doen wonderbare magie met computers. Pas op voor de dino! En voor het geval u zit te wachten op het definitieve einde van deze dino's: onthoud dat dino's de wereld 155 miljoen jaren hebben geregeerd! |
|
Dino's en andere anachronismen [ Aanmelden | Ring Overzicht | Willekeurig | << Vorige | Volgende >> ] |
||
Hieronder vindt u het logo van onze sponsor en logos van web-standaarden waaraan deze web-pagina voldoet.
|
|
|
|
||