2013-01-14 19:20:58 +01:00
|
|
|
/* Copyright (C) 2007-2013 Free Software Foundation, Inc.
|
2007-09-05 02:51:18 +02:00
|
|
|
Contributed by Andy Vaught
|
|
|
|
Write float code factoring to this file by Jerry DeLisle
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
F2003 I/O support contributed by Jerry DeLisle
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2010-05-07 17:55:59 +02:00
|
|
|
This file is part of the GNU Fortran runtime library (libgfortran).
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
Libgfortran is free software; you can redistribute it and/or modify
|
|
|
|
it under the terms of the GNU General Public License as published by
|
2009-04-09 17:00:19 +02:00
|
|
|
the Free Software Foundation; either version 3, or (at your option)
|
2007-09-05 02:51:18 +02:00
|
|
|
any later version.
|
|
|
|
|
|
|
|
Libgfortran is distributed in the hope that it will be useful,
|
|
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
GNU General Public License for more details.
|
|
|
|
|
2009-04-09 17:00:19 +02:00
|
|
|
Under Section 7 of GPL version 3, you are granted additional
|
|
|
|
permissions described in the GCC Runtime Library Exception, version
|
|
|
|
3.1, as published by the Free Software Foundation.
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License and
|
|
|
|
a copy of the GCC Runtime Library Exception along with this program;
|
|
|
|
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
|
|
<http://www.gnu.org/licenses/>. */
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
#include "config.h"
|
|
|
|
|
|
|
|
typedef enum
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
{ S_NONE, S_MINUS, S_PLUS }
|
2007-09-05 02:51:18 +02:00
|
|
|
sign_t;
|
|
|
|
|
|
|
|
/* Given a flag that indicates if a value is negative or not, return a
|
|
|
|
sign_t that gives the sign that we need to produce. */
|
|
|
|
|
|
|
|
static sign_t
|
|
|
|
calculate_sign (st_parameter_dt *dtp, int negative_flag)
|
|
|
|
{
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
sign_t s = S_NONE;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
if (negative_flag)
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
s = S_MINUS;
|
2007-09-05 02:51:18 +02:00
|
|
|
else
|
|
|
|
switch (dtp->u.p.sign_status)
|
|
|
|
{
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
case SIGN_SP: /* Show sign. */
|
|
|
|
s = S_PLUS;
|
2007-09-05 02:51:18 +02:00
|
|
|
break;
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
case SIGN_SS: /* Suppress sign. */
|
|
|
|
s = S_NONE;
|
2007-09-05 02:51:18 +02:00
|
|
|
break;
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
case SIGN_S: /* Processor defined. */
|
2008-09-23 05:52:19 +02:00
|
|
|
case SIGN_UNSPECIFIED:
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
s = options.optional_plus ? S_PLUS : S_NONE;
|
2007-09-05 02:51:18 +02:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
|
|
|
return s;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
/* Determine the precision except for EN format. For G format,
|
|
|
|
determines an upper bound to be used for sizing the buffer. */
|
|
|
|
|
|
|
|
static int
|
|
|
|
determine_precision (st_parameter_dt * dtp, const fnode * f, int len)
|
|
|
|
{
|
|
|
|
int precision = f->u.real.d;
|
|
|
|
|
|
|
|
switch (f->format)
|
|
|
|
{
|
|
|
|
case FMT_F:
|
|
|
|
case FMT_G:
|
|
|
|
precision += dtp->u.p.scale_factor;
|
|
|
|
break;
|
|
|
|
case FMT_ES:
|
|
|
|
/* Scale factor has no effect on output. */
|
|
|
|
break;
|
|
|
|
case FMT_E:
|
|
|
|
case FMT_D:
|
|
|
|
/* See F2008 10.7.2.3.3.6 */
|
|
|
|
if (dtp->u.p.scale_factor <= 0)
|
|
|
|
precision += dtp->u.p.scale_factor - 1;
|
|
|
|
break;
|
|
|
|
default:
|
|
|
|
return -1;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* If the scale factor has a large negative value, we must do our
|
|
|
|
own rounding? Use ROUND='NEAREST', which should be what snprintf
|
|
|
|
is using as well. */
|
|
|
|
if (precision < 0 &&
|
|
|
|
(dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
|
|
|
|
|| dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
|
|
|
|
dtp->u.p.current_unit->round_status = ROUND_NEAREST;
|
|
|
|
|
|
|
|
/* Add extra guard digits up to at least full precision when we do
|
|
|
|
our own rounding. */
|
|
|
|
if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
|
|
|
|
&& dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
|
|
|
|
{
|
|
|
|
precision += 2 * len + 4;
|
|
|
|
if (precision < 0)
|
|
|
|
precision = 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
return precision;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Output a real number according to its format which is FMT_G free. */
|
|
|
|
|
2013-03-19 12:13:32 +01:00
|
|
|
static bool
|
2012-03-15 16:14:43 +01:00
|
|
|
output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
|
|
|
|
int nprinted, int precision, int sign_bit, bool zero_flag)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
|
|
|
char *out;
|
|
|
|
char *digits;
|
2011-05-01 14:32:18 +02:00
|
|
|
int e, w, d, p, i;
|
2009-09-29 04:47:54 +02:00
|
|
|
char expchar, rchar;
|
2007-09-05 02:51:18 +02:00
|
|
|
format_token ft;
|
|
|
|
/* Number of digits before the decimal point. */
|
|
|
|
int nbefore;
|
|
|
|
/* Number of zeros after the decimal point. */
|
|
|
|
int nzero;
|
|
|
|
/* Number of digits after the decimal point. */
|
|
|
|
int nafter;
|
|
|
|
/* Number of zeros after the decimal point, whatever the precision. */
|
|
|
|
int nzero_real;
|
|
|
|
int leadzero;
|
|
|
|
int nblanks;
|
2012-03-15 16:14:43 +01:00
|
|
|
int ndigits, edigits;
|
2007-09-05 02:51:18 +02:00
|
|
|
sign_t sign;
|
|
|
|
|
|
|
|
ft = f->format;
|
|
|
|
w = f->u.real.w;
|
|
|
|
d = f->u.real.d;
|
2011-05-01 14:32:18 +02:00
|
|
|
p = dtp->u.p.scale_factor;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2009-09-29 04:47:54 +02:00
|
|
|
rchar = '5';
|
2007-09-05 02:51:18 +02:00
|
|
|
nzero_real = -1;
|
|
|
|
|
|
|
|
/* We should always know the field width and precision. */
|
|
|
|
if (d < 0)
|
|
|
|
internal_error (&dtp->common, "Unspecified precision");
|
|
|
|
|
|
|
|
sign = calculate_sign (dtp, sign_bit);
|
2008-07-21 06:44:10 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
/* Calculate total number of digits. */
|
|
|
|
if (ft == FMT_F)
|
|
|
|
ndigits = nprinted - 2;
|
|
|
|
else
|
|
|
|
ndigits = precision + 1;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
/* Read the exponent back in. */
|
2012-03-15 16:14:43 +01:00
|
|
|
if (ft != FMT_F)
|
|
|
|
e = atoi (&buffer[ndigits + 3]) + 1;
|
|
|
|
else
|
|
|
|
e = 0;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
/* Make sure zero comes out as 0.0e0. */
|
|
|
|
if (zero_flag)
|
2011-03-01 03:24:50 +01:00
|
|
|
e = 0;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
/* Normalize the fractional component. */
|
2012-03-15 16:14:43 +01:00
|
|
|
if (ft != FMT_F)
|
|
|
|
{
|
|
|
|
buffer[2] = buffer[1];
|
|
|
|
digits = &buffer[2];
|
|
|
|
}
|
|
|
|
else
|
|
|
|
digits = &buffer[1];
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
/* Figure out where to place the decimal point. */
|
|
|
|
switch (ft)
|
|
|
|
{
|
|
|
|
case FMT_F:
|
2012-03-15 16:14:43 +01:00
|
|
|
nbefore = ndigits - precision;
|
|
|
|
/* Make sure the decimal point is a '.'; depending on the
|
|
|
|
locale, this might not be the case otherwise. */
|
|
|
|
digits[nbefore] = '.';
|
|
|
|
if (p != 0)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
2012-03-15 16:14:43 +01:00
|
|
|
if (p > 0)
|
|
|
|
{
|
|
|
|
|
|
|
|
memmove (digits + nbefore, digits + nbefore + 1, p);
|
|
|
|
digits[nbefore + p] = '.';
|
|
|
|
nbefore += p;
|
|
|
|
nafter = d - p;
|
|
|
|
if (nafter < 0)
|
|
|
|
nafter = 0;
|
|
|
|
nafter = d;
|
|
|
|
nzero = nzero_real = 0;
|
|
|
|
}
|
|
|
|
else /* p < 0 */
|
|
|
|
{
|
|
|
|
if (nbefore + p >= 0)
|
|
|
|
{
|
|
|
|
nzero = 0;
|
|
|
|
memmove (digits + nbefore + p + 1, digits + nbefore + p, -p);
|
|
|
|
nbefore += p;
|
|
|
|
digits[nbefore] = '.';
|
|
|
|
nafter = d;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
nzero = -(nbefore + p);
|
|
|
|
memmove (digits + 1, digits, nbefore);
|
|
|
|
digits++;
|
|
|
|
nafter = d + nbefore;
|
|
|
|
nbefore = 0;
|
|
|
|
}
|
|
|
|
nzero_real = nzero;
|
|
|
|
if (nzero > d)
|
|
|
|
nzero = d;
|
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
2012-03-15 16:14:43 +01:00
|
|
|
nzero = nzero_real = 0;
|
2007-09-05 02:51:18 +02:00
|
|
|
nafter = d;
|
|
|
|
}
|
2012-03-15 16:14:43 +01:00
|
|
|
|
2012-03-17 18:19:49 +01:00
|
|
|
while (digits[0] == '0' && nbefore > 0)
|
|
|
|
{
|
|
|
|
digits++;
|
|
|
|
nbefore--;
|
|
|
|
ndigits--;
|
|
|
|
}
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
expchar = 0;
|
2012-03-15 16:14:43 +01:00
|
|
|
/* If we need to do rounding ourselves, get rid of the dot by
|
|
|
|
moving the fractional part. */
|
|
|
|
if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
|
|
|
|
&& dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
|
|
|
|
memmove (digits + nbefore, digits + nbefore + 1, ndigits - nbefore);
|
2007-09-05 02:51:18 +02:00
|
|
|
break;
|
|
|
|
|
|
|
|
case FMT_E:
|
|
|
|
case FMT_D:
|
|
|
|
i = dtp->u.p.scale_factor;
|
2011-05-01 14:32:18 +02:00
|
|
|
if (d <= 0 && p == 0)
|
2008-02-21 03:20:27 +01:00
|
|
|
{
|
|
|
|
generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
|
|
|
|
"greater than zero in format specifier 'E' or 'D'");
|
2013-03-19 12:13:32 +01:00
|
|
|
return false;
|
2008-02-21 03:20:27 +01:00
|
|
|
}
|
2011-05-01 14:32:18 +02:00
|
|
|
if (p <= -d || p >= d + 2)
|
2008-02-21 03:20:27 +01:00
|
|
|
{
|
|
|
|
generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
|
|
|
|
"out of range in format specifier 'E' or 'D'");
|
2013-03-19 12:13:32 +01:00
|
|
|
return false;
|
2008-02-21 03:20:27 +01:00
|
|
|
}
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
if (!zero_flag)
|
2011-05-01 14:32:18 +02:00
|
|
|
e -= p;
|
|
|
|
if (p < 0)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
|
|
|
nbefore = 0;
|
2011-05-01 14:32:18 +02:00
|
|
|
nzero = -p;
|
|
|
|
nafter = d + p;
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
2011-05-01 14:32:18 +02:00
|
|
|
else if (p > 0)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
2011-05-01 14:32:18 +02:00
|
|
|
nbefore = p;
|
2007-09-05 02:51:18 +02:00
|
|
|
nzero = 0;
|
2011-05-01 14:32:18 +02:00
|
|
|
nafter = (d - p) + 1;
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
2011-05-01 14:32:18 +02:00
|
|
|
else /* p == 0 */
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
|
|
|
nbefore = 0;
|
|
|
|
nzero = 0;
|
|
|
|
nafter = d;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (ft == FMT_E)
|
|
|
|
expchar = 'E';
|
|
|
|
else
|
|
|
|
expchar = 'D';
|
|
|
|
break;
|
|
|
|
|
|
|
|
case FMT_EN:
|
|
|
|
/* The exponent must be a multiple of three, with 1-3 digits before
|
|
|
|
the decimal point. */
|
|
|
|
if (!zero_flag)
|
|
|
|
e--;
|
|
|
|
if (e >= 0)
|
|
|
|
nbefore = e % 3;
|
|
|
|
else
|
|
|
|
{
|
|
|
|
nbefore = (-e) % 3;
|
|
|
|
if (nbefore != 0)
|
|
|
|
nbefore = 3 - nbefore;
|
|
|
|
}
|
|
|
|
e -= nbefore;
|
|
|
|
nbefore++;
|
|
|
|
nzero = 0;
|
|
|
|
nafter = d;
|
|
|
|
expchar = 'E';
|
|
|
|
break;
|
|
|
|
|
|
|
|
case FMT_ES:
|
|
|
|
if (!zero_flag)
|
|
|
|
e--;
|
|
|
|
nbefore = 1;
|
|
|
|
nzero = 0;
|
|
|
|
nafter = d;
|
|
|
|
expchar = 'E';
|
|
|
|
break;
|
|
|
|
|
|
|
|
default:
|
|
|
|
/* Should never happen. */
|
|
|
|
internal_error (&dtp->common, "Unexpected format token");
|
|
|
|
}
|
|
|
|
|
2011-04-18 05:48:25 +02:00
|
|
|
if (zero_flag)
|
|
|
|
goto skip;
|
2011-05-05 03:19:30 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
/* Round the value. The value being rounded is an unsigned magnitude. */
|
2009-09-29 04:47:54 +02:00
|
|
|
switch (dtp->u.p.current_unit->round_status)
|
|
|
|
{
|
2012-03-15 16:14:43 +01:00
|
|
|
/* For processor defined and unspecified rounding we use
|
|
|
|
snprintf to print the exact number of digits needed, and thus
|
|
|
|
let snprintf handle the rounding. On system claiming support
|
|
|
|
for IEEE 754, this ought to be round to nearest, ties to
|
|
|
|
even, corresponding to the Fortran ROUND='NEAREST'. */
|
|
|
|
case ROUND_PROCDEFINED:
|
|
|
|
case ROUND_UNSPECIFIED:
|
2009-09-29 04:47:54 +02:00
|
|
|
case ROUND_ZERO: /* Do nothing and truncation occurs. */
|
|
|
|
goto skip;
|
|
|
|
case ROUND_UP:
|
|
|
|
if (sign_bit)
|
|
|
|
goto skip;
|
2011-05-05 03:19:30 +02:00
|
|
|
goto updown;
|
2009-09-29 04:47:54 +02:00
|
|
|
case ROUND_DOWN:
|
|
|
|
if (!sign_bit)
|
|
|
|
goto skip;
|
2011-05-05 03:19:30 +02:00
|
|
|
goto updown;
|
2009-09-29 04:47:54 +02:00
|
|
|
case ROUND_NEAREST:
|
|
|
|
/* Round compatible unless there is a tie. A tie is a 5 with
|
|
|
|
all trailing zero's. */
|
2009-10-06 05:08:20 +02:00
|
|
|
i = nafter + nbefore;
|
2009-09-29 04:47:54 +02:00
|
|
|
if (digits[i] == '5')
|
|
|
|
{
|
|
|
|
for(i++ ; i < ndigits; i++)
|
|
|
|
{
|
|
|
|
if (digits[i] != '0')
|
|
|
|
goto do_rnd;
|
|
|
|
}
|
2011-05-05 03:19:30 +02:00
|
|
|
/* It is a tie so round to even. */
|
2009-10-06 05:08:20 +02:00
|
|
|
switch (digits[nafter + nbefore - 1])
|
2009-09-29 04:47:54 +02:00
|
|
|
{
|
|
|
|
case '1':
|
|
|
|
case '3':
|
|
|
|
case '5':
|
|
|
|
case '7':
|
|
|
|
case '9':
|
|
|
|
/* If odd, round away from zero to even. */
|
|
|
|
break;
|
|
|
|
default:
|
|
|
|
/* If even, skip rounding, truncate to even. */
|
|
|
|
goto skip;
|
|
|
|
}
|
|
|
|
}
|
2012-03-15 16:14:43 +01:00
|
|
|
/* Fall through. */
|
|
|
|
/* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
|
2009-09-29 04:47:54 +02:00
|
|
|
case ROUND_COMPATIBLE:
|
|
|
|
rchar = '5';
|
2011-05-05 03:19:30 +02:00
|
|
|
goto do_rnd;
|
|
|
|
}
|
|
|
|
|
|
|
|
updown:
|
|
|
|
|
|
|
|
rchar = '0';
|
|
|
|
if (w > 0 && d == 0 && p == 0)
|
|
|
|
nbefore = 1;
|
|
|
|
/* Scan for trailing zeros to see if we really need to round it. */
|
|
|
|
for(i = nbefore + nafter; i < ndigits; i++)
|
|
|
|
{
|
|
|
|
if (digits[i] != '0')
|
|
|
|
goto do_rnd;
|
2009-09-29 04:47:54 +02:00
|
|
|
}
|
2011-05-05 03:19:30 +02:00
|
|
|
goto skip;
|
2009-09-29 04:47:54 +02:00
|
|
|
|
|
|
|
do_rnd:
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
if (nbefore + nafter == 0)
|
|
|
|
{
|
|
|
|
ndigits = 0;
|
2009-09-29 04:47:54 +02:00
|
|
|
if (nzero_real == d && digits[0] >= rchar)
|
|
|
|
{
|
|
|
|
/* We rounded to zero but shouldn't have */
|
|
|
|
nzero--;
|
|
|
|
nafter = 1;
|
|
|
|
digits[0] = '1';
|
|
|
|
ndigits = 1;
|
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
|
|
|
else if (nbefore + nafter < ndigits)
|
|
|
|
{
|
2011-04-29 16:56:02 +02:00
|
|
|
i = ndigits = nbefore + nafter;
|
2009-09-29 04:47:54 +02:00
|
|
|
if (digits[i] >= rchar)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
|
|
|
/* Propagate the carry. */
|
|
|
|
for (i--; i >= 0; i--)
|
|
|
|
{
|
|
|
|
if (digits[i] != '9')
|
|
|
|
{
|
|
|
|
digits[i]++;
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
digits[i] = '0';
|
|
|
|
}
|
|
|
|
|
|
|
|
if (i < 0)
|
|
|
|
{
|
2009-09-29 04:47:54 +02:00
|
|
|
/* The carry overflowed. Fortunately we have some spare
|
|
|
|
space at the start of the buffer. We may discard some
|
|
|
|
digits, but this is ok because we already know they are
|
|
|
|
zero. */
|
2007-09-05 02:51:18 +02:00
|
|
|
digits--;
|
|
|
|
digits[0] = '1';
|
|
|
|
if (ft == FMT_F)
|
|
|
|
{
|
|
|
|
if (nzero > 0)
|
|
|
|
{
|
|
|
|
nzero--;
|
|
|
|
nafter++;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
nbefore++;
|
|
|
|
}
|
|
|
|
else if (ft == FMT_EN)
|
|
|
|
{
|
|
|
|
nbefore++;
|
|
|
|
if (nbefore == 4)
|
|
|
|
{
|
|
|
|
nbefore = 1;
|
|
|
|
e += 3;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else
|
|
|
|
e++;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2009-09-29 04:47:54 +02:00
|
|
|
skip:
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Calculate the format of the exponent field. */
|
|
|
|
if (expchar)
|
|
|
|
{
|
|
|
|
edigits = 1;
|
|
|
|
for (i = abs (e); i >= 10; i /= 10)
|
|
|
|
edigits++;
|
|
|
|
|
|
|
|
if (f->u.real.e < 0)
|
|
|
|
{
|
|
|
|
/* Width not specified. Must be no more than 3 digits. */
|
|
|
|
if (e > 999 || e < -999)
|
|
|
|
edigits = -1;
|
|
|
|
else
|
|
|
|
{
|
|
|
|
edigits = 4;
|
|
|
|
if (e > 99 || e < -99)
|
|
|
|
expchar = ' ';
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
/* Exponent width specified, check it is wide enough. */
|
|
|
|
if (edigits > f->u.real.e)
|
|
|
|
edigits = -1;
|
|
|
|
else
|
|
|
|
edigits = f->u.real.e + 2;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else
|
|
|
|
edigits = 0;
|
|
|
|
|
2011-03-01 03:24:50 +01:00
|
|
|
/* Scan the digits string and count the number of zeros. If we make it
|
|
|
|
all the way through the loop, we know the value is zero after the
|
|
|
|
rounding completed above. */
|
2012-12-25 23:11:16 +01:00
|
|
|
int hasdot = 0;
|
|
|
|
for (i = 0; i < ndigits + hasdot; i++)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
2012-12-25 23:11:16 +01:00
|
|
|
if (digits[i] == '.')
|
|
|
|
hasdot = 1;
|
|
|
|
else if (digits[i] != '0')
|
2007-09-05 02:51:18 +02:00
|
|
|
break;
|
|
|
|
}
|
2011-03-01 03:24:50 +01:00
|
|
|
|
|
|
|
/* To format properly, we need to know if the rounded result is zero and if
|
|
|
|
so, we set the zero_flag which may have been already set for
|
|
|
|
actual zero. */
|
2012-12-25 23:11:16 +01:00
|
|
|
if (i == ndigits + hasdot)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
2011-03-01 03:24:50 +01:00
|
|
|
zero_flag = true;
|
2007-09-05 02:51:18 +02:00
|
|
|
/* The output is zero, so set the sign according to the sign bit unless
|
|
|
|
-fno-sign-zero was specified. */
|
|
|
|
if (compile_options.sign_zero == 1)
|
|
|
|
sign = calculate_sign (dtp, sign_bit);
|
|
|
|
else
|
|
|
|
sign = calculate_sign (dtp, 0);
|
|
|
|
}
|
|
|
|
|
2011-03-01 03:24:50 +01:00
|
|
|
/* Pick a field size if none was specified, taking into account small
|
|
|
|
values that may have been rounded to zero. */
|
2008-12-21 22:23:52 +01:00
|
|
|
if (w <= 0)
|
2011-02-05 18:58:48 +01:00
|
|
|
{
|
2011-03-01 03:24:50 +01:00
|
|
|
if (zero_flag)
|
|
|
|
w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
|
|
|
|
else
|
|
|
|
{
|
|
|
|
w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
|
|
|
|
w = w == 1 ? 2 : w;
|
|
|
|
}
|
2011-02-05 18:58:48 +01:00
|
|
|
}
|
2008-12-21 22:23:52 +01:00
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Work out how much padding is needed. */
|
|
|
|
nblanks = w - (nbefore + nzero + nafter + edigits + 1);
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
if (sign != S_NONE)
|
2007-09-05 02:51:18 +02:00
|
|
|
nblanks--;
|
|
|
|
|
2008-12-21 22:23:52 +01:00
|
|
|
if (dtp->u.p.g0_no_blanks)
|
|
|
|
{
|
|
|
|
w -= nblanks;
|
|
|
|
nblanks = 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Create the ouput buffer. */
|
|
|
|
out = write_block (dtp, w);
|
|
|
|
if (out == NULL)
|
2013-03-19 12:13:32 +01:00
|
|
|
return false;
|
2008-12-21 22:23:52 +01:00
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Check the value fits in the specified field width. */
|
2011-02-05 18:58:48 +01:00
|
|
|
if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
2010-07-13 04:12:08 +02:00
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
|
|
{
|
2010-07-19 15:11:54 +02:00
|
|
|
gfc_char4_t *out4 = (gfc_char4_t *) out;
|
|
|
|
memset4 (out4, '*', w);
|
2013-03-19 12:13:32 +01:00
|
|
|
return false;
|
2010-07-13 04:12:08 +02:00
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
star_fill (out, w);
|
2013-03-19 12:13:32 +01:00
|
|
|
return false;
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
/* See if we have space for a zero before the decimal point. */
|
|
|
|
if (nbefore == 0 && nblanks > 0)
|
|
|
|
{
|
|
|
|
leadzero = 1;
|
|
|
|
nblanks--;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
leadzero = 0;
|
|
|
|
|
2010-07-13 04:12:08 +02:00
|
|
|
/* For internal character(kind=4) units, we duplicate the code used for
|
|
|
|
regular output slightly modified. This needs to be maintained
|
|
|
|
consistent with the regular code that follows this block. */
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
|
|
{
|
|
|
|
gfc_char4_t *out4 = (gfc_char4_t *) out;
|
|
|
|
/* Pad to full field width. */
|
|
|
|
|
|
|
|
if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
|
|
|
|
{
|
2010-07-19 15:11:54 +02:00
|
|
|
memset4 (out4, ' ', nblanks);
|
2010-07-13 04:12:08 +02:00
|
|
|
out4 += nblanks;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output the initial sign (if any). */
|
|
|
|
if (sign == S_PLUS)
|
|
|
|
*(out4++) = '+';
|
|
|
|
else if (sign == S_MINUS)
|
|
|
|
*(out4++) = '-';
|
|
|
|
|
|
|
|
/* Output an optional leading zero. */
|
|
|
|
if (leadzero)
|
|
|
|
*(out4++) = '0';
|
|
|
|
|
|
|
|
/* Output the part before the decimal point, padding with zeros. */
|
|
|
|
if (nbefore > 0)
|
|
|
|
{
|
|
|
|
if (nbefore > ndigits)
|
|
|
|
{
|
|
|
|
i = ndigits;
|
2010-07-19 15:11:54 +02:00
|
|
|
memcpy4 (out4, digits, i);
|
2010-07-13 04:12:08 +02:00
|
|
|
ndigits = 0;
|
|
|
|
while (i < nbefore)
|
|
|
|
out4[i++] = '0';
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
i = nbefore;
|
2010-07-19 15:11:54 +02:00
|
|
|
memcpy4 (out4, digits, i);
|
2010-07-13 04:12:08 +02:00
|
|
|
ndigits -= i;
|
|
|
|
}
|
|
|
|
|
|
|
|
digits += i;
|
|
|
|
out4 += nbefore;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output the decimal point. */
|
|
|
|
*(out4++) = dtp->u.p.current_unit->decimal_status
|
|
|
|
== DECIMAL_POINT ? '.' : ',';
|
2012-03-15 16:14:43 +01:00
|
|
|
if (ft == FMT_F
|
|
|
|
&& (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
|
|
|
|
|| dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
|
|
|
|
digits++;
|
2010-07-13 04:12:08 +02:00
|
|
|
|
|
|
|
/* Output leading zeros after the decimal point. */
|
|
|
|
if (nzero > 0)
|
|
|
|
{
|
|
|
|
for (i = 0; i < nzero; i++)
|
|
|
|
*(out4++) = '0';
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output digits after the decimal point, padding with zeros. */
|
|
|
|
if (nafter > 0)
|
|
|
|
{
|
|
|
|
if (nafter > ndigits)
|
|
|
|
i = ndigits;
|
|
|
|
else
|
|
|
|
i = nafter;
|
|
|
|
|
2010-07-19 15:11:54 +02:00
|
|
|
memcpy4 (out4, digits, i);
|
2010-07-13 04:12:08 +02:00
|
|
|
while (i < nafter)
|
|
|
|
out4[i++] = '0';
|
|
|
|
|
|
|
|
digits += i;
|
|
|
|
ndigits -= i;
|
|
|
|
out4 += nafter;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output the exponent. */
|
|
|
|
if (expchar)
|
|
|
|
{
|
|
|
|
if (expchar != ' ')
|
|
|
|
{
|
|
|
|
*(out4++) = expchar;
|
|
|
|
edigits--;
|
|
|
|
}
|
|
|
|
snprintf (buffer, size, "%+0*d", edigits, e);
|
2010-07-19 15:11:54 +02:00
|
|
|
memcpy4 (out4, buffer, edigits);
|
2010-07-13 04:12:08 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
if (dtp->u.p.no_leading_blank)
|
|
|
|
{
|
|
|
|
out4 += edigits;
|
2010-07-19 15:11:54 +02:00
|
|
|
memset4 (out4, ' ' , nblanks);
|
2010-07-13 04:12:08 +02:00
|
|
|
dtp->u.p.no_leading_blank = 0;
|
|
|
|
}
|
2013-03-19 12:13:32 +01:00
|
|
|
return true;
|
2010-07-13 04:12:08 +02:00
|
|
|
} /* End of character(kind=4) internal unit code. */
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Pad to full field width. */
|
|
|
|
|
|
|
|
if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
|
|
|
|
{
|
|
|
|
memset (out, ' ', nblanks);
|
|
|
|
out += nblanks;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output the initial sign (if any). */
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
if (sign == S_PLUS)
|
2007-09-05 02:51:18 +02:00
|
|
|
*(out++) = '+';
|
PR fortran/25829 28655
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25829 28655
* gfortran.map: Add new symbol, _gfortran_st_wait.
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid separator.
(eat_separator): Handle deimal comma. (read_logical): Fix whitespace.
(parse_real): Handle decimal comma. (read_real): Handle decimal comma.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: (unit_decimal, unit_encoding, unit_round, unit_sign,
unit_async): New enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode asychronous I/O control.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c: (st_option decimal_opt[], sign_opt[], blank_opt[]): New
option arrays. (formatted_transfer_scalar): Set sf_read_comma flag
based on new decimal_status flag. (data_transfer_init): Initialize new
parameters. Add checks for decimal, sign, and blank. (st_wait): New stub.
* format.c: (format_lex): Add format specifiers DP, DC, and D.
(parse_format_list): Parse the new specifiers.
* write.c (write_decimal): Use new sign enumerators to set the sign.
(write_complex): Handle decimal comma and semi-colon separator.
(nml_write_obj): Likewise.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
From-SVN: r133943
2008-04-06 00:18:03 +02:00
|
|
|
else if (sign == S_MINUS)
|
2007-09-05 02:51:18 +02:00
|
|
|
*(out++) = '-';
|
|
|
|
|
|
|
|
/* Output an optional leading zero. */
|
|
|
|
if (leadzero)
|
|
|
|
*(out++) = '0';
|
|
|
|
|
|
|
|
/* Output the part before the decimal point, padding with zeros. */
|
|
|
|
if (nbefore > 0)
|
|
|
|
{
|
|
|
|
if (nbefore > ndigits)
|
|
|
|
{
|
|
|
|
i = ndigits;
|
|
|
|
memcpy (out, digits, i);
|
|
|
|
ndigits = 0;
|
|
|
|
while (i < nbefore)
|
|
|
|
out[i++] = '0';
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
i = nbefore;
|
|
|
|
memcpy (out, digits, i);
|
|
|
|
ndigits -= i;
|
|
|
|
}
|
|
|
|
|
|
|
|
digits += i;
|
|
|
|
out += nbefore;
|
|
|
|
}
|
2008-12-21 22:23:52 +01:00
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Output the decimal point. */
|
2008-09-26 08:19:42 +02:00
|
|
|
*(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
|
2012-03-15 16:14:43 +01:00
|
|
|
if (ft == FMT_F
|
|
|
|
&& (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
|
|
|
|
|| dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
|
|
|
|
digits++;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
/* Output leading zeros after the decimal point. */
|
|
|
|
if (nzero > 0)
|
|
|
|
{
|
|
|
|
for (i = 0; i < nzero; i++)
|
|
|
|
*(out++) = '0';
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output digits after the decimal point, padding with zeros. */
|
|
|
|
if (nafter > 0)
|
|
|
|
{
|
|
|
|
if (nafter > ndigits)
|
|
|
|
i = ndigits;
|
|
|
|
else
|
|
|
|
i = nafter;
|
|
|
|
|
|
|
|
memcpy (out, digits, i);
|
|
|
|
while (i < nafter)
|
|
|
|
out[i++] = '0';
|
|
|
|
|
|
|
|
digits += i;
|
|
|
|
ndigits -= i;
|
|
|
|
out += nafter;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Output the exponent. */
|
|
|
|
if (expchar)
|
|
|
|
{
|
|
|
|
if (expchar != ' ')
|
|
|
|
{
|
|
|
|
*(out++) = expchar;
|
|
|
|
edigits--;
|
|
|
|
}
|
|
|
|
snprintf (buffer, size, "%+0*d", edigits, e);
|
|
|
|
memcpy (out, buffer, edigits);
|
|
|
|
}
|
2008-12-21 22:23:52 +01:00
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
if (dtp->u.p.no_leading_blank)
|
|
|
|
{
|
|
|
|
out += edigits;
|
|
|
|
memset( out , ' ' , nblanks );
|
|
|
|
dtp->u.p.no_leading_blank = 0;
|
|
|
|
}
|
2008-12-21 22:23:52 +01:00
|
|
|
|
2013-03-19 12:13:32 +01:00
|
|
|
return true;
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Write "Infinite" or "Nan" as appropriate for the given format. */
|
|
|
|
|
|
|
|
static void
|
|
|
|
write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
|
|
|
|
{
|
|
|
|
char * p, fin;
|
|
|
|
int nb = 0;
|
2011-01-29 18:31:04 +01:00
|
|
|
sign_t sign;
|
|
|
|
int mark;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
|
|
|
|
{
|
2011-01-29 18:31:04 +01:00
|
|
|
sign = calculate_sign (dtp, sign_bit);
|
|
|
|
mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
|
|
|
|
|
2010-07-13 04:12:08 +02:00
|
|
|
nb = f->u.real.w;
|
2011-04-15 18:29:44 +02:00
|
|
|
|
2010-07-13 04:12:08 +02:00
|
|
|
/* If the field width is zero, the processor must select a width
|
|
|
|
not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
|
|
|
|
|
2011-04-15 18:29:44 +02:00
|
|
|
if ((nb == 0) || dtp->u.p.g0_no_blanks)
|
2011-01-29 18:31:04 +01:00
|
|
|
{
|
|
|
|
if (isnan_flag)
|
|
|
|
nb = 3;
|
|
|
|
else
|
|
|
|
nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
p = write_block (dtp, nb);
|
|
|
|
if (p == NULL)
|
|
|
|
return;
|
|
|
|
if (nb < 3)
|
|
|
|
{
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
2010-07-19 15:11:54 +02:00
|
|
|
{
|
|
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
|
memset4 (p4, '*', nb);
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
else
|
|
|
|
memset (p, '*', nb);
|
|
|
|
return;
|
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2010-07-13 04:12:08 +02:00
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
2010-07-19 15:11:54 +02:00
|
|
|
{
|
|
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
|
memset4 (p4, ' ', nb);
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
else
|
|
|
|
memset(p, ' ', nb);
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2010-07-13 04:12:08 +02:00
|
|
|
if (!isnan_flag)
|
|
|
|
{
|
|
|
|
if (sign_bit)
|
|
|
|
{
|
|
|
|
/* If the sign is negative and the width is 3, there is
|
|
|
|
insufficient room to output '-Inf', so output asterisks */
|
|
|
|
if (nb == 3)
|
|
|
|
{
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
2010-07-19 15:11:54 +02:00
|
|
|
{
|
|
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
|
memset4 (p4, '*', nb);
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
else
|
|
|
|
memset (p, '*', nb);
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
/* The negative sign is mandatory */
|
|
|
|
fin = '-';
|
|
|
|
}
|
|
|
|
else
|
|
|
|
/* The positive sign is optional, but we output it for
|
|
|
|
consistency */
|
|
|
|
fin = '+';
|
|
|
|
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
|
|
{
|
|
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
2011-01-29 18:31:04 +01:00
|
|
|
|
|
|
|
if (nb > mark)
|
2010-07-13 04:12:08 +02:00
|
|
|
/* We have room, so output 'Infinity' */
|
2010-07-19 15:11:54 +02:00
|
|
|
memcpy4 (p4 + nb - 8, "Infinity", 8);
|
2007-09-05 02:51:18 +02:00
|
|
|
else
|
2011-01-29 18:31:04 +01:00
|
|
|
/* For the case of width equals mark, there is not enough room
|
2010-07-13 04:12:08 +02:00
|
|
|
for the sign and 'Infinity' so we go with 'Inf' */
|
2010-07-19 15:11:54 +02:00
|
|
|
memcpy4 (p4 + nb - 3, "Inf", 3);
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2011-01-29 18:31:04 +01:00
|
|
|
if (sign == S_PLUS || sign == S_MINUS)
|
|
|
|
{
|
|
|
|
if (nb < 9 && nb > 3)
|
|
|
|
/* Put the sign in front of Inf */
|
|
|
|
p4[nb - 4] = (gfc_char4_t) fin;
|
|
|
|
else if (nb > 8)
|
|
|
|
/* Put the sign in front of Infinity */
|
|
|
|
p4[nb - 9] = (gfc_char4_t) fin;
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
return;
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
|
2011-01-29 18:31:04 +01:00
|
|
|
if (nb > mark)
|
2010-07-13 04:12:08 +02:00
|
|
|
/* We have room, so output 'Infinity' */
|
|
|
|
memcpy(p + nb - 8, "Infinity", 8);
|
|
|
|
else
|
|
|
|
/* For the case of width equals 8, there is not enough room
|
|
|
|
for the sign and 'Infinity' so we go with 'Inf' */
|
|
|
|
memcpy(p + nb - 3, "Inf", 3);
|
|
|
|
|
2011-01-29 18:31:04 +01:00
|
|
|
if (sign == S_PLUS || sign == S_MINUS)
|
|
|
|
{
|
|
|
|
if (nb < 9 && nb > 3)
|
|
|
|
p[nb - 4] = fin; /* Put the sign in front of Inf */
|
|
|
|
else if (nb > 8)
|
|
|
|
p[nb - 9] = fin; /* Put the sign in front of Infinity */
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
2010-07-19 15:11:54 +02:00
|
|
|
{
|
|
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
|
memcpy4 (p4 + nb - 3, "NaN", 3);
|
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
else
|
|
|
|
memcpy(p + nb - 3, "NaN", 3);
|
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
return;
|
2007-09-05 02:51:18 +02:00
|
|
|
}
|
2010-07-13 04:12:08 +02:00
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
|
|
|
|
/* Returns the value of 10**d. */
|
|
|
|
|
|
|
|
#define CALCULATE_EXP(x) \
|
2011-11-10 18:08:24 +01:00
|
|
|
static GFC_REAL_ ## x \
|
2007-09-05 02:51:18 +02:00
|
|
|
calculate_exp_ ## x (int d)\
|
|
|
|
{\
|
|
|
|
int i;\
|
|
|
|
GFC_REAL_ ## x r = 1.0;\
|
|
|
|
for (i = 0; i< (d >= 0 ? d : -d); i++)\
|
|
|
|
r *= 10;\
|
|
|
|
r = (d >= 0) ? r : 1.0 / r;\
|
|
|
|
return r;\
|
|
|
|
}
|
|
|
|
|
|
|
|
CALCULATE_EXP(4)
|
|
|
|
|
|
|
|
CALCULATE_EXP(8)
|
|
|
|
|
|
|
|
#ifdef HAVE_GFC_REAL_10
|
|
|
|
CALCULATE_EXP(10)
|
|
|
|
#endif
|
|
|
|
|
|
|
|
#ifdef HAVE_GFC_REAL_16
|
|
|
|
CALCULATE_EXP(16)
|
|
|
|
#endif
|
|
|
|
#undef CALCULATE_EXP
|
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
|
|
|
|
/* Define a macro to build code for write_float. */
|
|
|
|
|
|
|
|
/* Note: Before output_float is called, snprintf is used to print to buffer the
|
|
|
|
number in the format +D.DDDDe+ddd.
|
|
|
|
|
|
|
|
# The result will always contain a decimal point, even if no
|
|
|
|
digits follow it
|
|
|
|
|
|
|
|
- The converted value is to be left adjusted on the field boundary
|
|
|
|
|
|
|
|
+ A sign (+ or -) always be placed before a number
|
|
|
|
|
|
|
|
* prec is used as the precision
|
|
|
|
|
|
|
|
e format: [-]d.ddde±dd where there is one digit before the
|
|
|
|
decimal-point character and the number of digits after it is
|
|
|
|
equal to the precision. The exponent always contains at least two
|
|
|
|
digits; if the value is zero, the exponent is 00. */
|
|
|
|
|
|
|
|
|
|
|
|
#define TOKENPASTE(x, y) TOKENPASTE2(x, y)
|
|
|
|
#define TOKENPASTE2(x, y) x ## y
|
|
|
|
|
|
|
|
#define DTOA(suff,prec,val) TOKENPASTE(DTOA2,suff)(prec,val)
|
|
|
|
|
|
|
|
#define DTOA2(prec,val) \
|
|
|
|
snprintf (buffer, size, "%+-#.*e", (prec), (val))
|
|
|
|
|
|
|
|
#define DTOA2L(prec,val) \
|
|
|
|
snprintf (buffer, size, "%+-#.*Le", (prec), (val))
|
|
|
|
|
|
|
|
|
|
|
|
#if defined(GFC_REAL_16_IS_FLOAT128)
|
|
|
|
#define DTOA2Q(prec,val) \
|
|
|
|
__qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qe", (prec), (val))
|
|
|
|
#endif
|
|
|
|
|
|
|
|
#define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val)
|
|
|
|
|
|
|
|
/* For F format, we print to the buffer with f format. */
|
|
|
|
#define FDTOA2(prec,val) \
|
|
|
|
snprintf (buffer, size, "%+-#.*f", (prec), (val))
|
|
|
|
|
|
|
|
#define FDTOA2L(prec,val) \
|
|
|
|
snprintf (buffer, size, "%+-#.*Lf", (prec), (val))
|
|
|
|
|
|
|
|
|
|
|
|
#if defined(GFC_REAL_16_IS_FLOAT128)
|
|
|
|
#define FDTOA2Q(prec,val) \
|
|
|
|
__qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qf", \
|
|
|
|
(prec), (val))
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
re PR libfortran/57496 (I/O: WRITE(*,*) HUGE(0._10) gives SIGFPE with -ffpe-trap=overflow)
2013-06-01 Tobias Burnus <burnus@net-b.de>
PR fortran/57496
* io/write_float.def (ISFINITE2Q, ISFINITE2, ISFINITE2L,
* ISFINITE,
SIGNBIT2Q, SIGNBIT2, SIGNBIT2L, SIGNBIT, ISNAN2Q, ISNAN2,
ISNAN2L, ISNAN): New macros.
(output_float_FMT_G_,WRITE_FLOAT): Use them.
From-SVN: r199598
2013-06-03 11:20:46 +02:00
|
|
|
#if defined(GFC_REAL_16_IS_FLOAT128)
|
|
|
|
#define ISFINITE2Q(val) finiteq(val)
|
|
|
|
#endif
|
|
|
|
#define ISFINITE2(val) isfinite(val)
|
|
|
|
#define ISFINITE2L(val) isfinite(val)
|
|
|
|
|
|
|
|
#define ISFINITE(suff,val) TOKENPASTE(ISFINITE2,suff)(val)
|
|
|
|
|
|
|
|
|
|
|
|
#if defined(GFC_REAL_16_IS_FLOAT128)
|
|
|
|
#define SIGNBIT2Q(val) signbitq(val)
|
|
|
|
#endif
|
|
|
|
#define SIGNBIT2(val) signbit(val)
|
|
|
|
#define SIGNBIT2L(val) signbit(val)
|
|
|
|
|
|
|
|
#define SIGNBIT(suff,val) TOKENPASTE(SIGNBIT2,suff)(val)
|
|
|
|
|
|
|
|
|
|
|
|
#if defined(GFC_REAL_16_IS_FLOAT128)
|
|
|
|
#define ISNAN2Q(val) isnanq(val)
|
|
|
|
#endif
|
|
|
|
#define ISNAN2(val) isnan(val)
|
|
|
|
#define ISNAN2L(val) isnan(val)
|
|
|
|
|
|
|
|
#define ISNAN(suff,val) TOKENPASTE(ISNAN2,suff)(val)
|
|
|
|
|
|
|
|
|
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
/* Generate corresponding I/O format for FMT_G and output.
|
|
|
|
The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
|
|
|
|
LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
|
|
|
|
|
|
|
|
Data Magnitude Equivalent Conversion
|
|
|
|
0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
|
|
|
|
m = 0 F(w-n).(d-1), n' '
|
|
|
|
0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
|
|
|
|
1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
|
|
|
|
10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
|
|
|
|
................ ..........
|
|
|
|
10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
|
|
|
|
m >= 10**d-0.5 Ew.d[Ee]
|
|
|
|
|
|
|
|
notes: for Gw.d , n' ' means 4 blanks
|
2011-04-18 05:48:25 +02:00
|
|
|
for Gw.dEe, n' ' means e+2 blanks
|
2011-04-20 06:18:25 +02:00
|
|
|
for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2
|
|
|
|
the asm volatile is required for 32-bit x86 platforms. */
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
#define OUTPUT_FLOAT_FMT_G(x,y) \
|
2007-09-05 02:51:18 +02:00
|
|
|
static void \
|
|
|
|
output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
|
|
|
|
GFC_REAL_ ## x m, char *buffer, size_t size, \
|
2012-03-15 16:14:43 +01:00
|
|
|
int sign_bit, bool zero_flag, int comp_d) \
|
2007-09-05 02:51:18 +02:00
|
|
|
{ \
|
|
|
|
int e = f->u.real.e;\
|
|
|
|
int d = f->u.real.d;\
|
|
|
|
int w = f->u.real.w;\
|
2012-03-15 16:14:43 +01:00
|
|
|
fnode newf;\
|
2011-04-18 05:48:25 +02:00
|
|
|
GFC_REAL_ ## x rexp_d, r = 0.5;\
|
2007-09-05 02:51:18 +02:00
|
|
|
int low, high, mid;\
|
|
|
|
int ubound, lbound;\
|
2011-01-27 03:16:18 +01:00
|
|
|
char *p, pad = ' ';\
|
2007-09-05 02:51:18 +02:00
|
|
|
int save_scale_factor, nb = 0;\
|
2013-03-19 12:13:32 +01:00
|
|
|
bool result;\
|
2012-03-15 16:14:43 +01:00
|
|
|
int nprinted, precision;\
|
2007-09-05 02:51:18 +02:00
|
|
|
\
|
|
|
|
save_scale_factor = dtp->u.p.scale_factor;\
|
2011-04-18 05:48:25 +02:00
|
|
|
\
|
|
|
|
switch (dtp->u.p.current_unit->round_status)\
|
|
|
|
{\
|
|
|
|
case ROUND_ZERO:\
|
2011-04-20 06:18:25 +02:00
|
|
|
r = sign_bit ? 1.0 : 0.0;\
|
2011-04-18 05:48:25 +02:00
|
|
|
break;\
|
|
|
|
case ROUND_UP:\
|
|
|
|
r = 1.0;\
|
|
|
|
break;\
|
|
|
|
case ROUND_DOWN:\
|
|
|
|
r = 0.0;\
|
|
|
|
break;\
|
|
|
|
default:\
|
|
|
|
break;\
|
|
|
|
}\
|
2007-09-05 02:51:18 +02:00
|
|
|
\
|
2009-05-20 02:16:38 +02:00
|
|
|
rexp_d = calculate_exp_ ## x (-d);\
|
2011-04-18 05:48:25 +02:00
|
|
|
if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\
|
|
|
|
|| ((m == 0.0) && !(compile_options.allow_std\
|
|
|
|
& (GFC_STD_F2003 | GFC_STD_F2008))))\
|
2007-09-05 02:51:18 +02:00
|
|
|
{ \
|
2012-03-15 16:14:43 +01:00
|
|
|
newf.format = FMT_E;\
|
|
|
|
newf.u.real.w = w;\
|
|
|
|
newf.u.real.d = d - comp_d;\
|
|
|
|
newf.u.real.e = e;\
|
2007-09-05 02:51:18 +02:00
|
|
|
nb = 0;\
|
2012-03-15 16:14:43 +01:00
|
|
|
precision = determine_precision (dtp, &newf, x);\
|
|
|
|
nprinted = DTOA(y,precision,m); \
|
2007-09-05 02:51:18 +02:00
|
|
|
goto finish;\
|
|
|
|
}\
|
|
|
|
\
|
|
|
|
mid = 0;\
|
|
|
|
low = 0;\
|
|
|
|
high = d + 1;\
|
|
|
|
lbound = 0;\
|
|
|
|
ubound = d + 1;\
|
|
|
|
\
|
|
|
|
while (low <= high)\
|
|
|
|
{ \
|
2011-04-29 16:56:02 +02:00
|
|
|
volatile GFC_REAL_ ## x temp;\
|
2007-09-05 02:51:18 +02:00
|
|
|
mid = (low + high) / 2;\
|
|
|
|
\
|
2011-04-18 05:48:25 +02:00
|
|
|
temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\
|
2007-09-05 02:51:18 +02:00
|
|
|
\
|
|
|
|
if (m < temp)\
|
|
|
|
{ \
|
|
|
|
ubound = mid;\
|
|
|
|
if (ubound == lbound + 1)\
|
|
|
|
break;\
|
|
|
|
high = mid - 1;\
|
|
|
|
}\
|
|
|
|
else if (m > temp)\
|
|
|
|
{ \
|
|
|
|
lbound = mid;\
|
|
|
|
if (ubound == lbound + 1)\
|
|
|
|
{ \
|
|
|
|
mid ++;\
|
|
|
|
break;\
|
|
|
|
}\
|
|
|
|
low = mid + 1;\
|
|
|
|
}\
|
|
|
|
else\
|
2008-11-21 05:29:54 +01:00
|
|
|
{\
|
|
|
|
mid++;\
|
|
|
|
break;\
|
|
|
|
}\
|
2007-09-05 02:51:18 +02:00
|
|
|
}\
|
|
|
|
\
|
2011-04-29 16:56:02 +02:00
|
|
|
nb = e <= 0 ? 4 : e + 2;\
|
|
|
|
nb = nb >= w ? w - 1 : nb;\
|
2012-03-15 16:14:43 +01:00
|
|
|
newf.format = FMT_F;\
|
|
|
|
newf.u.real.w = w - nb;\
|
|
|
|
newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
|
2007-09-05 02:51:18 +02:00
|
|
|
dtp->u.p.scale_factor = 0;\
|
2012-03-15 16:14:43 +01:00
|
|
|
precision = determine_precision (dtp, &newf, x); \
|
|
|
|
nprinted = FDTOA(y,precision,m); \
|
2007-09-05 02:51:18 +02:00
|
|
|
\
|
|
|
|
finish:\
|
2012-03-15 16:14:43 +01:00
|
|
|
result = output_float (dtp, &newf, buffer, size, nprinted, precision,\
|
|
|
|
sign_bit, zero_flag);\
|
2007-09-05 02:51:18 +02:00
|
|
|
dtp->u.p.scale_factor = save_scale_factor;\
|
|
|
|
\
|
|
|
|
\
|
2008-12-21 22:23:52 +01:00
|
|
|
if (nb > 0 && !dtp->u.p.g0_no_blanks)\
|
2010-07-19 15:11:54 +02:00
|
|
|
{\
|
2007-09-05 02:51:18 +02:00
|
|
|
p = write_block (dtp, nb);\
|
|
|
|
if (p == NULL)\
|
|
|
|
return;\
|
2013-03-19 12:13:32 +01:00
|
|
|
if (!result)\
|
2011-01-27 03:16:18 +01:00
|
|
|
pad = '*';\
|
2010-07-13 04:12:08 +02:00
|
|
|
if (unlikely (is_char4_unit (dtp)))\
|
2010-07-19 15:11:54 +02:00
|
|
|
{\
|
|
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;\
|
2011-01-27 03:16:18 +01:00
|
|
|
memset4 (p4, pad, nb);\
|
2010-07-19 15:11:54 +02:00
|
|
|
}\
|
2011-04-29 16:56:02 +02:00
|
|
|
else \
|
2011-01-27 03:16:18 +01:00
|
|
|
memset (p, pad, nb);\
|
2007-09-05 02:51:18 +02:00
|
|
|
}\
|
|
|
|
}\
|
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
OUTPUT_FLOAT_FMT_G(4,)
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
OUTPUT_FLOAT_FMT_G(8,)
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
#ifdef HAVE_GFC_REAL_10
|
2012-03-15 16:14:43 +01:00
|
|
|
OUTPUT_FLOAT_FMT_G(10,L)
|
2007-09-05 02:51:18 +02:00
|
|
|
#endif
|
|
|
|
|
|
|
|
#ifdef HAVE_GFC_REAL_16
|
2012-03-15 16:14:43 +01:00
|
|
|
# ifdef GFC_REAL_16_IS_FLOAT128
|
|
|
|
OUTPUT_FLOAT_FMT_G(16,Q)
|
|
|
|
#else
|
|
|
|
OUTPUT_FLOAT_FMT_G(16,L)
|
|
|
|
#endif
|
2007-09-05 02:51:18 +02:00
|
|
|
#endif
|
|
|
|
|
|
|
|
#undef OUTPUT_FLOAT_FMT_G
|
|
|
|
|
2008-07-21 06:44:10 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
/* EN format is tricky since the number of significant digits depends
|
|
|
|
on the magnitude. Solve it by first printing a temporary value and
|
|
|
|
figure out the number of significant digits from the printed
|
|
|
|
exponent. */
|
2008-07-21 06:44:10 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
#define EN_PREC(x,y)\
|
|
|
|
{\
|
|
|
|
GFC_REAL_ ## x tmp; \
|
|
|
|
tmp = * (GFC_REAL_ ## x *)source; \
|
re PR libfortran/57496 (I/O: WRITE(*,*) HUGE(0._10) gives SIGFPE with -ffpe-trap=overflow)
2013-06-01 Tobias Burnus <burnus@net-b.de>
PR fortran/57496
* io/write_float.def (ISFINITE2Q, ISFINITE2, ISFINITE2L,
* ISFINITE,
SIGNBIT2Q, SIGNBIT2, SIGNBIT2L, SIGNBIT, ISNAN2Q, ISNAN2,
ISNAN2L, ISNAN): New macros.
(output_float_FMT_G_,WRITE_FLOAT): Use them.
From-SVN: r199598
2013-06-03 11:20:46 +02:00
|
|
|
if (ISFINITE (y,tmp)) \
|
2012-03-15 16:14:43 +01:00
|
|
|
nprinted = DTOA(y,0,tmp); \
|
|
|
|
else\
|
|
|
|
nprinted = -1;\
|
|
|
|
}\
|
2008-07-21 06:44:10 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
static int
|
|
|
|
determine_en_precision (st_parameter_dt *dtp, const fnode *f,
|
|
|
|
const char *source, int len)
|
|
|
|
{
|
|
|
|
int nprinted;
|
|
|
|
char buffer[10];
|
|
|
|
const size_t size = 10;
|
2008-07-21 06:44:10 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
switch (len)
|
|
|
|
{
|
|
|
|
case 4:
|
|
|
|
EN_PREC(4,)
|
|
|
|
break;
|
2008-07-21 06:44:10 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
case 8:
|
|
|
|
EN_PREC(8,)
|
|
|
|
break;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
#ifdef HAVE_GFC_REAL_10
|
|
|
|
case 10:
|
|
|
|
EN_PREC(10,L)
|
|
|
|
break;
|
|
|
|
#endif
|
|
|
|
#ifdef HAVE_GFC_REAL_16
|
|
|
|
case 16:
|
|
|
|
# ifdef GFC_REAL_16_IS_FLOAT128
|
|
|
|
EN_PREC(16,Q)
|
|
|
|
# else
|
|
|
|
EN_PREC(16,L)
|
|
|
|
# endif
|
|
|
|
break;
|
|
|
|
#endif
|
|
|
|
default:
|
|
|
|
internal_error (NULL, "bad real kind");
|
|
|
|
}
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
if (nprinted == -1)
|
|
|
|
return -1;
|
2007-09-05 02:51:18 +02:00
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
int e = atoi (&buffer[5]);
|
|
|
|
int nbefore; /* digits before decimal point - 1. */
|
|
|
|
if (e >= 0)
|
|
|
|
nbefore = e % 3;
|
|
|
|
else
|
|
|
|
{
|
|
|
|
nbefore = (-e) % 3;
|
|
|
|
if (nbefore != 0)
|
|
|
|
nbefore = 3 - nbefore;
|
|
|
|
}
|
|
|
|
int prec = f->u.real.d + nbefore;
|
|
|
|
if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
|
|
|
|
&& dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
|
|
|
|
prec += 2 * len + 4;
|
|
|
|
return prec;
|
|
|
|
}
|
|
|
|
|
2010-11-16 22:23:19 +01:00
|
|
|
|
2007-09-05 02:51:18 +02:00
|
|
|
#define WRITE_FLOAT(x,y)\
|
|
|
|
{\
|
|
|
|
GFC_REAL_ ## x tmp;\
|
|
|
|
tmp = * (GFC_REAL_ ## x *)source;\
|
re PR libfortran/57496 (I/O: WRITE(*,*) HUGE(0._10) gives SIGFPE with -ffpe-trap=overflow)
2013-06-01 Tobias Burnus <burnus@net-b.de>
PR fortran/57496
* io/write_float.def (ISFINITE2Q, ISFINITE2, ISFINITE2L,
* ISFINITE,
SIGNBIT2Q, SIGNBIT2, SIGNBIT2L, SIGNBIT, ISNAN2Q, ISNAN2,
ISNAN2L, ISNAN): New macros.
(output_float_FMT_G_,WRITE_FLOAT): Use them.
From-SVN: r199598
2013-06-03 11:20:46 +02:00
|
|
|
sign_bit = SIGNBIT (y,tmp);\
|
|
|
|
if (!ISFINITE (y,tmp))\
|
2007-09-05 02:51:18 +02:00
|
|
|
{ \
|
re PR libfortran/57496 (I/O: WRITE(*,*) HUGE(0._10) gives SIGFPE with -ffpe-trap=overflow)
2013-06-01 Tobias Burnus <burnus@net-b.de>
PR fortran/57496
* io/write_float.def (ISFINITE2Q, ISFINITE2, ISFINITE2L,
* ISFINITE,
SIGNBIT2Q, SIGNBIT2, SIGNBIT2L, SIGNBIT, ISNAN2Q, ISNAN2,
ISNAN2L, ISNAN): New macros.
(output_float_FMT_G_,WRITE_FLOAT): Use them.
From-SVN: r199598
2013-06-03 11:20:46 +02:00
|
|
|
write_infnan (dtp, f, ISNAN (y,tmp), sign_bit);\
|
2007-09-05 02:51:18 +02:00
|
|
|
return;\
|
|
|
|
}\
|
|
|
|
tmp = sign_bit ? -tmp : tmp;\
|
|
|
|
zero_flag = (tmp == 0.0);\
|
2012-03-15 16:14:43 +01:00
|
|
|
if (f->format == FMT_G)\
|
2007-09-05 02:51:18 +02:00
|
|
|
output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
|
2012-03-15 16:14:43 +01:00
|
|
|
zero_flag, comp_d);\
|
|
|
|
else\
|
|
|
|
{\
|
|
|
|
if (f->format == FMT_F)\
|
|
|
|
nprinted = FDTOA(y,precision,tmp); \
|
|
|
|
else\
|
|
|
|
nprinted = DTOA(y,precision,tmp); \
|
|
|
|
output_float (dtp, f, buffer, size, nprinted, precision,\
|
|
|
|
sign_bit, zero_flag);\
|
|
|
|
}\
|
2007-09-05 02:51:18 +02:00
|
|
|
}\
|
|
|
|
|
|
|
|
/* Output a real number according to its format. */
|
|
|
|
|
|
|
|
static void
|
2011-04-29 16:56:02 +02:00
|
|
|
write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \
|
|
|
|
int len, int comp_d)
|
2007-09-05 02:51:18 +02:00
|
|
|
{
|
2012-03-15 16:14:43 +01:00
|
|
|
int sign_bit, nprinted;
|
|
|
|
int precision; /* Precision for snprintf call. */
|
2007-09-05 02:51:18 +02:00
|
|
|
bool zero_flag;
|
|
|
|
|
2012-03-15 16:14:43 +01:00
|
|
|
if (f->format != FMT_EN)
|
|
|
|
precision = determine_precision (dtp, f, len);
|
|
|
|
else
|
|
|
|
precision = determine_en_precision (dtp, f, source, len);
|
|
|
|
|
|
|
|
/* 4932 is the maximum exponent of long double and quad precision, 3
|
|
|
|
extra characters for the sign, the decimal point, and the
|
|
|
|
trailing null, and finally some extra digits depending on the
|
|
|
|
requested precision. */
|
|
|
|
const size_t size = 4932 + 3 + precision;
|
|
|
|
char buffer[size];
|
2007-09-05 02:51:18 +02:00
|
|
|
|
|
|
|
switch (len)
|
|
|
|
{
|
|
|
|
case 4:
|
|
|
|
WRITE_FLOAT(4,)
|
|
|
|
break;
|
|
|
|
|
|
|
|
case 8:
|
|
|
|
WRITE_FLOAT(8,)
|
|
|
|
break;
|
|
|
|
|
|
|
|
#ifdef HAVE_GFC_REAL_10
|
|
|
|
case 10:
|
|
|
|
WRITE_FLOAT(10,L)
|
|
|
|
break;
|
|
|
|
#endif
|
|
|
|
#ifdef HAVE_GFC_REAL_16
|
|
|
|
case 16:
|
2010-11-16 22:23:19 +01:00
|
|
|
# ifdef GFC_REAL_16_IS_FLOAT128
|
|
|
|
WRITE_FLOAT(16,Q)
|
|
|
|
# else
|
2007-09-05 02:51:18 +02:00
|
|
|
WRITE_FLOAT(16,L)
|
2010-11-16 22:23:19 +01:00
|
|
|
# endif
|
2007-09-05 02:51:18 +02:00
|
|
|
break;
|
|
|
|
#endif
|
|
|
|
default:
|
|
|
|
internal_error (NULL, "bad real kind");
|
|
|
|
}
|
|
|
|
}
|