re PR libfortran/32858 (printf-capabilities for runtime_error())
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-29 Thomas Koenig <tkoenig@gcc.gnu.org> PR libfortran/32858 PR libfortran/30814 * gfortran.dg/pack_bounds_1.f90: Adjust to new error message. From-SVN: r127049
This commit is contained in:
Thomas Koenig
parent
6a56381bf7
commit
d8163f5cc0
16 changed files with 193 additions and 259 deletions
|
|
@ -1,3 +1,9 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -1,3 +1,39 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -270,6 +270,9 @@
|
|||
/* 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
|
||||
|
||||
|
|
@ -594,9 +597,15 @@
|
|||
/* 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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
52
libgfortran/configure
vendored
52
libgfortran/configure
vendored
|
|
@ -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 </dev/null >&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 </dev/null >&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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
/* 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. */
|
||||
|
||||
#define ST_VPRINTF_SIZE 2048
|
||||
|
||||
int
|
||||
st_vprintf (const char *format, va_list ap)
|
||||
{
|
||||
memset (error, '\0', sizeof (*error));
|
||||
static char buffer[ST_VPRINTF_SIZE];
|
||||
int written;
|
||||
int fd;
|
||||
|
||||
error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
|
||||
|
||||
error->st.alloc_w_at = (void *) fd_alloc_w_at;
|
||||
error->st.sfree = (void *) fd_sfree;
|
||||
|
||||
error->unbuffered = 1;
|
||||
error->buffer = error->small_buffer;
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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++;
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ Boston, MA 02110-1301, USA. */
|
|||
#ifndef LIBGFOR_H
|
||||
#define LIBGFOR_H
|
||||
|
||||
#include <stdio.h>
|
||||
#include <math.h>
|
||||
#include <stddef.h>
|
||||
#include <float.h>
|
||||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue