On Fri, Aug 5, 2016 at 9:18 AM, Hardee, Chuck <[email protected] > wrote:
> <snip> > > > Has anyone ever written a single COBOL program which contains an ENTRY > statement for an internal language environment error handler? > If so, can you share with me what you did to make it work? > The code below seems to work (it is also available on github at https://gist.github.com/JohnArchieMckown/d4af397cb47017fac8b4c972daca1864). I just did some minor merging of two separate programs (invoker & handler) into one. I did not "clean up" much of anything to make it nicer / neater. I wasn't going to post this, but I've been castigate on some forum with comments like "not putting code in-line results in more work for others to read and the other site may go away leaving things hanging". === 000100 PROCESS LIB,QUOTE,NAME(ALIAS) 00010000 000200************************************************* 00020000 000300* * 00030000 000400* IBM Language Environment for OS/390 & VM * 00040000 000500* * 00050000 000600* Licensed Materials - Property of IBM * 00060000 000700* * 00070000 000800* 5647-A01 5688-198 * 00080000 000900* (C) Copyright IBM Corp. 1991, 1997 * 00090000 001000* All Rights Reserved * 00100000 001100* * 00110000 001200* US Government Users Restricted Rights - Use, * 00120000 001300* duplication or disclosure restricted by GSA * 00130000 001400* ADP Schedule Contract with IBM Corp. * 00140000 001500* * 00150000 001600************************************************* 00160000 001700*Module/File Name: IGZTHDLR 00170000 001800*********************************************** 00180000 001900** ** 00190000 002000** CBLHDLR - Call CEEHDLR to register a user ** 00200000 002100** condition handler ** 00210000 002200** ** 00220000 002300*********************************************** 00230000 002400 IDENTIFICATION DIVISION. 00240000 002500 PROGRAM-ID. CBLHDLR2. 00250000 002600 DATA DIVISION. 00260000 002700 WORKING-STORAGE SECTION. 00270000 002800 01 ROUTINE PROCEDURE-POINTER. 00280000 002900 01 WS-TOKEN PIC S9(9) BINARY. 00290000 003000 01 SEV PIC S9(4) BINARY. 00300000 003100 01 MSGNO PIC S9(4) BINARY. 00310000 003200 01 CASE PIC S9(4) BINARY. 00320000 003300 01 SEV2 PIC S9(4) BINARY. 00330000 003400 01 CNTRL PIC S9(4) BINARY. 00340000 003500 01 FACID PIC X(3). 00350000 003600 01 ISINFO PIC S9(9) BINARY. 00360000 003700 01 QDATA PIC S9(9) BINARY. 00370000 003800 01 RECOVERY-AREA EXTERNAL. 00380000 003900 05 RECOVERY-POINT POINTER. 00390000 004000 05 ERROR-INDICATOR PIC X . 00400000 004100 88 ERROR-OCCURRED VALUE IS HIGH-VALUES. 00410000 004200 88 NO-ERROR-OCCURRED VALUE IS LOW-VALUES. 00420000 004300 00430000 004400 01 FC-HANDLER. 00440000 004500 02 Condition-Token-Value. 00450000 004600 COPY CEEIGZCT. 00460000 004700 03 Case-1-Condition-ID. 00470000 004800 04 Severity PIC S9(4) BINARY. 00480000 004900 04 Msg-No PIC S9(4) BINARY. 00490000 005000 03 Case-2-Condition-ID 00500000 005100 REDEFINES Case-1-Condition-ID. 00510000 005200 04 Class-Code PIC S9(4) BINARY. 00520000 005300 04 Cause-Code PIC S9(4) BINARY. 00530000 005400 03 Case-Sev-Ctl PIC X. 00540000 005500 03 Facility-ID PIC XXX. 00550000 005600 02 I-S-Info PIC S9(9) BINARY. 00560000 005700 00570000 005800 01 FC. 00580000 005900 02 Condition-Token-Value. 00590000 006000 COPY CEEIGZCT. 00600000 006100 03 Case-1-Condition-ID. 00610000 006200 04 Severity PIC S9(4) BINARY. 00620000 006300 04 Msg-No PIC S9(4) BINARY. 00630000 006400 03 Case-2-Condition-ID 00640000 006500 REDEFINES Case-1-Condition-ID. 00650000 006600 04 Class-Code PIC S9(4) BINARY. 00660000 006700 04 Cause-Code PIC S9(4) BINARY. 00670000 006800 03 Case-Sev-Ctl PIC X. 00680000 006900 03 Facility-ID PIC XXX. 00690000 007000 02 I-S-Info PIC S9(9) BINARY. 00700000 007100 01 CONDTOK. 00710000 007200 02 Condition-Token-Value. 00720000 007300 COPY CEEIGZCT. 00730000 007400 03 Case-1-Condition-ID. 00740000 007500 04 Severity PIC S9(4) BINARY. 00750000 007600 04 Msg-No PIC S9(4) BINARY. 00760000 007700 03 Case-2-Condition-ID 00770000 007800 REDEFINES Case-1-Condition-ID. 00780000 007900 04 Class-Code PIC S9(4) BINARY. 00790000 008000 04 Cause-Code PIC S9(4) BINARY. 00800000 008100 03 Case-Sev-Ctl PIC X. 00810000 008200 03 Facility-ID PIC XXX. 00820000 008300 02 I-S-Info PIC S9(9) BINARY. 00830000 008400 LINKAGE SECTION. 00840000 008500 01 LS-TOKEN PIC S9(9) BINARY. 00850000 008600 01 LS-RESULT PIC S9(9) BINARY. 00860000 008700 88 RESUME VALUE 10. 00870000 008800 01 CURCOND. 00880000 008900 02 Condition-Token-Value. 00890000 009000 COPY CEEIGZCT. 00900000 009100 03 Case-1-Condition-ID. 00910000 009200 04 Severity PIC S9(4) BINARY. 00920000 009300 04 Msg-No PIC S9(4) BINARY. 00930000 009400 03 Case-2-Condition-ID 00940000 009500 REDEFINES Case-1-Condition-ID. 00950000 009600 04 Class-Code PIC S9(4) BINARY. 00960000 009700 04 Cause-Code PIC S9(4) BINARY. 00970000 009800 03 Case-Sev-Ctl PIC X. 00980000 009900 03 Facility-ID PIC XXX. 00990000 010000 02 I-S-Info PIC S9(9) BINARY. 01000000 010100 01 NEWCOND. 01010000 010200 02 Condition-Token-Value. 01020000 010300 COPY CEEIGZCT. 01030000 010400 03 Case-1-Condition-ID. 01040000 010500 04 Severity PIC S9(4) BINARY. 01050000 010600 04 Msg-No PIC S9(4) BINARY. 01060000 010700 03 Case-2-Condition-ID 01070000 010800 REDEFINES Case-1-Condition-ID. 01080000 010900 04 Class-Code PIC S9(4) BINARY. 01090000 011000 04 Cause-Code PIC S9(4) BINARY. 01100000 011100 03 Case-Sev-Ctl PIC X. 01110000 011200 03 Facility-ID PIC XXX. 01120000 011300 02 I-S-Info PIC S9(9) BINARY. 01130000 011400 01140000 011500 PROCEDURE DIVISION. 01150000 011600 PARA-CBLHDLR. 01160000 011700 SET ROUTINE TO ENTRY "HANDLER". 01170000 011800 CALL "CEEHDLR" USING ROUTINE, WS-TOKEN, FC. 01180000 011900 IF NOT CEE000 of FC THEN 01190000 012000 DISPLAY "CEEHDLR failed with msg " 01200000 012100 Msg-No of FC UPON CONSOLE 01210000 012200 STOP RUN 01220000 012300 END-IF. 01230000 012400 01240000 012500* RAISE A SIGNAL 01250000 012600 01260000 012700 PARA-CBLSGL. 01270000 012800************************************************* 01280000 012900** Call CEENCOD with the values assigned above ** 01290000 013000** to build a condition token "CONDTOK" ** 01300000 013100** Set CONDTOK to sev=3, msgno=1 facid=CEE. We ** 01310000 013200** raise a sev 3 to ensure our handler is driven* 01320000 013300************************************************* 01330000 013400 MOVE 3 TO SEV. 01340000 013500 MOVE 1 TO MSGNO. 01350000 013600 MOVE 1 TO CASE. 01360000 013700 MOVE 3 TO SEV2. 01370000 013800 MOVE 1 TO CNTRL. 01380000 013900 MOVE "CEE" TO FACID. 01390000 014000 MOVE 0 TO ISINFO. 01400000 014100 01410000 014200 CALL "CEENCOD" USING SEV, MSGNO, CASE, 01420000 014300 SEV2, CNTRL, FACID, ISINFO, CONDTOK, FC. 01430000 014400 IF NOT CEE000 of FC THEN 01440000 014500 DISPLAY "CEENCOD failed with msg " 01450000 014600 Msg-No of FC UPON CONSOLE 01460000 014700 STOP RUN 01470000 014800 END-IF. 01480000 014900 01490000 015000************************************************* 01500000 015100** Call CEESGL to signal the condition with ** 01510000 015200** the condition token and qdata described ** 01520000 015300** in CONDTOK and QDATA ** 01530000 015400************************************************* 01540000 015500 MOVE 0 TO QDATA. 01550000 015600 CALL "CEESGL" USING CONDTOK, QDATA, FC. 01560000 015700 IF NOT CEE000 of FC THEN 01570000 015800 DISPLAY "CEESGL failed with msg " 01580000 015900 Msg-No of FC UPON CONSOLE 01590000 016000 STOP RUN 01600000 016100 END-IF. 01610000 016200 01620000 016300 GOBACK. 01630000 016400 ENTRY "HANDLER" 01640000 016500 USING CURCOND, LS-TOKEN, LS-RESULT, NEWCOND 01650000 016600 . 01660000 016700* 01670000 016800 01680000 016900 PARA-HANDLER. 01690000 017000 IF RECOVERY-POINT IS NOT EQUAL TO NULL THEN 01700000 017100 SET ERROR-OCCURRED TO TRUE 01710000 017200 CALL "CEEMRCE" USING RECOVERY-POINT, FC-HANDLER 01720000 017300 END-IF 01730000 017400 DISPLAY "Entered user handler for condition" 01740000 017500 " with message number " Msg-No Of CURCOND 01750000 017600 " -- will resume execution" 01760000 017700 SET RESUME TO TRUE 01770000 017800 01780000 017900 GOBACK 01790000 018000 . 01800000 018100 END PROGRAM CBLHDLR2. 01810000 === > Thanks in advance, > Chuck > > Charles (Chuck) Hardee<mailto:[email protected]> > Senior Systems Engineer/Database Administration > EAS Information Technology > > Thermo Fisher Scientific > 300 Industry Drive | Pittsburgh, PA 15275 > Phone +1 (724) 517-2633 | Mobile +1 (412) 877-2809 | FAX: +1 (412) 490-9230 > [email protected]<mailto:[email protected]> | > www.thermofisher.com > > WORLDWIDE CONFIDENTIALITY NOTE: Dissemination, distribution or copying of > this e-mail or the information herein by anyone other than the intended > recipient, or an employee or agent of a system responsible for delivering > the message to the intended recipient, is prohibited. If you are not the > intended recipient, please inform the sender and delete all copies. > > > ---------------------------------------------------------------------- > For IBM-MAIN subscribe / signoff / archive access instructions, > send email to [email protected] with the message: INFO IBM-MAIN > -- Klein bottle for rent -- inquire within. Maranatha! <>< John McKown ---------------------------------------------------------------------- For IBM-MAIN subscribe / signoff / archive access instructions, send email to [email protected] with the message: INFO IBM-MAIN
