>>SOURCE FORMAT IS FIXED ***************************************************************** * OpenCOBOL demonstration * Author: Brian Tiffin * Date: 26-Jun-2008 * History: * 03-Jul-2008 * Updated to compile warning free according to standards * Purpose: * CBL_ERROR_PROC and CBL_EXIT_PROC call example * CBL_ERROR_PROC installs or removes run-time error procedures * CBL_EXIT_PROC installs or removes exit handlers * Also demonstrates the difference between Run time errors * and raised exceptions. Divide by zero is raises an * exception, it does not cause a run time error. * NB: * Please be advised that this example uses the functional but * now obsolete ENTRY verb. Compiling with -Wall will display * a warning. No warning will occur using -std=MF * Tectonics: cobc -x errorproc.cob identification division. program-id. error_exit_proc. data division. working-storage section. * entry point handlers are procedure addresses 01 install-address usage is procedure-pointer. 01 install-flag pic 9 comp-x value 0. 01 status-code pic s9(9) comp-5. * exit handler address and priority (prio is IGNORED with OC1.1) 01 install-params. 02 exit-addr usage is procedure-pointer. 02 handler-prio pic 999 comp-x. * indexing variable for back scannning error message strings 01 ind pic s9(9) comp-5. * work variable to demonstrate raising exception, not RTE 01 val pic 9. * mocked up error procedure reentrancy control, global level 01 once pic 9 value 0. 88 been-here value 1. * mocked up non-reentrant value 01 global-value pic 99 value 99. * LOCAL-STORAGE SECTION comes into play for ERROR_PROCs that * may themselves cause run-time errors, handling reentry. local-storage section. 01 reenter-value pic 99 value 11. * Linkage section for the error message argument passed to proc * By definition, error messages are 325 alphanumeric linkage section. 01 err-msg pic x(325). * example of OpenCOBOL error and exit procedures procedure division. * Demonstrate problem installing procedure * get address of WRONG handler. NOTE: Invalid address set exit-addr to entry "nogo-proc". * flag: 0 to install, 1 to remove call "CBL_EXIT_PROC" using install-flag install-params returning status-code end-call. * status-code 0 on success, in this case expect error. if status-code not = 0 display "Intentional problem installing EXIT PROC" ", Status: " status-code end-display end-if. * Demonstrate install of an exit handler * get address of exit handler set exit-addr to entry "exit-proc". * flag: 0 to install, 1 to remove call "CBL_EXIT_PROC" using install-flag install-params returning status-code end-call. * status-code 0 on success. if status-code not = 0 display "Problem installing EXIT PROC" ", Status: " status-code end-display stop run end-if. * Demonstrate installation of an error procedure * get the procedure entry address set install-address to entry "err-proc". * install error procedure. install-flag 0 installs, 1 removes call "CBL_ERROR_PROC" using install-flag install-address returning status-code end-call. * status-code is 0 on success. if status-code not = 0 display "Error installing ERROR PROC" end-display stop run end-if. * example of error that raises exception, not a run-time error divide 10 by 0 giving val end-divide. * val will be a junk value, use at own risk divide 10 by 0 giving val on size error display "DIVIDE BY ZERO Exception" end-display end-divide. * intentional run-time error call "erroneous" end-call. *> ** Intentional error ** * won't get here. RTS error handler will stop run display "procedure division, following run-time error" end-display. display "global-value: " global-value ", reenter-value: " reenter-value end-display. exit program. ***************************************************************** ***************************************************************** * Programmer controlled Exit Procedure: entry "exit-proc". display "**Custom EXIT HANDLER (will pause 3 and 0.5 seconds)**" end-display. * sleep for 3 seconds call "C$SLEEP" using "3" end-call. * demonstrate nanosleep; argument in billionth's of seconds * Note: also demonstrates OpenCOBOL's compile time * string catenation using ampersand; * 500 million being one half second call "CBL_OC_NANOSLEEP" using "500" & "000000" end-call. exit program. ***************************************************************** * Programmer controlled Error Procedure: entry "err-proc" using err-msg. display "**ENTER error procedure**" end-display. * These lines are to demonstrate local and working storage display "global-value: " global-value ", reenter-value: " reenter-value end-display. * As reenter-value is local-storage * the 77 will NOT display on rentry, while the global 66 will move 66 to global-value. move 77 to reenter-value. * Process err-msg. * Determine Length of error message, looking for null terminator perform varying ind from 1 by 1 until (err-msg(ind:1) = x"00") or (ind = length of err-msg) continue end-perform. display err-msg(1:ind) end-display. * demonstrate trapping an error caused in error-proc if not been-here then set been-here to true display "Cause error while inside error-proc" end-display call "very-erroneous" end-call *> Intentional error end-if. * In OpenCOBOL 1.1, the return-code is local and does * not influence further error handlers *move 1 to return-code. move 0 to return-code. display "**error procedure EXIT**" end-display. exit program.