+2007-07-29 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR libfortran/32858
+ PR libfortran/30814
+ * gfortran.dg/pack_bounds_1.f90: Adjust to new error message.
+
2007-07-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31211
! { 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" }
+2007-07-29 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ 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 <stdio.h>. 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 <jb@gcc.gnu.org>
* io/transfer.c (st_set_nml_var_dim): Use index_type instead of
/* Define to 1 if you have the `ctime' function. */
#undef HAVE_CTIME
+/* Define to 1 if you have the <dlfcn.h> header file. */
+#undef HAVE_DLFCN_H
+
/* Define to 1 if you have the `dup2' function. */
#undef HAVE_DUP2
/* Define to 1 if you have the `stat' function. */
#undef HAVE_STAT
+/* Define to 1 if you have the <stdarg.h> header file. */
+#undef HAVE_STDARG_H
+
/* Define to 1 if you have the <stdint.h> header file. */
#undef HAVE_STDINT_H
+/* Define to 1 if you have the <stdio.h> header file. */
+#undef HAVE_STDIO_H
+
/* Define to 1 if you have the <stdlib.h> header file. */
#undef HAVE_STDLIB_H
/* 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
/* 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
+
# 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
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"
;;
*-*-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=$?
-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.
-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.
-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
-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
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
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
# 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 </dev/null >&5\"") >&5
# 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 </dev/null >&5\"") >&5
-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.
-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
-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
-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
-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
# 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)
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)
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);
}
}
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;
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;
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);
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;
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;
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;
}
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;
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);
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);
}
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);
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);
}
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);
}
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);
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);
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;
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;
}
/* 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;
|| (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;
}
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;
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;
}
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, '=');
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 '/':
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;
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;
}
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;
}
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;
}
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;
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;
}
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;
}
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:
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;
}
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",
template = get_mem (strlen (tempdir) + 20);
- st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
+ sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
#ifdef HAVE_MKSTEMP
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;
}
{
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;
}
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++;
#ifndef LIBGFOR_H
#define LIBGFOR_H
+#include <stdio.h>
#include <math.h>
#include <stddef.h>
#include <float.h>
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 *)
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);
__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);
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 */
* 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);
/* 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;
}
OSDN Git Service
