From 9d8e8824964af3137b9e4cd400b9b45304fd86ef Mon Sep 17 00:00:00 2001 From: Scot Breitenfeld Date: Thu, 7 Mar 2024 05:34:55 -0600 Subject: Added new H5E with tests. (#4049) Added Fortran H5E APIs: h5eregister_class_f, h5eunregister_class_f, h5ecreate_msg_f, h5eclose_msg_f h5eget_msg_f, h5epush_f, h5eget_num_f, h5ewalk_f, h5eget_class_name_f, h5eappend_stack_f, h5eget_current_stack_f, h5eset_current_stack_f, h5ecreate_stack_f, h5eclose_stack_f, h5epop_f, h5eprint_f (C h5eprint v2 signature) Addresses Issue #3987 --- README.md | 4 +- config/cmake/H5pubconf.h.in | 3 + config/cmake/HDF5UseFortran.cmake | 9 + config/cmake/HDFUseFortran.cmake | 8 + configure.ac | 6 + doxygen/examples/H5E_examples.c | 7 +- fortran/src/CMakeLists.txt | 5 + fortran/src/H5Aff.F90 | 4 +- fortran/src/H5Ef.c | 211 ++------- fortran/src/H5Eff.F90 | 849 +++++++++++++++++++++++++++++++++-- fortran/src/H5Pff.F90 | 4 +- fortran/src/H5VLff.F90 | 2 +- fortran/src/H5config_f.inc.cmake | 3 + fortran/src/H5config_f.inc.in | 3 + fortran/src/H5f90proto.h | 13 +- fortran/src/H5fortkit.F90 | 27 +- fortran/src/Makefile.am | 3 +- fortran/src/hdf5_fortrandll.def.in | 18 +- fortran/test/fortranlib_test_F03.F90 | 13 +- fortran/test/tH5E.F90 | 2 - fortran/test/tH5E_F03.F90 | 440 ++++++++++++++---- fortran/test/tH5I.F90 | 7 +- m4/aclocal_fc.f90 | 4 + m4/aclocal_fc.m4 | 12 + release_docs/RELEASE.txt | 18 +- src/H5Epublic.h | 15 +- 26 files changed, 1354 insertions(+), 336 deletions(-) diff --git a/README.md b/README.md index 9dd7b85..f4bfa69 100644 --- a/README.md +++ b/README.md @@ -16,8 +16,8 @@ HDF5 version 1.15.0 currently under development *Please refer to the release_docs/INSTALL file for installation instructions.* This repository contains a high-performance library's source code and a file format -specification that implement the HDF5® data model. The model has been adopted across -many industries and this implementation has become a de facto data management standard +specification that implements the HDF5® data model. The model has been adopted across +many industries, and this implementation has become a de facto data management standard in science, engineering, and research communities worldwide. The HDF Group is the developer, maintainer, and steward of HDF5 software. Find more diff --git a/config/cmake/H5pubconf.h.in b/config/cmake/H5pubconf.h.in index da53ade..33522a4 100644 --- a/config/cmake/H5pubconf.h.in +++ b/config/cmake/H5pubconf.h.in @@ -68,6 +68,9 @@ /* Define if we have Fortran intrinsic STORAGE_SIZE */ #cmakedefine H5_FORTRAN_HAVE_STORAGE_SIZE @H5_FORTRAN_HAVE_STORAGE_SIZE@ +/* Define if Fortran supports allocatable character */ +#cmakedefine H5_FORTRAN_HAVE_CHAR_ALLOC @H5_FORTRAN_HAVE_CHAR_ALLOC@ + /* Determine the size of C long double */ #cmakedefine H5_FORTRAN_SIZEOF_LONG_DOUBLE @H5_FORTRAN_SIZEOF_LONG_DOUBLE@ diff --git a/config/cmake/HDF5UseFortran.cmake b/config/cmake/HDF5UseFortran.cmake index d34876c..73b4f74 100644 --- a/config/cmake/HDF5UseFortran.cmake +++ b/config/cmake/HDF5UseFortran.cmake @@ -124,6 +124,15 @@ else () message (FATAL_ERROR "Fortran compiler requires either intrinsic functions SIZEOF or STORAGE_SIZE") endif () +# Check to see of Fortran supports allocatable character +READ_SOURCE("PROGRAM PROG_CHAR_ALLOC" "END PROGRAM PROG_CHAR_ALLOC" SOURCE_CODE) +check_fortran_source_compiles (${SOURCE_CODE} FORTRAN_CHAR_ALLOC SRC_EXT f90) +if (${FORTRAN_CHAR_ALLOC}) + set (${HDF_PREFIX}_FORTRAN_HAVE_CHAR_ALLOC 1) +else () + set (${HDF_PREFIX}_FORTRAN_HAVE_CHAR_ALLOC 0) +endif () + #----------------------------------------------------------------------------- # Determine the available KINDs for REALs and INTEGERs #----------------------------------------------------------------------------- diff --git a/config/cmake/HDFUseFortran.cmake b/config/cmake/HDFUseFortran.cmake index 1389aaf..392ea30 100644 --- a/config/cmake/HDFUseFortran.cmake +++ b/config/cmake/HDFUseFortran.cmake @@ -78,6 +78,13 @@ set (STORAGE_SIZE_CODE END PROGRAM " ) +set (CHAR_ALLOC + " + PROGRAM main + CHARACTER(:), ALLOCATABLE :: str + END PROGRAM + " +) set (ISO_FORTRAN_ENV_CODE " PROGRAM main @@ -132,6 +139,7 @@ check_fortran_source_compiles (${STORAGE_SIZE_CODE} ${HDF_PREFIX}_FORTRAN_HAVE_S check_fortran_source_compiles (${ISO_FORTRAN_ENV_CODE} ${HDF_PREFIX}_HAVE_ISO_FORTRAN_ENV SRC_EXT f90) check_fortran_source_compiles (${REALISNOTDOUBLE_CODE} ${HDF_PREFIX}_FORTRAN_DEFAULT_REAL_NOT_DOUBLE SRC_EXT f90) check_fortran_source_compiles (${ISO_C_BINDING_CODE} ${HDF_PREFIX}_FORTRAN_HAVE_ISO_C_BINDING SRC_EXT f90) +check_fortran_source_compiles (${CHAR_ALLOC} ${HDF_PREFIX}_FORTRAN_HAVE_CHAR_ALLOC SRC_EXT f90) #----------------------------------------------------------------------------- # Add debug information (intel Fortran : JB) diff --git a/configure.ac b/configure.ac index f945df5..bb75019 100644 --- a/configure.ac +++ b/configure.ac @@ -652,6 +652,8 @@ if test "X$HDF_FORTRAN" = "Xyes"; then if test "X$HAVE_F2003_REQUIREMENTS" = "Xno"; then AC_MSG_ERROR([Fortran compiler lacks required Fortran 2003 features; unsupported Fortran 2003 compiler, remove --enable-fortran]) fi + ## Checking if the compiler supports fortran character being allocatable + PAC_HAVE_CHAR_ALLOC ## -------------------------------------------------------------------- ## Define wrappers for the C compiler to use Fortran function names @@ -741,6 +743,10 @@ if test "X$HDF_FORTRAN" = "Xyes"; then AC_DEFINE([FORTRAN_HAVE_SIZEOF], [1], [Define if we have Fortran intrinsic SIZEOF]) fi + if test "X$HAVE_CHAR_ALLOC_FORTRAN" = "Xyes"; then + AC_DEFINE([FORTRAN_HAVE_CHAR_ALLOC], [1], [Define if Fortran supports allocatable character]) + fi + ## See if C_LONG_DOUBLE is available PAC_PROG_FC_HAVE_C_LONG_DOUBLE diff --git a/doxygen/examples/H5E_examples.c b/doxygen/examples/H5E_examples.c index deea838..bd0ac61 100644 --- a/doxygen/examples/H5E_examples.c +++ b/doxygen/examples/H5E_examples.c @@ -6,6 +6,9 @@ #include #include +#define RESET "\x1b[0m" +#define RED "\x1b[31m" + int main(void) { @@ -34,8 +37,8 @@ main(void) } // push a custom error message onto the default stack - if (H5Epush2(H5E_DEFAULT, __FILE__, __FUNCTION__, __LINE__, cls, major, minor, "Hello, Error!\n") < - 0) { + if (H5Epush2(H5E_DEFAULT, __FILE__, __FUNCTION__, __LINE__, cls, major, minor, "%s Hello, error %s\n", + RED, RESET) < 0) { ret_val = EXIT_FAILURE; goto fail_push; } diff --git a/fortran/src/CMakeLists.txt b/fortran/src/CMakeLists.txt index 4c28046..99644b8 100644 --- a/fortran/src/CMakeLists.txt +++ b/fortran/src/CMakeLists.txt @@ -63,6 +63,11 @@ if (H5_FORTRAN_HAVE_C_SIZEOF) set (CMAKE_H5_FORTRAN_HAVE_C_SIZEOF 1) endif () +set (CMAKE_H5_FORTRAN_HAVE_CHAR_ALLOC 0) +if (H5_FORTRAN_HAVE_CHAR_ALLOC) + set (CMAKE_H5_FORTRAN_HAVE_CHAR_ALLOC 1) +endif () + configure_file (${HDF5_F90_SRC_SOURCE_DIR}/H5config_f.inc.cmake ${HDF5_F90_BINARY_DIR}/H5config_f.inc @ONLY) configure_file (${HDF5_F90_SRC_SOURCE_DIR}/H5fort_type_defines.h.cmake ${HDF5_F90_BINARY_DIR}/H5fort_type_defines.h @ONLY) diff --git a/fortran/src/H5Aff.F90 b/fortran/src/H5Aff.F90 index a55773a..c2de985 100644 --- a/fortran/src/H5Aff.F90 +++ b/fortran/src/H5Aff.F90 @@ -591,8 +591,8 @@ CONTAINS INTEGER, INTENT(OUT) :: hdferr INTERFACE - INTEGER FUNCTION H5Aclose(attr_id) BIND(C, NAME='H5Aclose') - IMPORT :: HID_T + INTEGER(C_INT) FUNCTION H5Aclose(attr_id) BIND(C, NAME='H5Aclose') + IMPORT :: HID_T, C_INT IMPLICIT NONE INTEGER(HID_T), INTENT(IN), VALUE :: attr_id END FUNCTION H5Aclose diff --git a/fortran/src/H5Ef.c b/fortran/src/H5Ef.c index 7e3a25f..449c8fa 100644 --- a/fortran/src/H5Ef.c +++ b/fortran/src/H5Ef.c @@ -20,43 +20,15 @@ #include "H5f90.h" #include "H5Eprivate.h" -/****if* H5Ef/h5eclear_c +/****if* H5Ef/h5eprint_c * NAME - * h5eclear_c - * PURPOSE - * Call H5Eclear to clear the error stack for the current thread - * INPUTS - * - * OUTPUTS - * - * RETURNS - * 0 on success, -1 on failure - * SOURCE - */ -int_f -h5eclear_c(hid_t_f *estack_id) -/******/ -{ - int_f ret_value = 0; - - /* - * Call H5Eclear function. - */ - if (H5Eclear2((hid_t)*estack_id) < 0) - HGOTO_DONE(FAIL); - -done: - return ret_value; -} - -/****if* H5Ef/h5eprint_c1 - * NAME - * h5eprint_c1 + * h5eprint_c * PURPOSE * Call H5Eprint to print the error stack in a default manner. * INPUTS - * name - file name - * namelen - length of name + * err_stack - error stack identifier + * name - file name + * namelen - length of name * OUTPUTS * * RETURNS @@ -64,22 +36,24 @@ done: * SOURCE */ int_f -h5eprint_c1(_fcd name, int_f *namelen) +h5eprint_c(hid_t_f *err_stack, _fcd name, size_t_f *namelen) /******/ { FILE *file = NULL; char *c_name = NULL; int_f ret_value = 0; - if (NULL == (c_name = (char *)HD5f2cstring(name, (size_t)*namelen))) - HGOTO_DONE(FAIL); - if (NULL == (file = fopen(c_name, "a"))) - HGOTO_DONE(FAIL); + if (namelen) { + if (NULL == (c_name = (char *)HD5f2cstring(name, (size_t)*namelen))) + HGOTO_DONE(FAIL); + if (NULL == (file = fopen(c_name, "a"))) + HGOTO_DONE(FAIL); + } /* * Call H5Eprint2 function. */ - if (H5Eprint2(H5E_DEFAULT, file) < 0) + if (H5Eprint2((hid_t)*err_stack, file) < 0) HGOTO_DONE(FAIL); done: @@ -91,122 +65,6 @@ done: return ret_value; } -/****if* H5Ef/h5eprint_c2 - * NAME - * h5eprint_c2 - * PURPOSE - * Call H5Eprint to print the error stack to stderr - * in a default manner. - * INPUTS - * - * OUTPUTS - * - * RETURNS - * 0 on success, -1 on failure - * SOURCE - */ -int_f -h5eprint_c2(void) -/******/ -{ - int_f ret_value = 0; - - /* - * Call H5Eprint2 function. - */ - if (H5Eprint2(H5E_DEFAULT, NULL) < 0) - HGOTO_DONE(FAIL); - -done: - return ret_value; -} - -/****if* H5Ef/h5eget_major_c - * NAME - * h5eget_major_c - * PURPOSE - * Get a character string describing an error specified by a - * major error number. - * INPUTS - * error_no - Major error number - * OUTPUTS - * name - character string describing the error - * RETURNS - * 0 on success, -1 on failure - * SOURCE - */ -int_f -h5eget_major_c(int_f *error_no, _fcd name, size_t_f *namelen) -/******/ -{ - char *c_name = NULL; - size_t c_namelen = (size_t)*namelen; - int_f ret_value = 0; - - if (c_namelen > 0) - c_name = (char *)malloc(c_namelen + 1); - - if (!c_name) - HGOTO_DONE(FAIL); - - /* - * Call H5Eget_msg function. - */ - H5Eget_msg((hid_t)*error_no, NULL, c_name, c_namelen); - HD5packFstring((char *)c_name, _fcdtocp(name), c_namelen); - if (!strcmp(c_name, "Invalid major error number")) - HGOTO_DONE(FAIL); - -done: - if (c_name) - free(c_name); - - return ret_value; -} - -/****if* H5Ef/h5eget_minor_c - * NAME - * h5eget_minor_c - * PURPOSE - * Get a character string describing an error specified by a - * minor error number. - * INPUTS - * error_no - Major error number - * OUTPUTS - * name - character string describing the error - * RETURNS - * 0 on success, -1 on failure - * SOURCE - */ -int_f -h5eget_minor_c(int_f *error_no, _fcd name, size_t_f *namelen) -/******/ -{ - char *c_name = NULL; - size_t c_namelen = (size_t)*namelen; - int_f ret_value = 0; - - if (c_namelen > 0) - c_name = (char *)malloc(c_namelen + 1); - - if (!c_name) - HGOTO_DONE(FAIL); - - /* - * Call H5Eget_msg function. - */ - H5Eget_msg((hid_t)*error_no, NULL, c_name, c_namelen); - HD5packFstring((char *)c_name, _fcdtocp(name), c_namelen); - if (!strcmp(c_name, "Invalid minor error number")) - HGOTO_DONE(FAIL); - -done: - if (c_name) - free(c_name); - - return ret_value; -} - /****if* H5Ef/h5eset_auto2_c * NAME * h5eset_auto2_c @@ -221,18 +79,6 @@ done: * 0 on success, -1 on failure * SOURCE */ -/* int_f */ -/* h5eset_auto2_c(hid_t_f *estack_id, H5E_auto2_t *func, void *client_data) */ -/* /\******\/ */ -/* { */ -/* int ret_val = -1; */ -/* herr_t status = -1; */ - -/* status = H5Eset_auto2((hid_t)*estack_id, *func, client_data); */ -/* if (status >= 0) ret_val = 0; */ -/* return ret_val; */ -/* } */ - int_f h5eset_auto2_c(int_f *printflag, hid_t_f *estack_id, H5E_auto2_t func, void *client_data) /******/ @@ -251,3 +97,34 @@ h5eset_auto2_c(int_f *printflag, hid_t_f *estack_id, H5E_auto2_t func, void *cli return ret_val; } + +int_f +h5epush_c(hid_t_f *err_stack, hid_t_f *cls_id, hid_t_f *maj_id, hid_t_f *min_id, _fcd msg, size_t_f *msg_len, + char *file, char *func, int *line, const char *arg1, const char *arg2, const char *arg3, + const char *arg4, const char *arg5, const char *arg6, const char *arg7, const char *arg8, + const char *arg9, const char *arg10, const char *arg11, const char *arg12, const char *arg13, + const char *arg14, const char *arg15, const char *arg16, const char *arg17, const char *arg18, + const char *arg19, const char *arg20) +/******/ +{ + + char *c_msg = NULL; /* Buffer to hold C string */ + int_f ret_value = 0; /* Return value */ + + /* + * Convert FORTRAN name to C name + */ + + if (NULL == (c_msg = HD5f2cstring(msg, (size_t)*msg_len))) + HGOTO_DONE(FAIL); + + if (H5Epush2((hid_t)*err_stack, file, func, (unsigned int)*line, (hid_t)*cls_id, (hid_t)*maj_id, + (hid_t)*min_id, c_msg, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, + arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19, arg20) < 0) + HGOTO_DONE(FAIL); + +done: + if (c_msg) + free(c_msg); + return ret_value; +} diff --git a/fortran/src/H5Eff.F90 b/fortran/src/H5Eff.F90 index 4ef18c1..c519ddc 100644 --- a/fortran/src/H5Eff.F90 +++ b/fortran/src/H5Eff.F90 @@ -34,15 +34,43 @@ ! 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, H5Eget_auto2 MODULE H5E USE H5GLOBAL + USE H5fortkit IMPLICIT NONE INTEGER, PARAMETER :: PRINTON = 1 !< Turn on automatic printing of errors INTEGER, PARAMETER :: PRINTOFF = 0 !< Turn off automatic printing of errors +!> @brief h5e_error_t derived type + TYPE, BIND(C) :: h5e_error_t + INTEGER(HID_T) :: cls_id !< Class ID + INTEGER(HID_T) :: maj_num !< Major error ID + INTEGER(HID_T) :: min_num !< Minor error number + INTEGER(C_INT) :: line !< Line in file where error occurs + TYPE(C_PTR) :: func_name !< Function in which error occurred + TYPE(C_PTR) :: file_name !< File in which error occurred + TYPE(C_PTR) :: desc !< Optional supplied description + END TYPE h5e_error_t + + INTERFACE h5eprint_f + MODULE PROCEDURE h5eprint1_f + MODULE PROCEDURE h5eprint2_f + END INTERFACE h5eprint_f + + INTERFACE + INTEGER FUNCTION h5eprint_c(err_stack, name, namelen) BIND(C,NAME='h5eprint_c') + IMPORT :: C_CHAR, HID_T, C_PTR + IMPLICIT NONE + INTEGER(HID_T) :: err_stack + CHARACTER(KIND=C_CHAR), DIMENSION(*) :: name + TYPE(C_PTR), VALUE :: namelen + END FUNCTION h5eprint_c + END INTERFACE + CONTAINS !> @@ -62,19 +90,20 @@ CONTAINS INTEGER(HID_T) :: estack_id_default INTERFACE - INTEGER FUNCTION h5eclear_c(estack_id_default) BIND(C,NAME='h5eclear_c') - IMPORT :: HID_T + INTEGER(C_INT) FUNCTION H5Eclear(err_stack) BIND(C,NAME='H5Eclear2') + IMPORT :: C_INT, HID_T IMPLICIT NONE - INTEGER(HID_T) :: estack_id_default - END FUNCTION h5eclear_c + INTEGER(HID_T), VALUE :: err_stack + END FUNCTION H5Eclear END INTERFACE estack_id_default = H5E_DEFAULT_F IF(PRESENT(estack_id)) estack_id_default = estack_id - hdferr = h5eclear_c(estack_id_default) + hdferr = INT(H5Eclear(estack_id_default)) END SUBROUTINE h5eclear_f +#ifdef H5_DOXYGEN !> !! \ingroup FH5E !! @@ -83,34 +112,66 @@ CONTAINS !! \param hdferr \fortran_error !! \param name Name of the file that contains print output !! -!! See C API: @ref H5Eprint2() +!! \note If \p name is not specified, the output will be sent to +!! the standard error (stderr). +!! +!! \attention Deprecated. +!! +!! See C API: @ref H5Eprint1() !! SUBROUTINE h5eprint_f(hdferr, name) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name INTEGER, INTENT(OUT) :: hdferr - INTEGER :: namelen + END SUBROUTINE h5eprint_f - INTERFACE - INTEGER FUNCTION h5eprint_c1(name, namelen) BIND(C,NAME='h5eprint_c1') - IMPORT :: C_CHAR - IMPLICIT NONE - INTEGER :: namelen - CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(IN) :: name - END FUNCTION h5eprint_c1 - END INTERFACE +!! \ingroup FH5E +!! +!! \brief Prints the error stack in a default manner. +!! +!! \param err_stack Error stack identifier +!! \param hdferr \fortran_error +!! \param name Name of the file that contains print output +!! +!! \note If \p name is not specified, the output will be sent to +!! the standard error (stderr). +!! +!! See C API: @ref H5Eprint2() +!! + SUBROUTINE h5eprint_f(err_stack, hdferr, name) + INTEGER(HID_T) , INTENT(IN) :: err_stack + INTEGER , INTENT(OUT) :: hdferr + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name + END SUBROUTINE h5eprint_f - INTERFACE - INTEGER FUNCTION h5eprint_c2() BIND(C,NAME='h5eprint_c2') - END FUNCTION h5eprint_c2 - END INTERFACE +#else + + SUBROUTINE h5eprint1_f(hdferr, name) + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name + INTEGER, INTENT(OUT) :: hdferr + + CALL h5eprint2_f(H5E_DEFAULT_F, hdferr, name) + + END SUBROUTINE h5eprint1_f + + SUBROUTINE h5eprint2_f(err_stack, hdferr, name) + INTEGER(HID_T), INTENT(IN) :: err_stack + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name + INTEGER, INTENT(OUT) :: hdferr + + INTEGER(SIZE_T), TARGET :: namelen + TYPE(C_PTR) :: c_namelen IF (PRESENT(name)) THEN - namelen = LEN(NAME) - hdferr = h5eprint_c1(name, namelen) + namelen = LEN(NAME, SIZE_T) + c_namelen = C_LOC(namelen) + hdferr = h5eprint_c(err_stack, name, c_namelen) ELSE - hdferr = h5eprint_c2() + hdferr = h5eprint_c(err_stack, C_NULL_CHAR, C_NULL_PTR) ENDIF - END SUBROUTINE h5eprint_f + END SUBROUTINE h5eprint2_f + +#endif + !> !! \ingroup FH5E !! @@ -121,25 +182,23 @@ CONTAINS !! \param namelen Number of characters in the name buffer. !! \param hdferr \fortran_error !! +!! \attention Deprecated: use H5Eget_msg_f() instead. +!! !! See C API: @ref H5Eget_major() !! SUBROUTINE h5eget_major_f(error_no, name, namelen, hdferr) - INTEGER, INTENT(IN) :: error_no - CHARACTER(LEN=*), INTENT(OUT) :: name - INTEGER(SIZE_T), INTENT(IN) :: namelen + INTEGER(HID_T) , INTENT(IN) :: error_no + CHARACTER(LEN=*), INTENT(OUT) :: name + INTEGER(SIZE_T) , INTENT(INOUT) :: namelen INTEGER, INTENT(OUT) :: hdferr - INTERFACE - INTEGER FUNCTION h5eget_major_c(error_no, name, namelen) BIND(C,NAME='h5eget_major_c') - IMPORT :: C_CHAR - IMPORT :: SIZE_T - IMPLICIT NONE - INTEGER :: error_no - CHARACTER(KIND=C_CHAR), DIMENSION(*) :: name - INTEGER(SIZE_T), INTENT(IN) :: namelen - END FUNCTION h5eget_major_c - END INTERFACE - hdferr = h5eget_major_c(error_no, name, namelen) + INTEGER :: msg_type + INTEGER(SIZE_T) :: namelen2 + + namelen2 = namelen + + CALL H5Eget_msg_f(error_no, msg_type, name, hdferr, namelen2) + END SUBROUTINE h5eget_major_f !> !! \ingroup FH5E @@ -150,23 +209,20 @@ CONTAINS !! \param name Character string describing the error. !! \param hdferr \fortran_error !! +!! \attention Deprecated: use H5Eget_msg_f() instead. +!! !! See C API: @ref H5Eget_minor() !! SUBROUTINE h5eget_minor_f(error_no, name, hdferr) - INTEGER, INTENT(IN) :: error_no + INTEGER(HID_T) , INTENT(IN) :: error_no CHARACTER(LEN=*), INTENT(OUT) :: name INTEGER, INTENT(OUT) :: hdferr - INTERFACE - INTEGER FUNCTION h5eget_minor_c(error_no, name) BIND(C,NAME='h5eget_minor_c') - IMPORT :: C_CHAR - INTEGER :: error_no - CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(OUT) :: name - END FUNCTION h5eget_minor_c - END INTERFACE - hdferr = h5eget_minor_c(error_no, name) - END SUBROUTINE h5eget_minor_f + INTEGER :: msg_type + CALL H5Eget_msg_f(error_no, msg_type, name, hdferr) + + END SUBROUTINE h5eget_minor_f !> !! \ingroup FH5E !! @@ -214,6 +270,705 @@ CONTAINS hdferr = h5eset_auto2_c(printflag, estack_id_default, func_default, client_data_default) END SUBROUTINE h5eset_auto_f +!> +!! \ingroup FH5E +!! +!! \brief Pushes a new error record onto an error stack. +!! +!! \param err_stack Error stack identifier. If the identifier is H5E_DEFAULT_F, the error +!! record will be pushed to the current stack. +!! \param cls_id Error class identifier +!! \param maj_id Major error identifier +!! \param min_id Minor error identifier +!! \param msg Error description string +!! \param hdferr \fortran_error +!! \param file Name of the file in which the error was detected +!! \param func Name of the function in which the error was detected +!! \param line Line number in the file where the error was detected +!! \param arg1 C style format control strings +!! \param arg2 C style format control strings +!! \param arg3 C style format control strings +!! \param arg4 C style format control strings +!! \param arg5 C style format control strings +!! \param arg6 C style format control strings +!! \param arg7 C style format control strings +!! \param arg8 C style format control strings +!! \param arg9 C style format control strings +!! \param arg10 C style format control strings +!! \param arg11 C style format control strings +!! \param arg12 C style format control strings +!! \param arg13 C style format control strings +!! \param arg14 C style format control strings +!! \param arg15 C style format control strings +!! \param arg16 C style format control strings +!! \param arg17 C style format control strings +!! \param arg18 C style format control strings +!! \param arg19 C style format control strings +!! \param arg20 C style format control strings +!! +!! \note \p arg[1-20] expects C-style format strings, similar to the +!! system and C functions printf() and fprintf(). +!! Furthermore, special characters, such as ANSI escapes, +!! will only be interpreted correctly if the Fortran equivalent +!! is used. For example, to print \p msg "TEXT" in red and has +!! a space after the text would be: +!!

+!! \code +!! (..., "%s TEXT %s"//C_NEW_LINE, hdferr, ..., arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" ) +!! \endcode +!!
Using "\n" instead of C_NEW_LINE will not be interpereted correctly, and similarly, +!! using "\x1B" instead of ACHAR(27) +!! +!! +!! See C API: @ref H5Epush2() +!! + SUBROUTINE h5epush_f(err_stack, cls_id, maj_id, min_id, msg, hdferr, & + file, func, line, & + arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, & + arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19, arg20) + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN) :: err_stack + INTEGER(HID_T), INTENT(IN) :: cls_id + INTEGER(HID_T), INTENT(IN) :: maj_id + INTEGER(HID_T), INTENT(IN) :: min_id + CHARACTER(LEN=*), INTENT(IN) :: msg + INTEGER, INTENT(OUT) :: hdferr + + TYPE(C_PTR), OPTIONAL :: file + TYPE(C_PTR), OPTIONAL :: func + TYPE(C_PTR), OPTIONAL :: line + CHARACTER(LEN=*), OPTIONAL, TARGET :: arg1, arg2, arg3, arg4, arg5, & + arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, & + arg16, arg17, arg18, arg19, arg20 + + TYPE(C_PTR) :: file_def = C_NULL_PTR + TYPE(C_PTR) :: func_def = C_NULL_PTR + TYPE(C_PTR) :: line_def = C_NULL_PTR + TYPE(C_PTR) :: arg1_def = C_NULL_PTR, arg2_def = C_NULL_PTR, & + arg3_def = C_NULL_PTR, arg4_def = C_NULL_PTR, & + arg5_def = C_NULL_PTR, arg6_def = C_NULL_PTR, & + arg7_def = C_NULL_PTR, arg8_def = C_NULL_PTR, & + arg9_def = C_NULL_PTR, arg10_def = C_NULL_PTR, & + arg11_def = C_NULL_PTR, arg12_def = C_NULL_PTR, & + arg13_def = C_NULL_PTR, arg14_def = C_NULL_PTR, & + arg15_def = C_NULL_PTR, arg16_def = C_NULL_PTR, & + arg17_def = C_NULL_PTR, arg18_def = C_NULL_PTR, & + arg19_def = C_NULL_PTR, arg20_def = C_NULL_PTR + + INTERFACE + INTEGER FUNCTION h5epush_c(err_stack, cls_id, maj_id, min_id, msg, msg_len, file, func, line, & + arg1, arg2, arg3, arg4, arg5, & + arg6, arg7, arg8, arg9, arg10, & + arg11, arg12, arg13, arg14, arg15, & + arg16, arg17, arg18, arg19, arg20) BIND(C, NAME='h5epush_c') + + IMPORT :: C_CHAR, C_INT, C_PTR + IMPORT :: HID_T + IMPLICIT NONE + INTEGER(HID_T) :: err_stack + INTEGER(HID_T) :: cls_id + INTEGER(HID_T) :: maj_id + INTEGER(HID_T) :: min_id + CHARACTER(KIND=C_CHAR), DIMENSION(*) :: msg + INTEGER :: msg_len + + TYPE(C_PTR), VALUE :: file + TYPE(C_PTR), VALUE :: func + TYPE(C_PTR), VALUE :: line + TYPE(C_PTR), VALUE :: arg1, arg2, arg3, arg4, & + arg5, arg6, arg7, arg8, & + arg9, arg10, arg11, arg12, & + arg13, arg14, arg15, arg16, & + arg17, arg18, arg19, arg20 + + END FUNCTION h5epush_c + END INTERFACE + + IF (PRESENT(file)) file_def = file + IF (PRESENT(func)) func_def = func + IF (PRESENT(line)) line_def = line + + IF (PRESENT(arg1)) arg1_def = C_LOC(arg1) + IF (PRESENT(arg2)) arg2_def = C_LOC(arg2) + IF (PRESENT(arg3)) arg3_def = C_LOC(arg3) + IF (PRESENT(arg4)) arg4_def = C_LOC(arg4) + IF (PRESENT(arg5)) arg5_def = C_LOC(arg5) + IF (PRESENT(arg6)) arg6_def = C_LOC(arg6) + IF (PRESENT(arg7)) arg7_def = C_LOC(arg7) + IF (PRESENT(arg8)) arg8_def = C_LOC(arg8) + IF (PRESENT(arg9)) arg9_def = C_LOC(arg9) + IF (PRESENT(arg10)) arg10_def = C_LOC(arg10) + IF (PRESENT(arg11)) arg11_def = C_LOC(arg11) + IF (PRESENT(arg12)) arg12_def = C_LOC(arg12) + IF (PRESENT(arg13)) arg13_def = C_LOC(arg13) + IF (PRESENT(arg14)) arg14_def = C_LOC(arg14) + IF (PRESENT(arg15)) arg15_def = C_LOC(arg15) + IF (PRESENT(arg16)) arg16_def = C_LOC(arg16) + IF (PRESENT(arg17)) arg17_def = C_LOC(arg17) + IF (PRESENT(arg18)) arg18_def = C_LOC(arg18) + IF (PRESENT(arg19)) arg19_def = C_LOC(arg19) + IF (PRESENT(arg20)) arg20_def = C_LOC(arg20) + + hdferr = h5epush_c(err_stack, cls_id, maj_id, min_id, msg, LEN(msg), & + file_def, func_def, line_def, & + arg1_def, arg2_def, arg3_def, arg4_def, arg5_def, & + arg6_def, arg7_def, arg8_def, arg9_def, arg10_def, & + arg11_def, arg12_def, arg13_def, arg14_def, arg15_def, & + arg16_def, arg17_def, arg18_def, arg19_def, arg20_def) + + END SUBROUTINE h5epush_f +!> +!! \ingroup FH5E +!! +!! \brief Registers a client library or application program to the HDF5 error API. +!! +!! \param cls_name Name of the error class +!! \param lib_name Name of the client library or application to which the error class belongs +!! \param version Version of the client library or application to which the error class belongs. It can be NULL. +!! \param class_id Class identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eregister_class() +!! + SUBROUTINE h5eregister_class_f(cls_name, lib_name, version, class_id, hdferr) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: cls_name + CHARACTER(LEN=*), INTENT(IN) :: lib_name + CHARACTER(LEN=*), INTENT(IN) :: version + INTEGER(HID_T) , INTENT(OUT) :: class_id + INTEGER, INTENT(OUT) :: hdferr + + CHARACTER(LEN=LEN_TRIM(cls_name)+1,KIND=C_CHAR) :: c_cls_name + CHARACTER(LEN=LEN_TRIM(lib_name)+1,KIND=C_CHAR) :: c_lib_name + CHARACTER(LEN=LEN_TRIM(version)+1,KIND=C_CHAR) :: c_version + INTERFACE + INTEGER(HID_T) FUNCTION H5Eregister_class(cls_name, lib_name, version) & + BIND(C,NAME='H5Eregister_class') + IMPORT :: C_CHAR + IMPORT :: HID_T + IMPLICIT NONE + CHARACTER(KIND=C_CHAR), DIMENSION(*) :: cls_name + CHARACTER(KIND=C_CHAR), DIMENSION(*) :: lib_name + CHARACTER(KIND=C_CHAR), DIMENSION(*) :: version + + END FUNCTION H5Eregister_class + END INTERFACE + + c_cls_name = TRIM(cls_name)//C_NULL_CHAR + c_lib_name = TRIM(lib_name)//C_NULL_CHAR + c_version = TRIM(version)//C_NULL_CHAR + + class_id = H5Eregister_class(c_cls_name, c_lib_name, c_version) + + hdferr = 0 + IF(class_id.LT.0) hdferr = -1 + + END SUBROUTINE h5eregister_class_f +!> +!! \ingroup FH5E +!! +!! \brief Removes an error class. +!! +!! \param class_id Class identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eunregister_class() +!! + SUBROUTINE h5eunregister_class_f(class_id, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN) :: class_id + INTEGER, INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Eunregister_class(class_id) BIND(C, NAME='H5Eunregister_class') + IMPORT :: HID_T, C_INT + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN), VALUE :: class_id + END FUNCTION H5Eunregister_class + END INTERFACE + + hdferr = INT(H5Eunregister_class(class_id)) + + END SUBROUTINE h5eunregister_class_f +!> +!! \ingroup FH5E +!! +!! \brief Adds a major or minor error message to an error class. +!! +!! \param class_id An error class identifier +!! \param msg_type The type of the error message +!! \param msg Error message +!! \param err_id Error identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Ecreate_msg() +!! + SUBROUTINE h5ecreate_msg_f(class_id, msg_type, msg, err_id, hdferr) + IMPLICIT NONE + + INTEGER(HID_T) , INTENT(IN) :: class_id + INTEGER , INTENT(IN) :: msg_type + CHARACTER(LEN=*), INTENT(IN) :: msg + INTEGER(HID_T) , INTENT(OUT) :: err_id + INTEGER, INTENT(OUT) :: hdferr + + CHARACTER(LEN=LEN_TRIM(msg)+1,KIND=C_CHAR) :: c_msg + + INTERFACE + INTEGER(HID_T) FUNCTION H5Ecreate_msg(class_id, msg_type, msg) & + BIND(C,NAME='H5Ecreate_msg') + IMPORT :: C_CHAR, C_INT + IMPORT :: HID_T + IMPLICIT NONE + INTEGER(HID_T), VALUE :: class_id + INTEGER(C_INT), VALUE :: msg_type + CHARACTER(KIND=C_CHAR), DIMENSION(*) :: msg + END FUNCTION H5Ecreate_msg + END INTERFACE + + c_msg = TRIM(msg)//C_NULL_CHAR + + err_id = H5Ecreate_msg(class_id, INT(msg_type, C_INT), c_msg) + + hdferr = 0 + IF(err_id.LT.0) hdferr = -1 + + END SUBROUTINE h5ecreate_msg_f +!> +!! \ingroup FH5E +!! +!! \brief Closes an error message. +!! +!! \param err_id An error message identifier +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eclose_msg() +!! + SUBROUTINE h5eclose_msg_f(err_id, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN) :: err_id + INTEGER, INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Eclose_msg(err_id) BIND(C, NAME='H5Eclose_msg') + IMPORT :: HID_T, C_INT + IMPLICIT NONE + INTEGER(HID_T), VALUE :: err_id + END FUNCTION H5Eclose_msg + END INTERFACE + + hdferr = INT(H5Eclose_msg(err_id)) + + END SUBROUTINE h5eclose_msg_f +!> +!! \ingroup FH5E +!! +!! \brief Retrieves an error message. +!! +!! \param msg_id Error message identifier +!! \param msg_type The type of the error message. Valid values are H5E_MAJOR_F and H5E_MINOR_F. +!! \param msg Error message buffer +!! \param hdferr \fortran_error +!! \param msg_size The length of error message to be returned by this function +!! +!! If \p msg_size is omitted, the API will copy up to the length of \p msg, and it +!! is the application's responsibility to provide a large enough buffer. If \p msg_size +!! is zero, the required buffer size will be returned, and \p msg is not accessed. +!! If \p msg_size is greater than zero, the function will copy up to the length +!! of \p msg_size info \p msg. +!! +!! See C API: @ref H5Eget_msg() +!! + SUBROUTINE H5Eget_msg_f(msg_id, msg_type, msg, hdferr, msg_size) + IMPLICIT NONE + + INTEGER(HID_T) , INTENT(IN) :: msg_id + INTEGER , INTENT(OUT) :: msg_type + CHARACTER(LEN=*) :: msg + INTEGER , INTENT(OUT) :: hdferr + INTEGER(SIZE_T) , INTENT(INOUT), OPTIONAL :: msg_size + + CHARACTER(LEN=1,KIND=C_CHAR), DIMENSION(:), ALLOCATABLE, TARGET :: c_msg + INTEGER(C_INT) :: c_msg_type + TYPE(C_PTR) :: f_ptr + INTEGER(SIZE_T) :: msg_cp_sz + INTEGER(SIZE_T) :: c_msg_size + + INTERFACE + INTEGER(SIZE_T) FUNCTION H5Eget_msg(msg_id, msg_type, msg, size) & + BIND(C,NAME='H5Eget_msg') + IMPORT :: C_CHAR, C_PTR, C_INT + IMPORT :: HID_T, SIZE_T + IMPLICIT NONE + INTEGER(HID_T), VALUE :: msg_id + INTEGER(C_INT) :: msg_type + TYPE(C_PTR) , VALUE :: msg + INTEGER(SIZE_T), VALUE :: size + END FUNCTION H5Eget_msg + END INTERFACE + + hdferr = 0 + msg_cp_sz = 0 + IF(PRESENT(msg_size))THEN + IF(msg_size .EQ. 0)THEN + c_msg_size = H5Eget_msg(msg_id, c_msg_type, C_NULL_PTR, 0_SIZE_T) + + IF(PRESENT(msg_size)) msg_size = c_msg_size + msg_type = INT(c_msg_type) + + IF(c_msg_size.LT.0) hdferr = -1 + RETURN + ELSE + msg_cp_sz = msg_size + ENDIF + ENDIF + + IF(msg_cp_sz.EQ.0) msg_cp_sz = LEN(msg) + + ALLOCATE(c_msg(1:msg_cp_sz+1), stat=hdferr) + IF (hdferr .NE. 0) THEN + hdferr = -1 + RETURN + ENDIF + f_ptr = C_LOC(c_msg(1)(1:1)) + c_msg_size = H5Eget_msg(msg_id, c_msg_type, f_ptr, msg_cp_sz+1) + + CALL HD5c2fstring(msg, c_msg, msg_cp_sz, msg_cp_sz+1_SIZE_T) + + DEALLOCATE(c_msg) + + IF(PRESENT(msg_size))THEN + msg_size = c_msg_size + ENDIF + + msg_type = INT(c_msg_type) + + IF(c_msg_size.LT.0) hdferr = -1 + + END SUBROUTINE H5Eget_msg_f + +!> +!! \ingroup FH5E +!! +!! \brief Retrieves the number of error messages in an error stack. +!! +!! \param error_stack_id An error message identifier +!! \param count Number of error messages in \p err_id +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eget_num() +!! + SUBROUTINE h5eget_num_f(error_stack_id, count, hdferr) + IMPLICIT NONE + INTEGER(HID_T) , INTENT(IN) :: error_stack_id + INTEGER(SIZE_T), INTENT(OUT) :: count + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(SIZE_T) FUNCTION H5Eget_num(error_stack_id) BIND(C, NAME='H5Eget_num') + IMPORT :: HID_T, SIZE_T + IMPLICIT NONE + INTEGER(HID_T), VALUE :: error_stack_id + END FUNCTION H5Eget_num + END INTERFACE + + count = H5Eget_num(error_stack_id) + + hdferr = 0 + IF(count.LT.0) hdferr = -1 + + END SUBROUTINE h5eget_num_f + +!> +!! \ingroup FH5E +!! +!! \brief Walks the specified error stack, calling the specified function. +!! +!! \param err_stack Error stack identifier +!! \param direction Direction in which the error stack is to be walked +!! \param op Function to be called for each error encountered +!! \param op_data Data to be passed to func +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Ewalk2() +!! + SUBROUTINE h5ewalk_f(err_stack, direction, op, op_data, hdferr) + IMPLICIT NONE + INTEGER(HID_T) , INTENT(IN) :: err_stack + INTEGER , INTENT(IN) :: direction + TYPE(C_FUNPTR) , INTENT(IN) :: op + TYPE(C_PTR) , INTENT(INOUT) :: op_data ! Declare INOUT to bypass gfortran 4.8.5 issue + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Ewalk(err_stack, direction, op, op_data) & + BIND(C, NAME='H5Ewalk2') + IMPORT :: HID_T, C_FUNPTR, C_PTR, C_INT + IMPLICIT NONE + INTEGER(HID_T), VALUE :: err_stack + INTEGER(C_INT), VALUE :: direction + TYPE(C_FUNPTR), VALUE :: op + TYPE(C_PTR) , VALUE :: op_data + END FUNCTION H5Ewalk + END INTERFACE + + hdferr = INT(H5Ewalk(err_stack, direction, op, op_data)) + + END SUBROUTINE h5ewalk_f + +!> +!! \ingroup FH5E +!! +!! \brief Retrieves an error message. +!! +!! \param class_id Error class identifier +!! \param name Buffer for the error class name +!! \param hdferr \fortran_error +!! \param size The maximum number of characters of the class name to be returned by this function in \p name. +!! +!! If \p size is omitted, the API will copy up to the length of \p name, and it +!! is the application's responsibility to provide a large enough buffer. If \p size +!! is zero, the required buffer size will be returned, and \p name is not accessed. +!! If \p size is greater than zero, the function will copy up to the length +!! of \p size info \p name. +!! +!! See C API: @ref H5Eget_class_name() +!! + SUBROUTINE H5Eget_class_name_f(class_id, name, hdferr, size) + IMPLICIT NONE + + INTEGER(HID_T) , INTENT(IN) :: class_id + CHARACTER(LEN=*) :: name + INTEGER , INTENT(OUT) :: hdferr + INTEGER(SIZE_T) , INTENT(INOUT), OPTIONAL :: size + + CHARACTER(LEN=1,KIND=C_CHAR), DIMENSION(:), ALLOCATABLE, TARGET :: c_name + TYPE(C_PTR) :: f_ptr + INTEGER(SIZE_T) :: name_cp_sz + INTEGER(SIZE_T) :: c_size + + INTERFACE + INTEGER(SIZE_T) FUNCTION H5Eget_class_name(class_id, name, size) & + BIND(C,NAME='H5Eget_class_name') + IMPORT :: C_PTR, C_CHAR + IMPORT :: HID_T, SIZE_T + IMPLICIT NONE + INTEGER(HID_T) , VALUE :: class_id + TYPE(C_PTR) , VALUE :: name + INTEGER(SIZE_T), VALUE :: size + END FUNCTION H5Eget_class_name + END INTERFACE + + hdferr = 0 + name_cp_sz = 0 + IF(PRESENT(size))THEN + IF(size .EQ. 0)THEN + c_size = H5Eget_class_name(class_id, C_NULL_PTR, 0_SIZE_T) + + IF(PRESENT(size)) size = c_size + IF(c_size.LT.0) hdferr = -1 + RETURN + ELSE + name_cp_sz = size + ENDIF + ENDIF + + IF(name_cp_sz.EQ.0) name_cp_sz = LEN(name) + + ALLOCATE(c_name(1:name_cp_sz+1), stat=hdferr) + IF (hdferr .NE. 0) THEN + hdferr = -1 + RETURN + ENDIF + f_ptr = C_LOC(c_name) + c_size = H5Eget_class_name(class_id, f_ptr, name_cp_sz+1_SIZE_T) + + CALL HD5c2fstring(name, c_name, name_cp_sz, name_cp_sz+1_SIZE_T) + DEALLOCATE(c_name) + + IF(PRESENT(size))THEN + size = c_size + ENDIF + + IF(c_size.LT.0) hdferr = -1 + + END SUBROUTINE H5Eget_class_name_f + +!> +!! \ingroup FH5E +!! +!! \brief Appends one error stack to another, optionally closing the source stack. +!! +!! \param dst_stack_id Error stack identifier +!! \param src_stack_id Error stack identifier +!! \param close_source_stack Flag to indicate whether to close the source stack +!! \param hdferr \fortran_error +!! +!! See C API: @ref H5Eappend_stack() +!! + SUBROUTINE H5Eappend_stack_f(dst_stack_id, src_stack_id, close_source_stack, hdferr) + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN) :: dst_stack_id + INTEGER(HID_T), INTENT(IN) :: src_stack_id + LOGICAL , INTENT(IN) :: close_source_stack + INTEGER , INTENT(OUT) :: hdferr + + INTERFACE + INTEGER(C_INT) FUNCTION H5Eappend_stack(dst_stack_id, src_stack_id, close_source_stack) & + BIND(C, NAME='H5Eappend_stack') + IMPORT :: HID_T, C_BOOL, C_INT + IMPLICIT NONE + INTEGER(HID_T) , VALUE :: dst_stack_id + INTEGER(HID_T) , VALUE :: src_stack_id + LOGICAL(C_BOOL), VALUE :: close_source_stack + END FUNCTION H5Eappend_stack + END INTERFACE + + hdferr = INT(H5Eappend_stack(dst_stack_id, src_stack_id, LOGICAL(close_source_stack, C_BOOL))) + + 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/H5Pff.F90 b/fortran/src/H5Pff.F90 index 90a74f7..516c34b 100644 --- a/fortran/src/H5Pff.F90 +++ b/fortran/src/H5Pff.F90 @@ -6250,7 +6250,7 @@ SUBROUTINE h5pget_virtual_filename_f(dcpl_id, index, name, hdferr, name_len) IF(INT(h5pget_virtual_filename(dcpl_id, index, f_ptr, INT(LEN(name)+1,SIZE_T)), SIZE_T).LT.0)THEN hdferr = -1 ELSE - CALL HD5c2fstring(name,c_name,LEN(name)) + CALL HD5c2fstring(name, c_name, LEN(name,KIND=SIZE_T), LEN(name,KIND=SIZE_T)+1_SIZE_T ) ENDIF ENDIF @@ -6304,7 +6304,7 @@ SUBROUTINE h5pget_virtual_dsetname_f(dcpl_id, index, name, hdferr, name_len) IF(INT(h5pget_virtual_dsetname(dcpl_id, index, f_ptr, INT(LEN(name)+1,SIZE_T)), SIZE_T).LT.0)THEN hdferr = -1 ELSE - CALL HD5c2fstring(name,c_name,LEN(name)) + CALL HD5c2fstring(name, c_name, LEN(name,KIND=SIZE_T), LEN(name,KIND=SIZE_T)+1_SIZE_T ) ENDIF ENDIF diff --git a/fortran/src/H5VLff.F90 b/fortran/src/H5VLff.F90 index 4467a59..66d098b 100644 --- a/fortran/src/H5VLff.F90 +++ b/fortran/src/H5VLff.F90 @@ -343,7 +343,7 @@ CONTAINS IF(INT(H5VLget_connector_name(obj_id, c_name, l), SIZE_T).LT.0)THEN hdferr = H5I_INVALID_HID_F ELSE - CALL HD5c2fstring(name,c_name,LEN(name)) + CALL HD5c2fstring(name, c_name, LEN(name,KIND=SIZE_T), LEN(name,KIND=SIZE_T)+1_SIZE_T ) ENDIF ENDIF diff --git a/fortran/src/H5config_f.inc.cmake b/fortran/src/H5config_f.inc.cmake index 4330ca2..44da2be 100644 --- a/fortran/src/H5config_f.inc.cmake +++ b/fortran/src/H5config_f.inc.cmake @@ -67,6 +67,9 @@ #define H5_FORTRAN_HAVE_C_SIZEOF #endif +! Define if allocatable character is supported +#define H5_FORTRAN_HAVE_CHAR_ALLOC @H5_FORTRAN_HAVE_CHAR_ALLOC@ + ! Define if the intrinsic function C_LONG_DOUBLE exists #define H5_FORTRAN_HAVE_C_LONG_DOUBLE @H5_FORTRAN_HAVE_C_LONG_DOUBLE@ diff --git a/fortran/src/H5config_f.inc.in b/fortran/src/H5config_f.inc.in index 65fd68a..cb2ec18 100644 --- a/fortran/src/H5config_f.inc.in +++ b/fortran/src/H5config_f.inc.in @@ -35,6 +35,9 @@ ! Define if the intrinsic function C_SIZEOF exists #undef FORTRAN_HAVE_C_SIZEOF +! Define if Fortran supports allocatable character +#undef FORTRAN_HAVE_CHAR_ALLOC + ! Define if the intrinsic function C_LONG_DOUBLE exists #undef FORTRAN_HAVE_C_LONG_DOUBLE diff --git a/fortran/src/H5f90proto.h b/fortran/src/H5f90proto.h index 0fe1b20..4bc8c2f 100644 --- a/fortran/src/H5f90proto.h +++ b/fortran/src/H5f90proto.h @@ -553,12 +553,15 @@ H5_FCDLL int_f h5iis_valid_c(hid_t_f *obj_id, int_f *c_valid); * Functions from H5Ef.c */ -H5_FCDLL int_f h5eclear_c(hid_t_f *estack_id); -H5_FCDLL int_f h5eprint_c1(_fcd name, int_f *namelen); -H5_FCDLL int_f h5eprint_c2(void); -H5_FCDLL int_f h5eget_major_c(int_f *error_no, _fcd name, size_t_f *namelen); -H5_FCDLL int_f h5eget_minor_c(int_f *error_no, _fcd name, size_t_f *namelen); +H5_FCDLL int_f h5eprint_c(hid_t_f *err_stack, _fcd name, size_t_f *namelen); H5_FCDLL int_f h5eset_auto2_c(int_f *printflag, hid_t_f *estack_id, H5E_auto2_t func, void *client_data); +H5_FCDLL int_f h5epush_c(hid_t_f *err_stack, hid_t_f *cls_id, hid_t_f *maj_id, hid_t_f *min_id, _fcd msg, + size_t_f *msg_len, char *file, char *func, int *line, const char *arg1, + const char *arg2, const char *arg3, const char *arg4, const char *arg5, + const char *arg6, const char *arg7, const char *arg8, const char *arg9, + const char *arg10, const char *arg11, const char *arg12, const char *arg13, + const char *arg14, const char *arg15, const char *arg16, const char *arg17, + const char *arg18, const char *arg19, const char *arg20); /* * Functions from H5f.c diff --git a/fortran/src/H5fortkit.F90 b/fortran/src/H5fortkit.F90 index b745c22..70d7087 100644 --- a/fortran/src/H5fortkit.F90 +++ b/fortran/src/H5fortkit.F90 @@ -25,6 +25,8 @@ !***** MODULE H5fortkit + USE H5FORTRAN_TYPES, ONLY : SIZE_T + CONTAINS !****if* H5fortkit/HD5c2fstring @@ -32,28 +34,35 @@ CONTAINS ! HD5c2fstring ! INPUTS ! cstring - C string stored as a string array of size 'len' of string size LEN=1 -! len - length of Fortran string +! f_len - length of Fortran string +! c_len - length of C array ! OUTPUT -! fstring - Fortran string array of LEN=1 +! fstring - Fortran string LEN=1 ! PURPOSE -! Copies a Fortran array of strings having a length of one to a fortran string and removes the C Null +! Copies a C array of strings having a length of one to a fortran string and removes the C Null ! terminator. The Null terminator is returned from C when calling the C APIs directly. ! ! The fortran standard does not allow C_LOC to be used on a character string of ! length greater than one, which is why we use the array of characters instead. ! ! SOURCE - SUBROUTINE HD5c2fstring(fstring,cstring,len) + SUBROUTINE HD5c2fstring(fstring,cstring,f_len,c_len) !***** IMPLICIT NONE - INTEGER :: i - INTEGER :: len - CHARACTER(LEN=len) :: fstring - CHARACTER(LEN=1), DIMENSION(1:len) :: cstring + INTEGER(SIZE_T) :: i + INTEGER(SIZE_T) :: f_len + INTEGER(SIZE_T) :: c_len + CHARACTER(*) :: fstring + CHARACTER(LEN=1), DIMENSION(1:c_len) :: cstring + + INTEGER(SIZE_T) :: f_len_max fstring = '' - DO i = 1, len + f_len_max = LEN(fstring, KIND=SIZE_T) + DO i = 1, c_len + IF (i .GT. f_len_max) EXIT + IF (i .GT. f_len) EXIT IF (cstring(i)(1:1)==CHAR(0)) EXIT fstring(i:i) = cstring(i)(1:1) END DO diff --git a/fortran/src/Makefile.am b/fortran/src/Makefile.am index 44561f6..8d8396f 100644 --- a/fortran/src/Makefile.am +++ b/fortran/src/Makefile.am @@ -143,10 +143,11 @@ FORTRAN_API=yes # modules they depend upon are actually made. *sigh* H5f90global.lo: $(srcdir)/H5f90global.F90 H5fortran_types.lo H5_buildiface.lo: $(srcdir)/H5_buildiface.F90 +H5fortkit.lo: $(srcdir)/H5fortkit.F90 H5fortran_types.lo H5_ff.lo: $(srcdir)/H5_ff.F90 H5Fff.lo H5f90global.lo H5Aff.lo: $(srcdir)/H5Aff.F90 H5f90global.lo H5Dff.lo: $(srcdir)/H5Dff.F90 H5f90global.lo H5_ff.lo H5Sff.lo -H5Eff.lo: $(srcdir)/H5Eff.F90 H5f90global.lo +H5Eff.lo: $(srcdir)/H5Eff.F90 H5f90global.lo H5fortkit.lo H5ESff.lo: $(srcdir)/H5ESff.F90 H5f90global.lo H5Fff.lo: $(srcdir)/H5Fff.F90 H5f90global.lo H5Gff.lo: $(srcdir)/H5Gff.F90 H5f90global.lo H5Pff.lo diff --git a/fortran/src/hdf5_fortrandll.def.in b/fortran/src/hdf5_fortrandll.def.in index e29488f..56f54ac 100644 --- a/fortran/src/hdf5_fortrandll.def.in +++ b/fortran/src/hdf5_fortrandll.def.in @@ -106,10 +106,26 @@ H5D_mp_H5DWRITE_CHUNK_F H5D_mp_H5DREAD_CHUNK_F ; H5E H5E_mp_H5ECLEAR_F -H5E_mp_H5EPRINT_F +H5E_mp_H5EPRINT1_F +H5E_mp_H5EPRINT2_F H5E_mp_H5EGET_MAJOR_F H5E_mp_H5EGET_MINOR_F H5E_mp_H5ESET_AUTO_F +H5E_mp_H5EREGISTER_CLASS_F +H5E_mp_H5EUNREGISTER_CLASS_F +H5E_mp_H5ECREATE_MSG_F +H5E_mp_H5ECLOSE_MSG_F +H5E_mp_H5EGET_MSG_F +H5E_mp_H5EPUSH_F +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/fortranlib_test_F03.F90 b/fortran/test/fortranlib_test_F03.F90 index 85ab744..1c38b36 100644 --- a/fortran/test/fortranlib_test_F03.F90 +++ b/fortran/test/fortranlib_test_F03.F90 @@ -55,14 +55,13 @@ PROGRAM fortranlibtest_F03 total_error = total_error + 1 ENDIF - ret_total_error = 0 -! PROBLEMS with C -! CALL test_error(ret_total_error) -! CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error) - WRITE(*,*) ret_total_error = 0 + CALL test_error(ret_total_error) + CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error) + + ret_total_error = 0 CALL test_array_compound_atomic(ret_total_error) CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Datatypes Functionality', total_error) @@ -175,6 +174,10 @@ PROGRAM fortranlibtest_F03 CALL test_obj_info(ret_total_error) CALL write_test_status(ret_total_error, ' Testing object info functions ', total_error) + ret_total_error = 0 + CALL test_error_stack(ret_total_error) + CALL write_test_status(ret_total_error, ' Test error H5E API stack operations', total_error) + ! write(*,*) ! write(*,*) '=========================================' ! write(*,*) 'Testing VDS ' diff --git a/fortran/test/tH5E.F90 b/fortran/test/tH5E.F90 index 0550bc8..5cf7614 100644 --- a/fortran/test/tH5E.F90 +++ b/fortran/test/tH5E.F90 @@ -48,8 +48,6 @@ CONTAINS CHARACTER(LEN=8), PARAMETER :: err_filename = "err_file"! Error output file CHARACTER(LEN=80) :: fix_err_filename - - INTEGER(HID_T) :: file_id ! File identifier INTEGER(HID_T) :: grp_id ! Group identifier INTEGER :: error, tmp_error, err_flag diff --git a/fortran/test/tH5E_F03.F90 b/fortran/test/tH5E_F03.F90 index c2bf74b..f5ed9fb 100644 --- a/fortran/test/tH5E_F03.F90 +++ b/fortran/test/tH5E_F03.F90 @@ -55,40 +55,116 @@ CONTAINS ! estack_id is always passed from C as: H5E_DEFAULT INTEGER(HID_T) :: estack_id + ! data that was registered with H5Eset_auto_f - INTEGER :: data_inout + ! INTEGER :: data_inout ! another option + ! or + TYPE(C_PTR), VALUE :: data_inout - PRINT*, " " - PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, WITH DATA" - PRINT*, " -This message should be written to standard out- " - PRINT*, " Data Values Passed In =", data_inout - PRINT*, " " + INTEGER, POINTER :: iunit - data_inout = 10*data_inout + CALL C_F_POINTER(data_inout, iunit) - my_hdf5_error_handler = 1 ! this is not used by the C routine + ! iunit = data_inout - END FUNCTION my_hdf5_error_handler + WRITE(iunit,'(A)') "H5Eset_auto_f_msg" + WRITE(iunit,'(I0)') iunit - INTEGER FUNCTION my_hdf5_error_handler_nodata(estack_id, data_inout) bind(C) + iunit = 10*iunit - ! This error function handle works with only version 2 error stack - - IMPLICIT NONE + my_hdf5_error_handler = 1 ! this is not used by the C routine - ! estack_id is always passed from C as: H5E_DEFAULT - INTEGER(HID_T) :: estack_id - ! data that was registered with H5Eset_auto_f - TYPE(C_PTR) :: data_inout + END FUNCTION my_hdf5_error_handler - PRINT*, " " - PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, NO DATA" - PRINT*, " -This message should be written to standard out- " - PRINT*, " " + !------------------------------------------------------------------------- + ! Function: custom_print_cb + ! + ! Purpose: Callback function to print error stack in customized way. + ! + !------------------------------------------------------------------------- + ! + INTEGER(C_INT) FUNCTION custom_print_cb(n, err_desc, op_data) BIND(C) - my_hdf5_error_handler_nodata = 1 ! this is not used by the C routine + IMPLICIT NONE - END FUNCTION my_hdf5_error_handler_nodata + INTEGER(SIZE_T), PARAMETER :: MSG_SIZE = 64 + + INTEGER(C_INT) :: n + TYPE(h5e_error_t) :: err_desc + TYPE(C_PTR) :: op_data + + CHARACTER(LEN=MSG_SIZE) :: maj + CHARACTER(LEN=MSG_SIZE) :: minn + CHARACTER(LEN=MSG_SIZE) :: cls + INTEGER(SIZE_T) :: size + INTEGER :: msg_type + + INTEGER :: error + + CALL H5Eget_class_name_f(err_desc%cls_id, cls, error) + IF(error .LT.0)THEN + custom_print_cb = -1 + RETURN + ENDIF + + IF(TRIM(cls).NE."Custom error class")THEN + custom_print_cb = -1 + RETURN + ENDIF + + size = 3 + CALL H5Eget_class_name_f(err_desc%cls_id, cls, error, size) + IF(error .LT.0)THEN + custom_print_cb = -1 + RETURN + ENDIF + IF(TRIM(cls).NE."Cus")THEN + custom_print_cb = -1 + RETURN + ENDIF + + size = 0 + CALL H5Eget_class_name_f(err_desc%cls_id, "", error, size) + IF(error .LT.0)THEN + custom_print_cb = -1 + RETURN + ENDIF + IF(size.NE.18)THEN + custom_print_cb = -1 + RETURN + ENDIF + + size = MSG_SIZE + CALL H5Eget_msg_f(err_desc%maj_num, msg_type, maj, error, size) + IF(error .LT.0)THEN + custom_print_cb = -1 + RETURN + ENDIF + + CALL h5eget_major_f(err_desc%maj_num, maj, size, error) + IF("MAJOR MSG".NE.TRIM(maj))THEN + custom_print_cb = -1 + RETURN + ENDIF + + IF(error .LT. 0)THEN + custom_print_cb = -1 + RETURN + ENDIF + + CALL h5eget_minor_f(err_desc%min_num, minn, error) + IF(error .LT. 0)THEN + custom_print_cb = -1 + RETURN + ENDIF + IF("MIN MSG".NE.TRIM(minn))THEN + custom_print_cb = -1 + RETURN + ENDIF + + custom_print_cb = 0 + + END FUNCTION custom_print_cb END MODULE test_my_hdf5_error_handler @@ -103,30 +179,24 @@ SUBROUTINE test_error(total_error) IMPLICIT NONE - INTEGER(hid_t), PARAMETER :: FAKE_ID = -1 INTEGER :: total_error INTEGER(hid_t) :: file - INTEGER(hid_t) :: dataset, space - INTEGER(hsize_t), DIMENSION(1:2) :: dims INTEGER :: error - INTEGER, DIMENSION(:), POINTER :: ptr_data INTEGER, TARGET :: my_hdf5_error_handler_data + INTEGER, TARGET :: iunit TYPE(C_PTR) :: f_ptr TYPE(C_FUNPTR) :: func + CHARACTER(LEN=180) :: chr180 + INTEGER :: idx - TYPE(C_PTR), TARGET :: f_ptr1 + LOGICAL :: status - INTEGER, DIMENSION(1:1) :: array_shape + ! set the error stack to the customized routine - my_hdf5_error_handler_data = 99 - CALL h5fcreate_f("terror.h5", H5F_ACC_TRUNC_F, file, error) - CALL check("h5fcreate_f", error, total_error) + iunit = 12 + OPEN(iunit, FILE="stderr.txt") - ! Create the data space - dims(1) = 10 - dims(2) = 20 - CALL H5Screate_simple_f(2, dims, space, error) - CALL check("h5screate_simple_f", error, total_error) + my_hdf5_error_handler_data = iunit ! ** SET THE CUSTOMIZED PRINTING OF ERROR STACK ** @@ -136,65 +206,277 @@ SUBROUTINE test_error(total_error) ! set the data sent to the customized routine f_ptr = c_loc(my_hdf5_error_handler_data) - ! turn on automatic printing, and use a custom error routine with input data CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr) + CALL check("H5Eset_auto_f", error, total_error) - ! Create the erring dataset - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) - CALL verify("h5dcreate_f", error, -1, total_error) + CALL h5fopen_f("DOESNOTEXIST", H5F_ACC_RDONLY_F, file, error) + CALL VERIFY("h5fopen_f", error, -1, total_error) -!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(1),10, total_error) -!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(2),20, total_error) + CLOSE(iunit) -!!$ ! Test enabling and disabling default printing -!!$ -!!$ CALL H5Eget_auto_f(H5E_DEFAULT_F, func1, f_ptr1, error) -!!$ CALL verify("H5Eget_auto_f", error, 0, total_error) + OPEN(iunit, FILE="stderr.txt") - ! PRINT*,c_associated(f_ptr1) + READ(iunit,'(A)') chr180 + idx = INDEX(string=chr180,substring="H5Eset_auto_f_msg") + IF(idx.EQ.0) CALL check("H5Eset_auto_f", -1, total_error) + READ(iunit, *) idx + CALL VERIFY("H5Eset_auto_f", idx, iunit, total_error) + CALL VERIFY("H5Eset_auto_f", my_hdf5_error_handler_data, 10*iunit, total_error) - ALLOCATE(ptr_data(1:2)) - ptr_data = 0 - array_shape(1) = 2 - CALL C_F_POINTER(f_ptr1, ptr_data, array_shape) + CLOSE(iunit, STATUS='delete') - ! ptr_data => f_ptr1(1) + CALL H5Eset_auto_f(0, error) + CALL check("H5Eset_auto_f", error, total_error) - ! PRINT*,ptr_data(1) + CALL h5fopen_f("DOESNOTEXIST", H5F_ACC_RDONLY_F, file, error) + CALL VERIFY("h5fopen_f", error, -1, total_error) -!!$ if(old_data != NULL) -!!$ TEST_ERROR; -!!$#ifdef H5_USE_16_API -!!$ if (old_func != (H5E_auto_t)H5Eprint) -!!$ TEST_ERROR; -!!$#else H5_USE_16_API -!!$ if (old_func != (H5E_auto2_t)H5Eprint2) -!!$ TEST_ERROR; -!!$#endif H5_USE_16_API + INQUIRE(file="H5Etest.txt", EXIST=status) + IF(status)THEN + CALL VERIFY("H5Eset_auto_f", error, -1, total_error) + ENDIF +END SUBROUTINE test_error - ! set the customized error handling routine - func = c_funloc(my_hdf5_error_handler_nodata) - ! set the data sent to the customized routine as null - f_ptr = C_NULL_PTR - ! turn on automatic printing, and use a custom error routine with no input data - CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr) +SUBROUTINE test_error_stack(total_error) + + IMPLICIT NONE + + INTEGER :: total_error + INTEGER :: error + INTEGER(HID_T) :: cls_id, major, minor, estack_id, estack_id1, estack_id2 + CHARACTER(LEN=18), TARGET :: file + CHARACTER(LEN=18), TARGET :: func + INTEGER , TARGET :: line + TYPE(C_PTR) :: ptr1, ptr2, ptr3, ptr4 + + INTEGER :: msg_type + CHARACTER(LEN=9) :: maj_mesg = "MAJOR MSG" + CHARACTER(LEN=7) :: min_mesg = "MIN MSG" + !file status + LOGICAL :: status + CHARACTER(LEN=180) :: chr180 + INTEGER :: idx + INTEGER(SIZE_T) :: count + CHARACTER(LEN=64), TARGET :: stderr + TYPE(C_FUNPTR) :: func_ptr + +#ifdef H5_FORTRAN_HAVE_CHAR_ALLOC + CHARACTER(:), ALLOCATABLE :: msg_alloc +#endif + + CHARACTER(LEN=9) :: chr9 + INTEGER(SIZE_T) :: msg_size + + CALL h5eregister_class_f("Custom error class", "H5E_F03", "0.1", cls_id, error) + CALL check("H5Eregister_class_f", error, total_error) + + CALL H5Ecreate_msg_f(cls_id, H5E_MAJOR_F, maj_mesg, major, error) + CALL check("H5Ecreate_msg_f", error, total_error) + CALL H5Ecreate_msg_f(cls_id, H5E_MINOR_F, min_mesg, minor, error) + CALL check("H5Ecreate_msg_f", error, total_error) + + file = "FILE"//C_NULL_CHAR + func = "FUNC"//C_NULL_CHAR + line = 99 + + ptr1 = C_LOC(file) + ptr2 = C_LOC(func) + ptr3 = C_LOC(line) + + CALL h5ecreate_stack_f(estack_id, error) + CALL check("h5ecreate_stack_f", error, total_error) + + ! push a custom error message onto the stack + CALL H5Epush_f(estack_id, cls_id, major, minor, "%s ERROR TEXT %s"//C_NEW_LINE, error, & + ptr1, ptr2, ptr3, & + arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" ) + CALL check("H5Epush_f", error, total_error) + + CALL h5eget_num_f(estack_id, count, error) + CALL check("h5eget_num_f", error, total_error) + CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error) + + msg_size = 0 + CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error) + + ! Check when a shorter buffer length is passed as the msg_size + msg_size = 3 + CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error) + CALL VERIFY("H5Eget_msg_f", TRIM(chr9), maj_mesg(1:3), total_error) + + ! Check when a exact size buffer length is passed as the msg_size + msg_size = 9 + CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error) + CALL VERIFY("H5Eget_msg_f", TRIM(chr9), maj_mesg(1:9), total_error) + + msg_size = 0 + CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error) + + ! Check when a shorter buffer length is passed as the msg_size + msg_size = 3 + CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error) + CALL VERIFY("H5Eget_msg_f", TRIM(chr9), min_mesg(1:3), total_error) + + ! Check when a larger buffer length is passed as the msg_size + msg_size = 9 + CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error) + CALL VERIFY("H5Eget_msg_f", TRIM(chr9), min_mesg(1:7), total_error) + + ! Check with an allocatable character of the exact size +#ifdef H5_FORTRAN_HAVE_CHAR_ALLOC + msg_size = 0 + CALL H5Eget_msg_f(minor, msg_type, "", error, msg_size) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error) + + ALLOCATE(CHARACTER(LEN=msg_size) :: msg_alloc) + CALL H5Eget_msg_f(minor, msg_type, msg_alloc, error) + CALL check("H5Eget_msg_f", error, total_error) + CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error) + CALL VERIFY("H5Eget_msg_f", msg_alloc, min_mesg, total_error) +#endif + + CALL h5eprint_f(H5E_DEFAULT_F, error) + CALL check("h5eprint_f", error, total_error) + CALL h5eprint_f(error) + CALL check("h5eprint_f", error, total_error) + + INQUIRE(file="H5Etest.txt", EXIST=status) + IF(status)THEN + OPEN(UNIT=12, FILE="H5Etest.txt", status='old') + CLOSE(12, STATUS='delete') + ENDIF + + CALL h5eprint_f(estack_id, 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) + ELSE + OPEN(UNIT=12, FILE="H5Etest.txt", status='old') + + READ(12,'(A)') chr180 + idx = INDEX(string=chr180,substring="Custom error class") + IF(idx.EQ.0) CALL check("h5eprint_f1", -1, total_error) + idx = INDEX(string=chr180,substring="H5E_F03") + IF(idx.EQ.0) CALL check("h5eprint_f2", -1, total_error) + idx = INDEX(string=chr180,substring="0.1") + IF(idx.EQ.0) CALL check("h5eprint_f3", -1, total_error) + + READ(12,'(A)') chr180 + idx = INDEX(string=chr180,substring="FILE") + IF(idx.EQ.0) CALL check("h5eprint_f4", -1, total_error) + idx = INDEX(string=chr180,substring="99") + IF(idx.EQ.0) CALL check("h5eprint_f5", -1, total_error) + idx = INDEX(string=chr180,substring="FUNC") + IF(idx.EQ.0) CALL check("h5eprint_f6", -1, total_error) + idx = INDEX(string=chr180,substring="ERROR TEXT") + IF(idx.EQ.0) CALL check("h5eprint_f7", -1, total_error) + + READ(12,'()') + + READ(12,"(A)") chr180 + idx = INDEX(string=chr180,substring=maj_mesg) + IF(idx.EQ.0) CALL check("h5eprint_f", -1, total_error) + + READ(12,"(A)") chr180 + idx = INDEX(string=chr180,substring=min_mesg) + IF(idx.EQ.0) CALL check("h5eprint_f", -1, total_error) + + CLOSE(12, STATUS='delete') + ENDIF + + stderr = "** Print error stack in customized way **"//C_NULL_CHAR + ptr4 = C_LOC(stderr(1:1)) + func_ptr = C_FUNLOC(custom_print_cb) + + CALL h5ewalk_f(estack_id, H5E_WALK_UPWARD_F, func_ptr, ptr4, error) + CALL check("h5ewalk_f", error, total_error) + + CALL h5eget_num_f(estack_id, count, error) + CALL check("h5eget_num_f", error, total_error) + CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error) + + CALL H5Ecreate_stack_f(estack_id2, error) + CALL check("H5Ecreate_stack_f", error, total_error) + + CALL H5Eappend_stack_f(estack_id2, estack_id, .FALSE., error) + CALL check("H5Eappend_stack_f", error, total_error) + + CALL h5eget_num_f(estack_id2, count, error) + CALL check("h5eget_num_f", error, total_error) + CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error) + + ! 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, 0_SIZE_T, total_error) + + CALL H5Eclose_stack_f(estack_id2, error) + CALL check(" H5Eclose_stack_f", error, total_error) + + CALL H5Eclose_stack_f(estack_id, error) + CALL check("H5Eclose_stack_f", error, total_error) + + CALL H5Eclose_stack_f(estack_id1, error) + CALL check("H5Eclose_stack_f", error, total_error) + + CALL h5ecreate_stack_f(estack_id1, error) + CALL check("h5ecreate_stack_f", error, total_error) - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) - CALL verify("h5dcreate_f", error, -1, total_error) + ! push a custom error message onto the stack + CALL H5Epush_f(estack_id1, cls_id, major, minor, "%s ERROR TEXT %s"//C_NEW_LINE, error, & + ptr1, ptr2, ptr3, & + arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" ) + CALL check("H5Epush_f", error, total_error) + CALL H5Eset_current_stack_f(estack_id1, error) ! API will also close estack_id1 + CALL check("H5Eset_current_stack_f", error, total_error) - ! turn on automatic printing with h5eprint_f which prints an error stack in the default manner. + CALL h5eget_num_f(H5E_DEFAULT_F, count, error) + CALL check("h5eget_num_f", error, total_error) + CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error) - ! func = c_funloc(h5eprint_f) - ! CALL H5Eset_auto_f(0, error, H5E_DEFAULT_F, func, C_NULL_PTR) + CALL h5epop_f(H5E_DEFAULT_F, 1_size_t, total_error) + CALL check("h5epop_f", error, total_error) - CALL H5Eset_auto_f(0, error) - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) + CALL h5eget_num_f(H5E_DEFAULT_F, count, error) + CALL check("h5eget_num_f", error, total_error) + CALL VERIFY("h5eget_num_f", count, 0_SIZE_T, total_error) - CALL H5Eset_auto_f(1, error) - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) + CALL H5Eclose_msg_f(major, error) + CALL check("H5Eclose_msg_f", error, total_error) -END SUBROUTINE test_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) + +END SUBROUTINE test_error_stack END MODULE TH5E_F03 diff --git a/fortran/test/tH5I.F90 b/fortran/test/tH5I.F90 index a5fedb9..7d97219 100644 --- a/fortran/test/tH5I.F90 +++ b/fortran/test/tH5I.F90 @@ -308,9 +308,12 @@ CONTAINS ! Clear the error stack from the file close failure CALL h5eset_auto_f(1, error) CALL h5eclear_f(error) + CALL check("h5eclear_f",error,total_error) + CALL h5eclear_f(error, H5P_DEFAULT_F) + CALL check("h5eclear_f",error,total_error) - if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) RETURN END SUBROUTINE identifier_test diff --git a/m4/aclocal_fc.f90 b/m4/aclocal_fc.f90 index d485f77..939988f 100644 --- a/m4/aclocal_fc.f90 +++ b/m4/aclocal_fc.f90 @@ -55,6 +55,10 @@ PROGRAM PROG_FC_HAVE_F2003_REQUIREMENTS ptr = C_LOC(ichr(1:1)) END PROGRAM PROG_FC_HAVE_F2003_REQUIREMENTS +PROGRAM PROG_CHAR_ALLOC + CHARACTER(:), ALLOCATABLE :: str +END PROGRAM PROG_CHAR_ALLOC + !---- START ----- Check to see C_BOOL is different from LOGICAL MODULE l_type_mod USE ISO_C_BINDING diff --git a/m4/aclocal_fc.m4 b/m4/aclocal_fc.m4 index 5e47626..49e5732 100644 --- a/m4/aclocal_fc.m4 +++ b/m4/aclocal_fc.m4 @@ -106,6 +106,18 @@ AC_DEFUN([PAC_PROG_FC_STORAGE_SIZE],[ ]) +dnl See if the fortran compiler supports allocatable character + +AC_DEFUN([PAC_HAVE_CHAR_ALLOC],[ + HAVE_CHAR_ALLOC_FORTRAN="no" + AC_MSG_CHECKING([if Fortran compiler supports allocatable character]) + TEST_SRC="`sed -ne '/PROGRAM PROG_CHAR_ALLOC/,/END PROGRAM PROG_CHAR_ALLOC/p' $srcdir/m4/aclocal_fc.f90`" + AC_LINK_IFELSE([$TEST_SRC], [AC_MSG_RESULT([yes]) + HAVE_CHAR_ALLOC_FORTRAN="yes"], + [AC_MSG_RESULT([no])]) + +]) + dnl Check to see C_LONG_DOUBLE is available AC_DEFUN([PAC_PROG_FC_HAVE_C_LONG_DOUBLE],[ diff --git a/release_docs/RELEASE.txt b/release_docs/RELEASE.txt index 8695b62..f3de90f 100644 --- a/release_docs/RELEASE.txt +++ b/release_docs/RELEASE.txt @@ -406,7 +406,13 @@ New Features Fortran Library: ---------------- - - Add API support for Fortran MPI_F08 module definitions: + - Added Fortran H5E APIs: + h5eregister_class_f, h5eunregister_class_f, h5ecreate_msg_f, h5eclose_msg_f + h5eget_msg_f, h5epush_f, h5eget_num_f, h5ewalk_f, h5eget_class_name_f, + h5eappend_stack_f, h5eget_current_stack_f, h5eset_current_stack_f, h5ecreate_stack_f, + h5eclose_stack_f, h5epop_f, h5eprint_f (C h5eprint v2 signature) + + - Added API support for Fortran MPI_F08 module definitions: Adds support for MPI's MPI_F08 module datatypes: type(MPI_COMM) and type(MPI_INFO) for HDF5 APIs: H5PSET_FAPL_MPIO_F, H5PGET_FAPL_MPIO_F, H5PSET_MPI_PARAMS_F, H5PGET_MPI_PARAMS_F Ref. #3951 @@ -1168,7 +1174,11 @@ Bug Fixes since HDF5-1.14.0 release Fortran API ----------- - - + - Fixed: HDF5 fails to compile with -Werror=lto-type-mismatch + + Removed the use of the offending C stub wrapper. + + Fixes GitHub issue #3987 High-Level Library @@ -1405,6 +1415,10 @@ Known Problems The subsetting option in ph5diff currently will fail and should be avoided. The subsetting option works correctly in serial h5diff. + Flang Fortran compilation will fail (last check version 17) due to not yet + implemented: (1) derived type argument passed by value (H5VLff.F90), + and (2) support for REAL with KIND = 2 in intrinsic SPACING used in testing. + Several tests currently fail on certain platforms: MPI_TEST-t_bigio fails with spectrum-mpi on ppc64le platforms. diff --git a/src/H5Epublic.h b/src/H5Epublic.h index a22c9c6..0d5993e 100644 --- a/src/H5Epublic.h +++ b/src/H5Epublic.h @@ -250,12 +250,12 @@ H5_DLL herr_t H5Eclose_msg(hid_t err_id); * -------------------------------------------------------------------------- * \ingroup H5E * - * \brief Adds a major error message to an error class + * \brief Adds a major or minor error message to an error class * * \param[in] cls An error class identifier * \param[in] msg_type The type of the error message - * \param[in] msg Major error message - * \return \herr_t + * \param[in] msg Error message + * \return An error ID (success), H5I_INVALID_HID (failure) * * \details H5Ecreate_msg() adds an error message to an error class defined by * client library or application program. The error message can be @@ -625,7 +625,7 @@ H5_DLL herr_t H5Eauto_is_v2(hid_t err_stack, unsigned *is_stack); * \brief Retrieves an error message * * \param[in] msg_id Error message identifier - * \param[out] type The type of the error message Valid values are #H5E_MAJOR + * \param[out] type The type of the error message. Valid values are #H5E_MAJOR * and #H5E_MINOR. * \param[out] msg Error message buffer * \param[in] size The length of error message to be returned by this function @@ -651,7 +651,8 @@ H5_DLL ssize_t H5Eget_msg(hid_t msg_id, H5E_type_t *type, char *msg, size_t size * \brief Retrieves the number of error messages in an error stack * * \estack_id{error_stack_id} - * \return Returns a non-negative value on success; otherwise returns a negative value. + * \return Returns number of error messages in an error stack on + * success; otherwise returns a negative value. * * \details H5Eget_num() retrieves the number of error records in the error * stack specified by \p error_stack_id (including major, minor @@ -916,7 +917,7 @@ H5_DLL herr_t H5Ewalk1(H5E_direction_t direction, H5E_walk1_t func, void *client * error number * * \param[in] maj Major error number - * \return \herr_t + * \return Pointer to the message (success), or NULL (failure) * * \deprecated 1.8.0 Function deprecated in this release. * @@ -939,7 +940,7 @@ H5_DLL char *H5Eget_major(H5E_major_t maj); * error number * * \param[in] min Minor error number - * \return \herr_t + * \return Pointer to the message (success), or NULL (failure) * * \deprecated 1.8.0 Function deprecated and return type changed in this release. * -- cgit v0.12