C Copyright © Oracle Corporation 1995. All Rights Reserved. PROGRAM DEPTFOR C---------------------------------------------------------- C This program stores a new department and modifies the C current job history department codes of employees who C have been moved to the new department. It then calls C a subfunction to print out the supervisory ladder C of each employee in the new department. C---------------------------------------------------------- IMPLICIT NONE INCLUDE '($FORIOSDEF)' INTEGER*4 OK !success/failure flag INTEGER*4 EMP !index for EMP_ID array INTEGER*4 IOERR !value returned by IOSTAT INTEGER*4 ARG_NUM !number of arguments to pass to function INTEGER*4 INTERP0 !function to call RDB$INTERPRET with 0 arguments INTEGER*4 INTERPN !function to call RDB$INTERPRET with n arguments INTEGER*4 GETSUPER !function to print supervisory ladder CHARACTER*200 RDB_STR !string to hold RDO statements CHARACTER*5 ID !employee id (passed to GETSUPER) CHARACTER*15 LAST_NAME !supervisor's last name CHARACTER*15 ARG_1, ARG_2, ARG_3 !strings to pass arguments CHARACTER*4 NEW_DEPT_CODE !new department code CHARACTER*30 NEW_DEPT_NAME !new department name CHARACTER*5 NEW_MANAG_ID !new department manager id CHARACTER*5 EMP_IDS(20) !new employee id array CHARACTER*140 INBUF !input buffer EQUIVALENCE (INBUF(2:5),NEW_DEPT_CODE) EQUIVALENCE (INBUF(6:35),NEW_DEPT_NAME) EQUIVALENCE (INBUF(36:40),NEW_MANAG_ID) EQUIVALENCE (INBUF(41:41),EMP_IDS(1)) C---------------------------------------------------- C invoke database and start transaction using C function INTERP0, which takes no !val arguments C---------------------------------------------------- PRINT *, 'In MAIN, invoking database' 10 RDB_STR = 'invoke database filename '// X '"RDM$DEMO:personnel"' OK = INTERP0(RDB_STR) IF (OK) 20, 400, 400 C------------------------------------------------------- C call subprogram DEFINNDX to define index dept_code C------------------------------------------------------- 20 CALL DEFINNDX PRINT *, 'Back from DEFINNDX' C--------------------------------------- C call subprogram DEFINCON to define C constraint manag_id_exists C--------------------------------------- 25 CALL DEFINCON PRINT *, 'Back from DEFINCON' C--------------- C open files C--------------- 30 OPEN (UNIT=1, FILE='RDM$DEMO:NEWDEPTS.DAT', 1 STATUS='OLD', ERR=150, IOSTAT=IOERR, RECORDTYPE='FIXED', 2 RECL=140) OPEN (UNIT=2, FILE='RDM$DEMO:DEPTFOR.LST', 1 STATUS='NEW', ERR=250, IOSTAT=IOERR, RECORDTYPE='VARIABLE') OPEN (UNIT=3, FILE='RDM$DEMO:DEPTFOR.ERR', 1 STATUS='NEW', ERR=350, IOSTAT=IOERR, RECORDTYPE='VARIABLE') WRITE (2, 1) !write message to output file WRITE (3, 1) !write message to error file WRITE (5, 1) !write message to terminal GO TO 40 1 FORMAT (' ','Starting DEPTFOR.FOR') 150 IF (IOERR .EQ. FOR$IOS_FILNOTFOU) THEN WRITE (5,*) 1 'Input file RDM$DEMO:NEWDEPTS.DAT not found' ELSE WRITE (5,*) 'Error in open: NEWDEPTS.DAT, code =', IOERR END IF GO TO 1000 250 WRITE (5,*) 'Error in open: DEPTFOR.LST, code =', IOERR GO TO 1000 350 WRITE (5,*) 'Error in open: DEPTFOR.ERR, code =', IOERR GO TO 1000 C--------------------------------------------------- C begin data manipulation using function INTERP0 C--------------------------------------------------- 40 RDB_STR = 'start-transaction read-write reserving '// X 'departments, job-history for exclusive write, '// X 'employees for shared write' OK = INTERP0(RDB_STR) IF (OK) 50, 40, 400 !if deadlock, lock conflict, try again C------------------------------------ C begin processing: read a record C------------------------------------ 50 READ (1, 8, END=82) INBUF WRITE (3, 9) NEW_DEPT_CODE,NEW_DEPT_NAME,NEW_MANAG_ID WRITE (3,11) (EMP_IDS(EMP), EMP=1,20) WRITE (5, 9) NEW_DEPT_CODE,NEW_DEPT_NAME,NEW_MANAG_ID WRITE (5,11) (EMP_IDS(EMP), EMP=1,20) 8 FORMAT (A340) 9 FORMAT (' ',A4,2X,A30,2X,A5) 11 FORMAT (' ',20(A5,X)) C--------------------------------------------- C store a new department using function C INTEPRN which takes 3 !val arguments; if C department exists, INTERPN will return 1 C--------------------------------------------- PRINT *, 'Storing department' 54 RDB_STR = 'store d in departments using '// X 'd.department-code = !val;'// X 'd.department-name = !val;'// X 'd.manager-id = !val end-store' ARG_NUM = 3 OK = INTERPN(RDB_STR, NEW_DEPT_CODE, NEW_DEPT_NAME, X NEW_MANAG_ID, ARG_NUM) IF (OK) 56, 200, 80 !if OK=1 dept exists, go to 80 C--------------------------------------------------------- C modify job_history for each emp in employee id array C using function INTERPN which takes 1 !val argument C--------------------------------------------------------- 56 EMP = 1 C--------------------------------------- C begin DO loop C (do until no more employees in rec) C--------------------------------------- DO WHILE (EMP_IDS(EMP) .NE. ' ') PRINT *, 'In DO loop, starting stream for modify' 58 RDB_STR = 'start-stream emps using e in employees '// X 'cross jh in job-history with jh.job-end missing '// X 'and jh.employee-id = e.employee-id '// X 'and e.employee-id = !val' ARG_NUM = 1 OK = INTERPN(RDB_STR, EMP_IDS(EMP), ARG_2, ARG_3, ARG_NUM) IF (OK) 60, 200, 400 C---------------------------------------- C fetch stream using function INTERP0 C---------------------------------------- 60 RDB_STR = 'fetch emps' OK = INTERP0(RDB_STR) IF (OK) 62, 200, 300 !if OK=1 no record, program error 62 RDB_STR = 'modify jh using '// X 'jh.department-code = !val end-modify' ARG_NUM = 1 OK = INTERPN(RDB_STR, NEW_DEPT_CODE, ARG_2, ARG_3, ARG_NUM) IF (OK) 64, 200, 400 64 RDB_STR = 'end_stream emps' OK = INTERP0(RDB_STR) IF (OK) 66, 200, 400 66 EMP = EMP + 1 C---------------- C end DO loop C---------------- END DO C--------------------------------- C print the supervisory ladder C for everyone in new dept C--------------------------------- PRINT *, 'Printing supervisory ladder' 70 RDB_STR = 'start-stream curr using cj in current-job '// X 'with cj.department-code = !val' ARG_NUM = 1 OK = INTERPN(RDB_STR, NEW_DEPT_CODE, ARG_2, ARG_3, ARG_NUM) IF (OK) 72, 200, 400 C---------------------------------------------- C fetch stream using function INTERP0; when C no more current-job records, close stream C---------------------------------------------- 72 RDB_STR = 'fetch curr' OK = INTERP0(RDB_STR) IF (OK) 74, 200, 78 !if OK=1 no more records, end stream 74 RDB_STR = 'get !val = cj.employee-id;'// X '!val = cj.last-name end-get' ARG_NUM = 2 OK = INTERPN(RDB_STR, ID, LAST_NAME, ARG_3, ARG_NUM) IF (OK) 76, 200, 400 C------------------------------------------------------------ C call function GETSUPER to print out supervisory ladder; C if successful return from GETSUPER, do another fetch C------------------------------------------------------------ 76 WRITE (2, 4) LAST_NAME, NEW_DEPT_NAME 4 FORMAT (' ', 'Supervisors for employee ', X A15 /' ','in department ', A30) OK = GETSUPER(ID) IF (OK) 72, 200, 400 !if OK=-1 do another fetch 78 RDB_STR = 'end_stream curr' OK = INTERP0(RDB_STR) IF (OK) 50, 200, 400 !if OK=-1 all done, get another record 80 WRITE (2, 6) NEW_DEPT_CODE 6 FORMAT (' ','Department ', A4, ' already exists') GO TO 50 !get another record 200 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) CLOSE (1, ERR=450) CLOSE (2, ERR=550) CLOSE (3, ERR=650) GO TO 30 C---------------------------------------------------- C no more records, close file and end transaction C---------------------------------------------------- 82 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) IF (OK) 90, 400, 400 !program error if deadlock, lock conflict C------------------------------------------ C call subroutine DELET to delete index C dept_code, constraint manag_id_exists C------------------------------------------ 90 CALL DELET C----------------------------------- C all done, detach from database C----------------------------------- 98 RDB_STR = 'finish' OK = INTERP0(RDB_STR) IF (OK) 900, 400, 400 !program error if deadlock, lock conflict 300 WRITE (3,*) 'No records found for modify' WRITE (5,*) 'No records found for modify' 400 WRITE (3,*) 'Program error' WRITE (5,*) 'Program error' CLOSE (1, STATUS='KEEP', ERR=450) CLOSE (2, STATUS='DELETE', ERR=550) CLOSE (3, STATUS='PRINT', ERR=650) GO TO 1000 450 WRITE (5,*) 'Error in close: NEWDEPTS.DAT, code =', IOERR GO TO 1000 550 WRITE (5,*) 'Error in close: DEPTFOR.LST, code =', IOERR GO TO 1000 650 WRITE (5,*) 'Error in close: DEPTFOR.ERR, code =', IOERR GO TO 1000 C---------------- C close files C---------------- 900 CLOSE (1, STATUS ='KEEP', ERR=450) CLOSE (2, STATUS ='PRINT', ERR=550) CLOSE (3, STATUS ='DELETE', ERR=650) 1000 STOP 'End of program DEPTFOR.FOR' END C----------------------------------------- C SUBROUTINES AND FUNCTION SUBPROGRAMS C----------------------------------------- SUBROUTINE DEFINNDX C---------------------------------------------------- C This subroutine defines an index on department- C code; the subroutine calls function INTERP0. C---------------------------------------------------- IMPLICIT NONE INTEGER*4 OK !success/failure flag INTEGER*4 INTERP0 !function to call RDB$INTERPRET with 0 arguments CHARACTER*200 RDB_STR !string to hold RDO statements PRINT *, 'In DEFINNDX, starting transaction' 20 RDB_STR = 'start_transaction read_write' OK = INTERP0(RDB_STR) IF (OK) 22, 20, 60 !if deadlock, lock conflict, try again 22 RDB_STR = 'define index dept_code for departments '// X 'duplicates not allowed. department_code. end index.' OK = INTERP0(RDB_STR) IF (OK) 26, 50, 32 !if OK=1 index already defined, return 50 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) IF (OK) 20, 60, 60 60 WRITE (3,*) 'Program error' WRITE (5,*) 'Program error' GO TO 30 26 RDB_STR = 'commit' OK = INTERP0(RDB_STR) IF (OK) 28, 60, 60 28 WRITE (3,*) 'Index successfully defined' WRITE (5,*) 'Index successfully defined' 30 RETURN 32 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) IF (OK) 34, 60, 60 34 RETURN END SUBROUTINE DEFINCON C--------------------------------------------- C This subroutine defines a constraint C that manager id must exist in employees; C the subroutine calls function INTERP0. C--------------------------------------------- IMPLICIT NONE INTEGER*4 OK !success/failure flag INTEGER*4 INTERP0 !function to call RDB$INTERPRET with 0 arguments CHARACTER*200 RDB_STR !string to hold RDO statements PRINT *, 'In DEFINCON, starting transaction' 20 RDB_STR = 'start_transaction read_write' OK = INTERP0(RDB_STR) IF (OK) 24, 20, 60 !if deadlock, lock conflict, try again 24 RDB_STR = 'define constraint manag_id_exists for d in '// X 'departments require any e in employees with '// X 'e.employee_id = d.manager_id check on update.' OK = INTERP0(RDB_STR) IF (OK) 26, 50, 32 !if OK=1 constraint already defined, return 50 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) IF (OK) 20, 60, 60 60 WRITE (3,*) 'Program error' WRITE (5,*) 'Program error' GO TO 30 26 RDB_STR = 'commit' OK = INTERP0(RDB_STR) IF (OK) 28, 60, 60 28 WRITE (3,*) 'Constraint successfully defined' WRITE (5,*) 'Constraint successfully defined' 30 RETURN 32 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) IF (OK) 34, 60, 60 34 RETURN END SUBROUTINE DELET C--------------------------------------------------------- C This subroutine deletes the index on department-code C and the constraint that manager id must exist in C employees; the subroutine calls function INTERP0. C--------------------------------------------------------- IMPLICIT NONE INTEGER*4 OK !success/failure flag INTEGER*4 INTERP0 !function to call RDB$INTERPRET with 0 arguments CHARACTER*200 RDB_STR !string to hold RDO statements 20 RDB_STR = 'start_transaction read_write' OK = INTERP0(RDB_STR) IF (OK) 22, 20, 60 !if deadlock, lock conflict, try again 22 RDB_STR = 'delete index dept_code.' OK = INTERP0(RDB_STR) IF (OK) 24, 50, 60 24 RDB_STR = 'delete constraint manag_id_exists.' OK = INTERP0(RDB_STR) IF (OK) 26, 50, 60 50 RDB_STR = 'rollback' OK = INTERP0(RDB_STR) IF (OK) 20, 60, 60 60 WRITE (3,*) 'Program error' WRITE (5,*) 'Program error' GO TO 28 26 RDB_STR = 'commit' OK = INTERP0(RDB_STR) IF (OK) 28, 60, 60 28 RETURN END INTEGER FUNCTION GETSUPER(ID) C--------------------------------------------------------- C This function returns -1 if successfully completed, C 0 if deadlock or lock conflict occurs, 1 if there is C a program error. C--------------------------------------------------------- IMPLICIT NONE CHARACTER*(*) ID !id passed to function CHARACTER*5 SUPER_ID !supervisor id CHARACTER*5 SAVE_ID !storage for supervisor id CHARACTER*4 SUPER_DEPT !supervisor's department CHARACTER*15 LAST_NAME !supervisor's last name CHARACTER*200 RDB_STR !string to hold RDO statements CHARACTER*15 ARG_1, ARG_2, ARG_3 !strings to pass arguments INTEGER*4 OK !success/failure flag INTEGER*4 ARG_NUM !number of arguments to pass to function INTEGER*4 INTERP0 !function to call RDB$INTERPRET with 0 arguments INTEGER*4 INTERPN !function to call RDB$INTERPRET with n arguments C----------------------------------------- C begin DO loop C (do until save_id is the same as id) C----------------------------------------- 10 DO WHILE (ID .NE. SAVE_ID) SAVE_ID = ID 12 RDB_STR = 'start-stream supers using c in current-job '// X 'cross sc in current-job with c.employee-id = !val '// X 'and c.supervisor-id = sc.employee-id' ARG_NUM = 1 OK = INTERPN(RDB_STR, ID, ARG_2, ARG_3, ARG_NUM) IF (OK) 14, 30, 40 14 RDB_STR = 'fetch supers' OK = INTERP0(RDB_STR) IF (OK) 16, 30, 35 !if OK=1 no record, program error 16 RDB_STR = 'get !val = c.supervisor-id;'// X '!val = sc.last-name;'// X '!val = sc.department-code end-get' ARG_NUM = 3 OK = INTERPN(RDB_STR, SUPER_ID, LAST_NAME, X SUPER_DEPT, ARG_NUM) IF (OK) 18, 30, 40 18 RDB_STR = 'end_stream supers' OK = INTERP0(RDB_STR) IF (OK) 20, 30, 40 C------------------------------------------ C if supervisor doesn't supervise self, C write super's id, name, dept C------------------------------------------ 20 IF (SUPER_ID .NE. ID) THEN WRITE (2, 5) SUPER_ID, LAST_NAME, SUPER_DEPT END IF C-------------------------------- C now get supervisor of super C-------------------------------- ID = SUPER_ID C---------------- C end DO loop C---------------- END DO GO TO 50 30 GETSUPER = 0 !deadlock or lock conflict RETURN 35 WRITE (3,*) 'No records found in GETSUPER' WRITE (5,*) 'No records found in GETSUPER' 40 GETSUPER = 1 !program error RETURN 50 GETSUPER = -1 !function successfully completed RETURN 5 FORMAT (' ',A5,2X,A15,2X,A4) END INTEGER FUNCTION INTERP0(RDO_STR) C------------------------------------------------------------------ C This function calls RDB$INTERPRET with no !val arguments. C It returns -1 if the call was successful, 0 if deadlock or C lock conflict is trapped, 1 if stream eof; if constraint or C index is already defined, the function sets the COMMON flag C FATAL to false, and calls RDB$SIGNAL which will signal to C the condition handler. If there is an unexpected fatal error, C the function sets the COMMON flag FATAL to true and calls C RDB$SIGNAL which will resignal to the condition handler. C------------------------------------------------------------------ IMPLICIT NONE INCLUDE '($SSDEF)' CHARACTER*(*) RDO_STR !RDO string passed to function LOGICAL*2 FATAL !flag to set if unexpected fatal error INTEGER*4 STAT !return status for call to RDB$INTERPRET INTEGER*4 ERR !variable returned by LIB$MATCH_COND INTEGER*4 RDB$INTERPRET !datatype for function RDB$INTERPRET INTEGER*4 LIB$MATCH_COND !datatype for function LIB$MATCH_COND CHARACTER*80 MSG_STR !string to receive error message EXTERNAL HANDLER !condition handler EXTERNAL RDB$SIGNAL EXTERNAL LIB$ESTABLISH EXTERNAL LIB$MATCH_COND EXTERNAL RDB$INTERPRET EXTERNAL LIB$SYS_GETMSG COMMON FATAL !make flag available to function HANDLER C---------------------- C errors to handle: C---------------------- INTEGER*4 RDB$_LOCK_CONFLICT !lock conflict INTEGER*4 RDB$_DEADLOCK !deadlock INTEGER*4 RDO$_INDEXTS !index already defined INTEGER*4 RDO$_CONALREXI !constraint already defined INTEGER*4 RDB$_STREAM_EOF !stream eof EXTERNAL RDB$_LOCK_CONFLICT EXTERNAL RDB$_DEADLOCK EXTERNAL RDO$_INDEXTS EXTERNAL RDO$_CONALREXI EXTERNAL RDB$_STREAM_EOF C------------------------- C begin function logic C------------------------- CALL LIB$ESTABLISH(HANDLER) !establish condition handler STAT = RDB$INTERPRET(%DESCR(RDO_STR)) !call interpreter IF ((STAT .AND. 1) .NE. 0) THEN !call was successful INTERP0 = -1 RETURN !continue main module logic ELSE ERR = LIB$MATCH_COND(%REF(STAT), 1 %LOC(RDB$_LOCK_CONFLICT), 2 %LOC(RDB$_DEADLOCK), 3 %LOC(RDO$_INDEXTS), 4 %LOC(RDO$_CONALREXI), 5 %LOC(RDB$_STREAM_EOF)) END IF GO TO (10,20,30,40,50), ERR !handle expected errors C---------------------------------------------- C LIB$MATCH_COND returns 0, no match found: C set flag so HANDLER won't handle error, C call RDB$SIGNAL to print error and quit. C---------------------------------------------- FATAL = .TRUE. !unexpected fatal error CALL RDB$SIGNAL() 10 INTERP0 = 0 !lock conflict WRITE (3, 1) !write message to error file WRITE (5, 1) !write message to terminal RETURN 20 INTERP0 = 0 !deadlock WRITE (3, 2) !write message to error file WRITE (5, 2) !write message to terminal RETURN C---------------------------------------------------- C LIB$MATCH_COND returns 3, index already C defined: set flag so HANDLER will handle error, C call RDB$SIGNAL to print error and continue. C---------------------------------------------------- 30 FATAL = .FALSE. !index already defined CALL RDB$SIGNAL() !write errors to terminal INTERP0 = 1 !return 1 to DEFINNDX WRITE (3, 3) !write message to error file WRITE (5, 3) !write message to terminal RETURN C---------------------------------------------------- C LIB$MATCH_COND returns 4, constraint already C defined: set flag so HANDLER will handle error, C call RDB$SIGNAL to print error and continue. C---------------------------------------------------- 40 FATAL = .FALSE. !constraint already defined CALL RDB$SIGNAL() !write errors to terminal INTERP0 = 1 !return 1 to DEFINCON WRITE (3, 4) !write message to error file WRITE (5, 4) !write message to terminal RETURN 50 INTERP0 = 1 !stream eof, return 1 to MAIN RETURN 1 FORMAT ('0','Lock conflict, rolling back transaction') 2 FORMAT ('0','Deadlock, rolling back transaction') 3 FORMAT ('0','Nonfatal error, index already defined') 4 FORMAT ('0','Nonfatal error, constraint already defined') END INTEGER*4 FUNCTION INTERPN(RDO_STR, ARG_1, ARG_2, ARG_3, ARG_NUM) C------------------------------------------------------------------ C This function calls RDB$INTERPRET with n !val arguments. It C returns -1 if the call was successful, 0 if DEADLOCK deadlock C or lock conflict, 1 if dept-code already exists. If an un- C expected fatal error is trapped the function calls RDB$SIGNAL C and does NOT handle the error. C------------------------------------------------------------------ IMPLICIT NONE CHARACTER*(*) RDO_STR !RDO string passed to function CHARACTER*(*) ARG_1, ARG_2, ARG_3 !arguments passed to function INTEGER*4 ARG_NUM !number of arguments passed to function INTEGER*4 STAT !return status for call to RDB$INTERPRET INTEGER*4 ERR !variable returned by LIB$MATCH_COND INTEGER*4 RDB$INTERPRET !datatype for function RDB$INTERPRET INTEGER*4 LIB$MATCH_COND !datatype for function LIB$MATCH_COND CHARACTER*80 MSG_STR !string to receive error message EXTERNAL RDB$SIGNAL EXTERNAL LIB$MATCH_COND EXTERNAL RDB$INTERPRET EXTERNAL LIB$SYS_GETMSG C---------------------- C errors to handle: C---------------------- INTEGER*4 RDB$_LOCK_CONFLICT !lock conflict INTEGER*4 RDB$_DEADLOCK !deadlock INTEGER*4 RDB$_NO_DUP !can't store duplicate index INTEGER*4 RDB$_INTEG_FAIL !constraint failed INTEGER*4 RDB$_NO_CUR_REC !no rec in stream INTEGER*4 RDB$_NO_RECORD !rec was deleted INTEGER*4 RDB$_UNRES_REL !unreserved relation INTEGER*4 RDB$_READ_ONLY_VIEW !no updates using views INTEGER*4 RDB$_REQ_NO_TRANS !transaction already ended EXTERNAL RDB$_LOCK_CONFLICT EXTERNAL RDB$_DEADLOCK EXTERNAL RDB$_NO_DUP EXTERNAL RDB$_INTEG_FAIL EXTERNAL RDB$_NO_CUR_REC EXTERNAL RDB$_NO_RECORD EXTERNAL RDB$_UNRES_REL EXTERNAL RDB$_READ_ONLY_VIEW EXTERNAL RDB$_REQ_NO_TRANS C------------------------- C begin function logic C------------------------- IF (ARG_NUM .EQ. 1) THEN !call interpreter with 1 argument STAT = RDB$INTERPRET(%DESCR(RDO_STR), 1 %DESCR(ARG_1)) ELSE IF (ARG_NUM .EQ. 2) THEN !call interpreter with 2 arguments STAT = RDB$INTERPRET(%DESCR(RDO_STR), 1 %DESCR(ARG_1), 2 %DESCR(ARG_2)) ELSE IF (ARG_NUM .EQ. 3) THEN !call interpreter with 3 arguments STAT = RDB$INTERPRET(%DESCR(RDO_STR), 1 %DESCR(ARG_1), 2 %DESCR(ARG_2), 3 %DESCR(ARG_3)) ELSE WRITE (3, 1) ARG_NUM !write error message to error file WRITE (5, 1) ARG_NUM !write error message to terminal END IF IF ((STAT .AND. 1) .NE. 0) THEN !call was successful INTERPN = -1 RETURN !continue main module logic ELSE ERR = LIB$MATCH_COND(%REF(STAT), 1 %LOC(RDB$_LOCK_CONFLICT), 2 %LOC(RDB$_DEADLOCK), 3 %LOC(RDB$_NO_DUP), 4 %LOC(RDB$_INTEG_FAIL), 5 %LOC(RDB$_UNRES_REL), 6 %LOC(RDB$_READ_ONLY_VIEW), 7 %LOC(RDB$_NO_CUR_REC), 8 %LOC(RDB$_NO_RECORD), 9 %LOC(RDB$_REQ_NO_TRANS)) END IF GO TO (10,20,30,40,40,40,40,40), ERR !handle expected errors C-------------------------------------- C ERR equals 0, an unexpected error C-------------------------------------- CALL LIB$SYS_GETMSG(%REF(STAT),,%DESCR(MSG_STR)) WRITE (3, 2) MSG_STR !write error message to error file WRITE (5, 3) !write to terminal CALL RDB$SIGNAL() !send errors to terminal and quit 10 INTERPN = 0 !lock conflict WRITE (3, 4) !write message to error file WRITE (5, 4) !write message to terminal RETURN 20 INTERPN = 0 !deadlock WRITE (3, 5) !write message to error file WRITE (5, 5) !write message to terminal RETURN C-------------------------------------------- C ERR equals 3, department already exists C-------------------------------------------- 30 INTERPN = 1 !attempt to store duplicate index RETURN C------------------------------------ C other expected but fatal errors C------------------------------------ 40 CALL LIB$SYS_GETMSG(%REF(STAT),,%DESCR(MSG_STR)) WRITE (3, 6) MSG_STR !write error message to error file WRITE (5, 7) !write message to terminal CALL RDB$SIGNAL() !send errors to terminal and quit 1 FORMAT ('0','Program error, ARG_NUM = ', I6) 2 FORMAT ('0','Unexpected fatal RDB$INTERPRET error, X terminating DEPTFOR.FOR'/ A80) 3 FORMAT ('0','Unexpected fatal RDB$INTERPRET error, X terminating DEPTFOR.FOR') 4 FORMAT ('0','Lock conflict, rolling back transaction') 5 FORMAT ('0','Deadlock, rolling back transaction') 6 FORMAT ('0','Expected fatal RDB$INTERPRET error, X terminating DEPTFOR.FOR'/ A80) 7 FORMAT ('0','Expected fatal RDB$INTERPRET error, X terminating DEPTFOR.FOR') END INTEGER*4 FUNCTION HANDLER(SIGARGS, MECHARGS) IMPLICIT NONE INCLUDE '($SSDEF)' INTEGER*4 SIGARGS(20), MECHARGS(5) LOGICAL*2 FATAL COMMON FATAL EXTERNAL SYS$PUTMSG C------------------------------------------------------ C if error is fatal, set condition code to severe C error and resignal; else print error to terminal, C set severity level to 3 and continue C------------------------------------------------------ PRINT *, 'In HANDLER, evaluate FATAL' 10 IF (FATAL) THEN SIGARGS(2) = JIBCLR(SIGARGS(2), 0) SIGARGS(2) = JIBCLR(SIGARGS(2), 1) SIGARGS(2) = JIBSET(SIGARGS(2), 2) HANDLER = SS$_RESIGNAL ELSE CALL SYS$PUTMSG(SIGARGS) SIGARGS(2) = JIBSET(SIGARGS(2), 0) SIGARGS(2) = JIBSET(SIGARGS(2), 1) SIGARGS(2) = JIBCLR(SIGARGS(2), 2) HANDLER = SS$_CONTINUE END IF RETURN END