From 5a037dbd1fa96857356ea9450dbb279236a4ccbd Mon Sep 17 00:00:00 2001 From: tkoenig Date: Sun, 29 Jul 2007 20:01:45 +0000 Subject: [PATCH] 2007-07-29 Thomas Koenig PR libfortran/32858 PR libfortran/30814 * configure.ac: Added checks for presence of stdio.h and stdarg.h. Test presence of vsnprintf(). * configure: Regenerated. * config.h.in: Regenerated. * libgfortran.h: Include . Add printf attribute to prototype of runtime_error. Remove prototype for st_sprintf. Add prototype for st_vprintf. * runtime/main.c (store_exec_path): Replace st_sprintf by sprintf. * runtime/error.c (st_sprintf): Remove. (runtime_error): Rewrite as a variadic function. Call st_vprintf(). * intrinsics/pack_generic.c: Output extents of LHS and RHS for bounds error. * io/open.c (new_unit): Replace st_sprintf by sprintf. * io/list_read.c (convert_integer): Likewise. (parse_repeat): Likewise. (read_logical): Likewise. (read_character): Likewise. (parse_real): Likewise. (read_real): Likewise. (check_type): Likewise. (nml_parse_qualifyer): Likewise. (nml_read_obj): Likewise. (nml_get_ojb_data): Likewise. * io/unix.c (init_error_stream): Remove. (tempfile): Replace st_sprintf by sprintf. (st_vprintf): New function. (st_printf): Rewrite to call st_vprintf. * io/transfer.c (require_type): Replace st_sprintf by sprintf. * io/format.c (format_error): Likewise. * io/write.c (nml_write_obj): Likewise. 2007-07-29 Thomas Koenig PR libfortran/32858 PR libfortran/30814 * gfortran.dg/pack_bounds_1.f90: Adjust to new error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127049 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/pack_bounds_1.f90 | 4 +- libgfortran/ChangeLog | 36 +++++++ libgfortran/config.h.in | 16 ++++ libgfortran/configure | 52 ++++++----- libgfortran/configure.ac | 4 +- libgfortran/intrinsics/pack_generic.c | 10 +- libgfortran/io/format.c | 2 +- libgfortran/io/list_read.c | 84 ++++++++--------- libgfortran/io/open.c | 8 +- libgfortran/io/transfer.c | 4 +- libgfortran/io/unix.c | 140 ++++++---------------------- libgfortran/io/write.c | 4 +- libgfortran/libgfortran.h | 11 ++- libgfortran/runtime/error.c | 67 ++----------- libgfortran/runtime/main.c | 2 +- 16 files changed, 192 insertions(+), 258 deletions(-) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1954fb0..7d4be5e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-07-29 Thomas Koenig + + PR libfortran/32858 + PR libfortran/30814 + * gfortran.dg/pack_bounds_1.f90: Adjust to new error message. + 2007-07-29 Paul Thomas PR fortran/31211 diff --git a/gcc/testsuite/gfortran.dg/pack_bounds_1.f90 b/gcc/testsuite/gfortran.dg/pack_bounds_1.f90 index 94c8eb0..d1e185c 100644 --- a/gcc/testsuite/gfortran.dg/pack_bounds_1.f90 +++ b/gcc/testsuite/gfortran.dg/pack_bounds_1.f90 @@ -1,10 +1,10 @@ ! { dg-do run } ! { dg-options "-fbounds-check" } -! { dg-shouldfail "Incorrect extent in return value of PACK intrinsic" } +! { dg-shouldfail "Incorrect extent in return value of PACK intrinsic; is 4, should be 5" } ! PR 30814 - a bounds error with pack was not caught. program main integer :: a(2,2), b(5) a = reshape((/ 1, -1, 1, -1 /), shape(a)) b = pack(a, a /= 0) end program main -! { dg-output "Fortran runtime error: Incorrect extent in return value of PACK intrinsic" } +! { dg-output "Fortran runtime error: Incorrect extent in return value of PACK intrinsic; is 4, should be 5" } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 374040d..71f0f01 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,39 @@ +2007-07-29 Thomas Koenig + + PR libfortran/32858 + PR libfortran/30814 + * configure.ac: Added checks for presence of stdio.h and + stdarg.h. Test presence of vsnprintf(). + * configure: Regenerated. + * config.h.in: Regenerated. + * libgfortran.h: Include . Add printf attribute to + prototype of runtime_error. Remove prototype for st_sprintf. + Add prototype for st_vprintf. + * runtime/main.c (store_exec_path): Replace st_sprintf by sprintf. + * runtime/error.c (st_sprintf): Remove. + (runtime_error): Rewrite as a variadic function. Call + st_vprintf(). + * intrinsics/pack_generic.c: Output extents of LHS and RHS for + bounds error. + * io/open.c (new_unit): Replace st_sprintf by sprintf. + * io/list_read.c (convert_integer): Likewise. + (parse_repeat): Likewise. + (read_logical): Likewise. + (read_character): Likewise. + (parse_real): Likewise. + (read_real): Likewise. + (check_type): Likewise. + (nml_parse_qualifyer): Likewise. + (nml_read_obj): Likewise. + (nml_get_ojb_data): Likewise. + * io/unix.c (init_error_stream): Remove. + (tempfile): Replace st_sprintf by sprintf. + (st_vprintf): New function. + (st_printf): Rewrite to call st_vprintf. + * io/transfer.c (require_type): Replace st_sprintf by sprintf. + * io/format.c (format_error): Likewise. + * io/write.c (nml_write_obj): Likewise. + 2007-07-27 Janne Blomqvist * io/transfer.c (st_set_nml_var_dim): Use index_type instead of diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in index 205aca3..0779149 100644 --- a/libgfortran/config.h.in +++ b/libgfortran/config.h.in @@ -270,6 +270,9 @@ /* Define to 1 if you have the `ctime' function. */ #undef HAVE_CTIME +/* Define to 1 if you have the header file. */ +#undef HAVE_DLFCN_H + /* Define to 1 if you have the `dup2' function. */ #undef HAVE_DUP2 @@ -594,9 +597,15 @@ /* Define to 1 if you have the `stat' function. */ #undef HAVE_STAT +/* Define to 1 if you have the header file. */ +#undef HAVE_STDARG_H + /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H +/* Define to 1 if you have the header file. */ +#undef HAVE_STDIO_H + /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H @@ -696,6 +705,9 @@ /* Define if target can unlink open files. */ #undef HAVE_UNLINK_OPEN_FILE +/* Define to 1 if you have the `vsnprintf' function. */ +#undef HAVE_VSNPRINTF + /* Define to 1 if you have the `wait' function. */ #undef HAVE_WAIT @@ -729,6 +741,10 @@ /* libm includes ynl */ #undef HAVE_YNL +/* Define to the sub-directory in which libtool stores uninstalled libraries. + */ +#undef LT_OBJDIR + /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT diff --git a/libgfortran/configure b/libgfortran/configure index ca967e4..7e568a3 100755 --- a/libgfortran/configure +++ b/libgfortran/configure @@ -3359,6 +3359,7 @@ fi + # Check for symbol versioning (copied from libssp). echo "$as_me:$LINENO: checking whether symbol versioning is supported" >&5 echo $ECHO_N "checking whether symbol versioning is supported... $ECHO_C" >&6 @@ -4320,13 +4321,13 @@ if test "${lt_cv_nm_interface+set}" = set; then else lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext - (eval echo "\"\$as_me:4323: $ac_compile\"" >&5) + (eval echo "\"\$as_me:4324: $ac_compile\"" >&5) (eval "$ac_compile" 2>conftest.err) cat conftest.err >&5 - (eval echo "\"\$as_me:4326: $NM \\\"conftest.$ac_objext\\\"\"" >&5) + (eval echo "\"\$as_me:4327: $NM \\\"conftest.$ac_objext\\\"\"" >&5) (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) cat conftest.err >&5 - (eval echo "\"\$as_me:4329: output\"" >&5) + (eval echo "\"\$as_me:4330: output\"" >&5) cat conftest.out >&5 if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" @@ -5381,7 +5382,7 @@ ia64-*-hpux*) ;; *-*-irix6*) # Find out which ABI we are using. - echo '#line 5384 "configure"' > conftest.$ac_ext + echo '#line 5385 "configure"' > conftest.$ac_ext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? @@ -6486,11 +6487,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6489: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6490: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:6493: \$? = $ac_status" >&5 + echo "$as_me:6494: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -6808,11 +6809,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6811: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6812: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:6815: \$? = $ac_status" >&5 + echo "$as_me:6816: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -6913,11 +6914,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6916: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6917: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:6920: \$? = $ac_status" >&5 + echo "$as_me:6921: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -6968,11 +6969,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6971: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6972: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:6975: \$? = $ac_status" >&5 + echo "$as_me:6976: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -9820,7 +9821,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 9823 "configure" +#line 9824 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -9920,7 +9921,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 9923 "configure" +#line 9924 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -10250,7 +10251,7 @@ fi # Provide some information about the compiler. -echo "$as_me:10253:" \ +echo "$as_me:10254:" \ "checking for Fortran compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 @@ -10486,7 +10487,7 @@ fi # Provide some information about the compiler. -echo "$as_me:10489:" \ +echo "$as_me:10490:" \ "checking for Fortran compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 @@ -11202,11 +11203,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:11205: $lt_compile\"" >&5) + (eval echo "\"\$as_me:11206: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:11209: \$? = $ac_status" >&5 + echo "$as_me:11210: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -11301,11 +11302,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:11304: $lt_compile\"" >&5) + (eval echo "\"\$as_me:11305: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:11308: \$? = $ac_status" >&5 + echo "$as_me:11309: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -11353,11 +11354,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:11356: $lt_compile\"" >&5) + (eval echo "\"\$as_me:11357: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:11360: \$? = $ac_status" >&5 + echo "$as_me:11361: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -14077,7 +14078,9 @@ fi -for ac_header in stdlib.h string.h unistd.h signal.h + + +for ac_header in stdio.h stdlib.h string.h unistd.h signal.h stdarg.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then @@ -18477,7 +18480,8 @@ done -for ac_func in gettimeofday stat fstat lstat getpwuid + +for ac_func in gettimeofday stat fstat lstat getpwuid vsnprintf do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac index 9e1572f..0c85326 100644 --- a/libgfortran/configure.ac +++ b/libgfortran/configure.ac @@ -176,7 +176,7 @@ AC_TYPE_OFF_T # check header files AC_STDC_HEADERS AC_HEADER_TIME -AC_HAVE_HEADERS(stdlib.h string.h unistd.h signal.h) +AC_HAVE_HEADERS(stdio.h stdlib.h string.h unistd.h signal.h stdarg.h) AC_CHECK_HEADERS(time.h sys/time.h sys/times.h sys/resource.h) AC_CHECK_HEADERS(sys/types.h sys/stat.h sys/wait.h floatingpoint.h ieeefp.h) AC_CHECK_HEADERS(fenv.h fptrap.h float.h execinfo.h pwd.h) @@ -192,7 +192,7 @@ AC_CHECK_FUNCS(getrusage times mkstemp strtof strtold snprintf ftruncate chsize) AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror) AC_CHECK_FUNCS(sleep time ttyname signal alarm ctime clock access fork execl) AC_CHECK_FUNCS(wait setmode execvp pipe dup2 close fdopen strcasestr getrlimit) -AC_CHECK_FUNCS(gettimeofday stat fstat lstat getpwuid) +AC_CHECK_FUNCS(gettimeofday stat fstat lstat getpwuid vsnprintf) # Check for glibc backtrace functions AC_CHECK_FUNCS(backtrace backtrace_symbols) diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 104c59f..a1998ad58 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -217,9 +217,13 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, else { /* We come here because of range checking. */ - if (total != ret->dim[0].ubound + 1 - ret->dim[0].lbound) - runtime_error ("Incorrect extent in return value of" - " PACK intrinsic"); + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); } } diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index 36ab89b..c8cd2a7 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -915,7 +915,7 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message) if (f != NULL) fmt->format_string = f->source; - st_sprintf (buffer, "%s\n", message); + sprintf (buffer, "%s\n", message); j = fmt->format_string - dtp->format; diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index b06b1ca..41d4a60 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -464,8 +464,8 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) if (dtp->u.p.repeat_count == 0) { - st_sprintf (message, "Zero repeat count in item %d of list input", - dtp->u.p.item_count); + sprintf (message, "Zero repeat count in item %d of list input", + dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); m = 1; @@ -477,11 +477,11 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) overflow: if (length == -1) - st_sprintf (message, "Repeat count overflow in item %d of list input", - dtp->u.p.item_count); + sprintf (message, "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); else - st_sprintf (message, "Integer overflow while reading item %d", - dtp->u.p.item_count); + sprintf (message, "Integer overflow while reading item %d", + dtp->u.p.item_count); free_saved (dtp); generate_error (&dtp->common, ERROR_READ_VALUE, message); @@ -527,9 +527,9 @@ parse_repeat (st_parameter_dt *dtp) if (repeat > MAX_REPEAT) { - st_sprintf (message, - "Repeat count overflow in item %d of list input", - dtp->u.p.item_count); + sprintf (message, + "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); return 1; @@ -540,9 +540,9 @@ parse_repeat (st_parameter_dt *dtp) case '*': if (repeat == 0) { - st_sprintf (message, - "Zero repeat count in item %d of list input", - dtp->u.p.item_count); + sprintf (message, + "Zero repeat count in item %d of list input", + dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); return 1; @@ -563,8 +563,8 @@ parse_repeat (st_parameter_dt *dtp) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad repeat count in item %d of list input", - dtp->u.p.item_count); + sprintf (message, "Bad repeat count in item %d of list input", + dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); return 1; } @@ -708,7 +708,7 @@ read_logical (st_parameter_dt *dtp, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad logical value while reading item %d", + sprintf (message, "Bad logical value while reading item %d", dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); return; @@ -840,7 +840,7 @@ read_integer (st_parameter_dt *dtp, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad integer for item %d in list input", + sprintf (message, "Bad integer for item %d in list input", dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); @@ -1004,7 +1004,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) else { free_saved (dtp); - st_sprintf (message, "Invalid string input in item %d", + sprintf (message, "Invalid string input in item %d", dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); } @@ -1123,7 +1123,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad floating point number for item %d", + sprintf (message, "Bad floating point number for item %d", dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); @@ -1206,7 +1206,7 @@ eol_2: eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad complex value in item %d of list input", + sprintf (message, "Bad complex value in item %d of list input", dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); } @@ -1421,7 +1421,7 @@ read_real (st_parameter_dt *dtp, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad real number in item %d of list input", + sprintf (message, "Bad real number in item %d of list input", dtp->u.p.item_count); generate_error (&dtp->common, ERROR_READ_VALUE, message); } @@ -1437,7 +1437,7 @@ check_type (st_parameter_dt *dtp, bt type, int len) if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type) { - st_sprintf (message, "Read type %s where %s was expected for item %d", + sprintf (message, "Read type %s where %s was expected for item %d", type_name (dtp->u.p.saved_type), type_name (type), dtp->u.p.item_count); @@ -1450,7 +1450,7 @@ check_type (st_parameter_dt *dtp, bt type, int len) if (dtp->u.p.saved_length != len) { - st_sprintf (message, + sprintf (message, "Read kind %d %s where kind %d is required for item %d", dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len, dtp->u.p.item_count); @@ -1723,8 +1723,8 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, if ((c==',' && dim == rank -1) || (c==')' && dim < rank -1)) { - st_sprintf (parse_err_msg, - "Bad number of index fields"); + sprintf (parse_err_msg, + "Bad number of index fields"); goto err_ret; } break; @@ -1739,21 +1739,21 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, break; default: - st_sprintf (parse_err_msg, "Bad character in index"); + sprintf (parse_err_msg, "Bad character in index"); goto err_ret; } if ((c == ',' || c == ')') && indx == 0 && dtp->u.p.saved_string == 0) { - st_sprintf (parse_err_msg, "Null index field"); + sprintf (parse_err_msg, "Null index field"); goto err_ret; } if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0) || (indx == 2 && dtp->u.p.saved_string == 0)) { - st_sprintf(parse_err_msg, "Bad index triplet"); + sprintf(parse_err_msg, "Bad index triplet"); goto err_ret; } @@ -1769,7 +1769,7 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, /* Now read the index. */ if (convert_integer (dtp, sizeof(ssize_t), neg)) { - st_sprintf (parse_err_msg, "Bad integer in index"); + sprintf (parse_err_msg, "Bad integer in index"); goto err_ret; } break; @@ -1811,13 +1811,13 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, || (ls[dim].end > (ssize_t)ad[dim].ubound) || (ls[dim].end < (ssize_t)ad[dim].lbound)) { - st_sprintf (parse_err_msg, "Index %d out of range", dim + 1); + sprintf (parse_err_msg, "Index %d out of range", dim + 1); goto err_ret; } if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) || (ls[dim].step == 0)) { - st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1); + sprintf (parse_err_msg, "Bad range in index %d", dim + 1); goto err_ret; } @@ -2171,7 +2171,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, goto incr_idx; default: - st_sprintf (nml_err_msg, "Bad type for namelist object %s", + sprintf (nml_err_msg, "Bad type for namelist object %s", nl->var_name); internal_error (&dtp->common, nml_err_msg); goto nml_err_ret; @@ -2260,7 +2260,7 @@ incr_idx: if (dtp->u.p.repeat_count > 1) { - st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" , + sprintf (nml_err_msg, "Repeat count too large for namelist object %s" , nl->var_name ); goto nml_err_ret; } @@ -2310,7 +2310,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, c = next_char (dtp); if (c != '?') { - st_sprintf (nml_err_msg, "namelist read: misplaced = sign"); + sprintf (nml_err_msg, "namelist read: misplaced = sign"); goto nml_err_ret; } nml_query (dtp, '='); @@ -2325,7 +2325,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, nml_match_name (dtp, "end", 3); if (dtp->u.p.nml_read_error) { - st_sprintf (nml_err_msg, "namelist not terminated with / or &end"); + sprintf (nml_err_msg, "namelist not terminated with / or &end"); goto nml_err_ret; } case '/': @@ -2384,11 +2384,11 @@ get_name: if (nl == NULL) { if (dtp->u.p.nml_read_error && *pprev_nl) - st_sprintf (nml_err_msg, "Bad data for namelist object %s", + sprintf (nml_err_msg, "Bad data for namelist object %s", (*pprev_nl)->var_name); else - st_sprintf (nml_err_msg, "Cannot match namelist object name %s", + sprintf (nml_err_msg, "Cannot match namelist object name %s", dtp->u.p.saved_string); goto nml_err_ret; @@ -2412,7 +2412,7 @@ get_name: if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, parse_err_msg) == FAILURE) { - st_sprintf (nml_err_msg, "%s for namelist variable %s", + sprintf (nml_err_msg, "%s for namelist variable %s", parse_err_msg, nl->var_name); goto nml_err_ret; } @@ -2429,7 +2429,7 @@ get_name: if (nl->type != GFC_DTYPE_DERIVED) { - st_sprintf (nml_err_msg, "Attempt to get derived component for %s", + sprintf (nml_err_msg, "Attempt to get derived component for %s", nl->var_name); goto nml_err_ret; } @@ -2457,7 +2457,7 @@ get_name: if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE) { - st_sprintf (nml_err_msg, "%s for namelist variable %s", + sprintf (nml_err_msg, "%s for namelist variable %s", parse_err_msg, nl->var_name); goto nml_err_ret; } @@ -2467,7 +2467,7 @@ get_name: if (ind[0].step != 1) { - st_sprintf (nml_err_msg, + sprintf (nml_err_msg, "Bad step in substring for namelist object %s", nl->var_name); goto nml_err_ret; @@ -2490,7 +2490,7 @@ get_name: if (c == '(') { - st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character" + sprintf (nml_err_msg, "Qualifier for a scalar or non-character" " namelist object %s", nl->var_name); goto nml_err_ret; } @@ -2514,7 +2514,7 @@ get_name: if (c != '=') { - st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s", + sprintf (nml_err_msg, "Equal sign must follow namelist object name %s", nl->var_name); goto nml_err_ret; } diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index 68be74b..67f8804 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -389,19 +389,19 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) switch (errno) { case ENOENT: - st_sprintf (msg, "File '%s' does not exist", path); + sprintf (msg, "File '%s' does not exist", path); break; case EEXIST: - st_sprintf (msg, "File '%s' already exists", path); + sprintf (msg, "File '%s' already exists", path); break; case EACCES: - st_sprintf (msg, "Permission denied trying to open file '%s'", path); + sprintf (msg, "Permission denied trying to open file '%s'", path); break; case EISDIR: - st_sprintf (msg, "'%s' is a directory", path); + sprintf (msg, "'%s' is a directory", path); break; default: diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 3feae04..04f9f73 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -852,8 +852,8 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) if (actual == expected) return 0; - st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", - type_name (expected), dtp->u.p.item_count, type_name (actual)); + sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", + type_name (expected), dtp->u.p.item_count, type_name (actual)); format_error (dtp, f, buffer); return 1; diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 87d001e..e9ad164 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -142,10 +142,6 @@ typedef struct } int_stream; -extern stream *init_error_stream (unix_stream *); -internal_proto(init_error_stream); - - /* This implementation of stream I/O is based on the paper: * * "Exploiting the advantages of mapped files for stream I/O", @@ -1155,7 +1151,7 @@ tempfile (st_parameter_open *opp) template = get_mem (strlen (tempdir) + 20); - st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir); + sprintf (template, "%s/gfortrantmpXXXXXX", tempdir); #ifdef HAVE_MKSTEMP @@ -1385,122 +1381,44 @@ error_stream (void) return fd_to_stream (STDERR_FILENO, PROT_WRITE); } -/* init_error_stream()-- Return a pointer to the error stream. This - * subroutine is called when the stream is needed, rather than at - * initialization. We want to work even if memory has been seriously - * corrupted. */ -stream * -init_error_stream (unix_stream *error) -{ - memset (error, '\0', sizeof (*error)); +/* st_vprintf()-- vprintf function for error output. To avoid buffer + overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k + is big enough to completely fill a 80x25 terminal, so it shuld be + OK. We use a direct write() because it is simpler and least likely + to be clobbered by memory corruption. */ - error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO; +#define ST_VPRINTF_SIZE 2048 - error->st.alloc_w_at = (void *) fd_alloc_w_at; - error->st.sfree = (void *) fd_sfree; - - error->unbuffered = 1; - error->buffer = error->small_buffer; +int +st_vprintf (const char *format, va_list ap) +{ + static char buffer[ST_VPRINTF_SIZE]; + int written; + int fd; - return (stream *) error; + fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO; +#ifdef HAVE_VSNPRINTF + written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap); +#else + written = __builtin_vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap); +#endif + written = write (fd, buffer, written); + return written; } -/* st_printf()-- simple printf() function for streams that handles the - * formats %d, %s and %c. This function handles printing of error - * messages that originate within the library itself, not from a user - * program. */ +/* st_printf()-- printf() function for error output. This just calls + st_vprintf() to do the actual work. */ int st_printf (const char *format, ...) { - int count, total; - va_list arg; - char *p; - const char *q; - stream *s; - char itoa_buf[GFC_ITOA_BUF_SIZE]; - unix_stream err_stream; - - total = 0; - s = init_error_stream (&err_stream); - va_start (arg, format); - - for (;;) - { - count = 0; - - while (format[count] != '%' && format[count] != '\0') - count++; - - if (count != 0) - { - p = salloc_w (s, &count); - memmove (p, format, count); - sfree (s); - } - - total += count; - format += count; - if (*format++ == '\0') - break; - - switch (*format) - { - case 'c': - count = 1; - - p = salloc_w (s, &count); - *p = (char) va_arg (arg, int); - - sfree (s); - break; - - case 'd': - q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf)); - count = strlen (q); - - p = salloc_w (s, &count); - memmove (p, q, count); - sfree (s); - break; - - case 'x': - q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf)); - count = strlen (q); - - p = salloc_w (s, &count); - memmove (p, q, count); - sfree (s); - break; - - case 's': - q = va_arg (arg, char *); - count = strlen (q); - - p = salloc_w (s, &count); - memmove (p, q, count); - sfree (s); - break; - - case '\0': - return total; - - default: - count = 2; - p = salloc_w (s, &count); - p[0] = format[-1]; - p[1] = format[0]; - sfree (s); - break; - } - - total += count; - format++; - } - - va_end (arg); - return total; + int written; + va_list ap; + va_start (ap, format); + written = st_vprintf(format, ap); + va_end (ap); + return written; } diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index b4e5d3e..9509711 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1719,7 +1719,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, { if (rep_ctr > 1) { - st_sprintf(rep_buff, " %d*", rep_ctr); + sprintf(rep_buff, " %d*", rep_ctr); write_character (dtp, rep_buff, strlen (rep_buff)); dtp->u.p.no_leading_blank = 1; } @@ -1792,7 +1792,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, ext_name[tot_len] = '('; tot_len++; } - st_sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx); + sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx); tot_len += strlen (ext_name + tot_len); ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ','; tot_len++; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index a1efab2..33c2e2c 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -31,6 +31,7 @@ Boston, MA 02110-1301, USA. */ #ifndef LIBGFOR_H #define LIBGFOR_H +#include #include #include #include @@ -593,7 +594,8 @@ iexport_proto(os_error); extern void show_locus (st_parameter_common *); internal_proto(show_locus); -extern void runtime_error (const char *) __attribute__ ((noreturn)); +extern void runtime_error (const char *, ...) + __attribute__ ((noreturn, format (printf, 1, 2))); iexport_proto(runtime_error); extern void runtime_error_at (const char *, const char *) @@ -607,10 +609,6 @@ internal_proto(internal_error); extern const char *get_oserror (void); internal_proto(get_oserror); -extern void st_sprintf (char *, const char *, ...) - __attribute__ ((format (printf, 2, 3))); -internal_proto(st_sprintf); - extern const char *translate_error (int); internal_proto(translate_error); @@ -688,6 +686,9 @@ extern int st_printf (const char *, ...) __attribute__ ((format (printf, 1, 2))); internal_proto(st_printf); +extern int st_vprintf (const char *, va_list); +internal_proto(st_vprintf); + extern char * filename_from_unit (int); internal_proto(filename_from_unit); diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c index 959a44b..4dda227 100644 --- a/libgfortran/runtime/error.c +++ b/libgfortran/runtime/error.c @@ -185,63 +185,6 @@ xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) return p; } - -/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */ - -void -st_sprintf (char *buffer, const char *format, ...) -{ - va_list arg; - char c; - const char *p; - int count; - char itoa_buf[GFC_ITOA_BUF_SIZE]; - - va_start (arg, format); - - for (;;) - { - c = *format++; - if (c != '%') - { - *buffer++ = c; - if (c == '\0') - break; - continue; - } - - c = *format++; - switch (c) - { - case 'c': - *buffer++ = (char) va_arg (arg, int); - break; - - case 'd': - p = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf)); - count = strlen (p); - - memcpy (buffer, p, count); - buffer += count; - break; - - case 's': - p = va_arg (arg, char *); - count = strlen (p); - - memcpy (buffer, p, count); - buffer += count; - break; - - default: - *buffer++ = c; - } - } - - va_end (arg); -} - - /* show_locus()-- Print a line number and filename describing where * something went wrong */ @@ -306,10 +249,16 @@ iexport(os_error); * invalid fortran program. */ void -runtime_error (const char *message) +runtime_error (const char *message, ...) { + va_list ap; + recursion_check (); - st_printf ("Fortran runtime error: %s\n", message); + st_printf ("Fortran runtime error: "); + va_start (ap, message); + st_vprintf (message, ap); + va_end (ap); + st_printf ("\n"); sys_exit (2); } iexport(runtime_error); diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c index e88c2ab..570e959 100644 --- a/libgfortran/runtime/main.c +++ b/libgfortran/runtime/main.c @@ -126,7 +126,7 @@ store_exe_path (const char * argv0) /* exe_path will be cwd + "/" + argv[0] + "\0" */ path = malloc (strlen (cwd) + 1 + strlen (argv0) + 1); - st_sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0); + sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0); exe_path = path; please_free_exe_path_when_done = 1; } -- 2.7.4