diff --git a/fortran/src/H5Eff.F90 b/fortran/src/H5Eff.F90 index 666dbe49779..e1c1ff1091b 100644 --- a/fortran/src/H5Eff.F90 +++ b/fortran/src/H5Eff.F90 @@ -34,8 +34,7 @@ ! to the Windows dll file 'hdf5_fortrandll.def.in' in the fortran/src directory. ! This is needed for Windows based operating systems. ! -! MISSING: H5Eauto_is_v2, H5Eclose_stack, H5Ecreate_stack -! H5Eget_auto2, H5Eget_current_stack, H5Epop, H5Eset_current_stack +! MISSING: H5Eauto_is_v2, H5Eget_auto2 MODULE H5E @@ -707,10 +706,11 @@ SUBROUTINE H5Eget_class_name_f(class_id, name, hdferr, size) INTERFACE INTEGER(SIZE_T) FUNCTION H5Eget_class_name(class_id, name, size) & BIND(C,NAME='H5Eget_class_name') - IMPORT :: C_PTR + IMPORT :: C_PTR, C_CHAR IMPORT :: HID_T, SIZE_T IMPLICIT NONE INTEGER(HID_T) , VALUE :: class_id + ! CHARACTER(KIND=C_CHAR,LEN=1), DIMENSION(*) :: name TYPE(C_PTR) , VALUE :: name INTEGER(SIZE_T), VALUE :: size END FUNCTION H5Eget_class_name @@ -732,16 +732,19 @@ END FUNCTION H5Eget_class_name IF(name_cp_sz.EQ.0) name_cp_sz = LEN(name) - ALLOCATE(c_name(1:name_cp_sz+1), stat=hdferr) + ALLOCATE(c_name(1:name_cp_sz+2), stat=hdferr) IF (hdferr .NE. 0) THEN hdferr = -1 RETURN ENDIF - f_ptr = C_LOC(c_name(1)(1:1)) + f_ptr = C_LOC(c_name) + PRINT*,'lkjdsf',name_cp_sz, name_cp_sz+1_SIZE_T c_size = H5Eget_class_name(class_id, f_ptr, name_cp_sz+1) - - CALL HD5c2fstring(name, c_name, name_cp_sz, name_cp_sz+1_SIZE_T) - + !c_size = H5Eget_class_name(class_id, c_name, name_cp_sz+2) + PRINT*,c_name + ! CALL HD5c2fstring(name, c_name, name_cp_sz, name_cp_sz+1_SIZE_T) + ! name = "Custom error class" + ! PRINT*,name DEALLOCATE(c_name) IF(PRESENT(size))THEN @@ -786,5 +789,147 @@ END FUNCTION H5Eappend_stack END SUBROUTINE H5Eappend_stack_f +!> +!! \ingroup FH5E +!! +!! \brief Returns a copy of the current error stack. +!! +!! \param err_stack_id Error stack identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eget_current_stack() +!! + SUBROUTINE H5Eget_current_stack_f(err_stack_id, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(OUT) :: err_stack_id + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(HID_T) FUNCTION H5Eget_current_stack() BIND(C, NAME='H5Eget_current_stack') + IMPORT :: HID_T + IMPLICIT NONE + END FUNCTION H5Eget_current_stack + END INTERFACE + + err_stack_id = H5Eget_current_stack() + + hdferr = 0 + IF(err_stack_id.LT.0) hdferr = -1 + + END SUBROUTINE H5Eget_current_stack_f + +!> +!! \ingroup FH5E +!! +!! \brief Replaces the current error stack. +!! +!! \param err_stack_id Error stack identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eset_current_stack() +!! + SUBROUTINE H5Eset_current_stack_f(err_stack_id, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN ) :: err_stack_id + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Eset_current_stack(err_stack_id) BIND(C, NAME='H5Eset_current_stack') + IMPORT :: C_INT, HID_T + IMPLICIT NONE + INTEGER(HID_T), VALUE :: err_stack_id + END FUNCTION H5Eset_current_stack + END INTERFACE + + hdferr = INT(H5Eset_current_stack(err_stack_id)) + + END SUBROUTINE H5Eset_current_stack_f + +!> +!! \ingroup FH5E +!! +!! \brief Closes an error stack handle. +!! +!! \param err_stack_id Error stack identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eclose_stack() +!! + SUBROUTINE H5Eclose_stack_f(err_stack_id, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN ) :: err_stack_id + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Eclose_stack(err_stack_id) BIND(C, NAME='H5Eclose_stack') + IMPORT :: C_INT, HID_T + IMPLICIT NONE + INTEGER(HID_T), VALUE :: err_stack_id + END FUNCTION H5Eclose_stack + END INTERFACE + + hdferr = INT(H5Eclose_stack(err_stack_id)) + + END SUBROUTINE H5Eclose_stack_f + +!> +!! \ingroup FH5E +!! +!! \brief Creates a new, empty error stack. +!! +!! \param err_stack_id Error stack identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Ecreate_stack() +!! + SUBROUTINE H5Ecreate_stack_f(err_stack_id, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(OUT) :: err_stack_id + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(HID_T) FUNCTION H5Ecreate_stack() BIND(C, NAME='H5Ecreate_stack') + IMPORT :: HID_T + IMPLICIT NONE + END FUNCTION H5Ecreate_stack + END INTERFACE + + err_stack_id = H5Ecreate_stack() + + hdferr = 0 + IF(err_stack_id.LT.0) hdferr = -1 + + END SUBROUTINE H5Ecreate_stack_f + +!> +!! \ingroup FH5E +!! +!! \brief Deletes specified number of error messages from the error stack. +!! +!! \param err_stack_id Error stack identifier +!! \param count The number of error messages to be deleted from the top of error stack +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Epop() +!! + SUBROUTINE H5Epop_f(err_stack_id, count, hdferr) + IMPLICIT NONE + INTEGER(HID_T) , INTENT(IN ) :: err_stack_id + INTEGER(SIZE_T), INTENT(IN ) :: count + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Epop(err_stack_id, count) BIND(C, NAME='H5Epop') + IMPORT :: C_INT, HID_T, SIZE_T + IMPLICIT NONE + INTEGER(HID_T) , VALUE :: err_stack_id + INTEGER(SIZE_T), VALUE :: count + END FUNCTION H5Epop + END INTERFACE + + hdferr = INT(H5Epop(err_stack_id, count)) + + END SUBROUTINE H5Epop_f + END MODULE H5E diff --git a/fortran/src/hdf5_fortrandll.def.in b/fortran/src/hdf5_fortrandll.def.in index d38f9dd51e1..8a58ca3529e 100644 --- a/fortran/src/hdf5_fortrandll.def.in +++ b/fortran/src/hdf5_fortrandll.def.in @@ -120,6 +120,11 @@ H5E_mp_H5EGET_NUM_F H5E_mp_H5EWALK_F H5E_mp_H5EGET_CLASS_NAME_F H5E_mp_H5EAPPEND_STACK_F +H5E_mp_H5EGET_CURRENT_STACK_F +H5E_mp_H5ESET_CURRENT_STACK_F +H5E_mp_H5ECREATE_STACK_F +H5E_mp_H5ECLOSE_STACK_F +H5E_mp_H5EPOP_F ; H5ES H5ES_mp_H5ESCREATE_F H5ES_mp_H5ESGET_COUNT_F diff --git a/fortran/test/tH5E_F03.F90 b/fortran/test/tH5E_F03.F90 index 1eb195bd2f4..387fec0bbb8 100644 --- a/fortran/test/tH5E_F03.F90 +++ b/fortran/test/tH5E_F03.F90 @@ -308,7 +308,7 @@ SUBROUTINE test_error_stack(total_error) INTEGER :: total_error INTEGER :: error - INTEGER(HID_T) :: cls_id, major, minor + INTEGER(HID_T) :: cls_id, major, minor, estack_id1, estack_id2 CHARACTER(LEN=18), TARGET :: file CHARACTER(LEN=18), TARGET :: func INTEGER , TARGET :: line @@ -427,6 +427,7 @@ SUBROUTINE test_error_stack(total_error) CALL h5eprint_f(error, "H5Etest.txt") CALL check("h5eprint_f", error, total_error) + INQUIRE(file="H5Etest.txt", EXIST=status) IF(.NOT.status)THEN CALL check("h5eprint_f", -1, total_error) @@ -467,17 +468,40 @@ SUBROUTINE test_error_stack(total_error) stderr = "** Print error stack in customized way **"//C_NULL_CHAR ptr4 = C_LOC(stderr(1:1)) func_ptr = C_FUNLOC(custom_print_cb) + +! MSB WHY DOES THIS RESET count to 0? FIX +#if 1 CALL h5ewalk_f(H5P_DEFAULT_F, H5E_WALK_UPWARD_F, func_ptr, ptr4, error) CALL check("h5ewalk_f", error, total_error) + CALL h5eget_num_f(H5P_DEFAULT_F, count, error) + PRINT*,"LJDF2332", count +#endif + + ! Copy error stack, which clears the original + CALL H5Eget_current_stack_f(estack_id1, error) + CALL check("H5Eget_current_stack_f", error, total_error) + + CALL h5eget_num_f(estack_id1, count, error) + CALL check("h5eget_num_f", error, total_error) + CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error) + CALL H5Eclose_msg_f(major, error) CALL check("H5Eclose_msg_f", error, total_error) + CALL H5Eclose_msg_f(minor, error) CALL check("H5Eclose_msg_f", error, total_error) CALL h5eunregister_class_f(cls_id, error) CALL check("H5Eunregister_class_f", error, total_error) + CALL H5Ecreate_stack_f(estack_id2, error) + CALL check("H5Ecreate_stack_f", error, total_error) + + CALL H5Eclose_stack_f(estack_id2, error) + CALL check(" H5Eclose_stack_f", error, total_error) + + END SUBROUTINE test_error_stack END MODULE TH5E_F03