mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-04 09:14:04 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

PR fortran/25829 28655

Browse Source 
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
This commit is contained in:
Jerry DeLisle 2008-04-05 22:18:03 +00:00
parent 3d3e20df36
commit 10256cbe95
13 changed files with 519 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
libgfortran/ChangeLog
View File

@ -1,3 +1,42 @@
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.
2008-03-28 Thomas Koenig <tkoenig@gcc.gnu.org> 2008-03-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32972 PR libfortran/32972

1
libgfortran/gfortran.map
View File

@ -1037,6 +1037,7 @@ GFORTRAN_1.1 {
_gfortran_erfc_scaled_r8; _gfortran_erfc_scaled_r8;
_gfortran_erfc_scaled_r10; _gfortran_erfc_scaled_r10;
_gfortran_erfc_scaled_r16; _gfortran_erfc_scaled_r16;
_gfortran_st_wait;
} GFORTRAN_1.0; } GFORTRAN_1.0;
F2C_1.0 { F2C_1.0 {

24
libgfortran/io/format.c
View File

@ -1,6 +1,7 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -395,7 +396,6 @@ format_lex (format_data *fmt)
unget_char (fmt); unget_char (fmt);
break; break;
} }
break; break;
case 'G': case 'G':
@ -415,7 +415,19 @@ format_lex (format_data *fmt)
break; break;
case 'D': case 'D':
token = FMT_D; switch (next_char (fmt, 0))
{
case 'P':
token = FMT_DP;
break;
case 'C':
token = FMT_DC;
break;
default:
token = FMT_D;
unget_char (fmt);
break;
}
break; break;
case -1: case -1:
@ -550,6 +562,11 @@ parse_format_list (st_parameter_dt *dtp)
tail->repeat = 1; tail->repeat = 1;
goto optional_comma; goto optional_comma;
case FMT_DC:
case FMT_DP:
notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
"descriptor not allowed");
/* Fall through. */
case FMT_S: case FMT_S:
case FMT_SS: case FMT_SS:
case FMT_SP: case FMT_SP:
@ -576,6 +593,7 @@ parse_format_list (st_parameter_dt *dtp)
notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor"); notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
goto between_desc; goto between_desc;
case FMT_T: case FMT_T:
case FMT_TL: case FMT_TL:
case FMT_TR: case FMT_TR:

96
libgfortran/io/io.h
View File

@ -1,6 +1,7 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -44,7 +45,6 @@ typedef enum
} }
bt; bt;
struct st_parameter_dt; struct st_parameter_dt;
typedef struct stream typedef struct stream
@ -61,6 +61,9 @@ typedef struct stream
} }
stream; stream;
typedef enum
{ SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC }
io_mode;
/* Macros for doing file I/O given a stream. */ /* Macros for doing file I/O given a stream. */
@ -204,6 +207,25 @@ typedef enum
{ PAD_YES, PAD_NO, PAD_UNSPECIFIED } { PAD_YES, PAD_NO, PAD_UNSPECIFIED }
unit_pad; unit_pad;
typedef enum
{ DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
unit_decimal;
typedef enum
{ ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
unit_encoding;
typedef enum
{ ROUND_UP, ROUND_DOWN, ROUND_ZERO, ROUND_NEAREST, ROUND_COMPATIBLE,
ROUND_PROCDEFINED, ROUND_UNSPECIFIED }
unit_round;
/* NOTE: unit_sign must correspond with the sign_status enumerator in
st_parameter_dt to not break the ABI. */
typedef enum
{ SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
unit_sign;
typedef enum typedef enum
{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED } { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
unit_advance; unit_advance;
@ -212,6 +234,10 @@ typedef enum
{READING, WRITING} {READING, WRITING}
unit_mode; unit_mode;
typedef enum
{ ASYNC_YES, ASYNC_NO, AYSYNC_UNSPECIFIED }
unit_async;
#define CHARACTER1(name) \ #define CHARACTER1(name) \
char * name; \ char * name; \
gfc_charlen_type name ## _len gfc_charlen_type name ## _len
@ -233,6 +259,11 @@ typedef struct
CHARACTER1 (delim); CHARACTER1 (delim);
CHARACTER2 (pad); CHARACTER2 (pad);
CHARACTER1 (convert); CHARACTER1 (convert);
CHARACTER2 (decimal);
CHARACTER1 (encoding);
CHARACTER2 (round);
CHARACTER1 (sign);
CHARACTER2 (asynchronous);
} }
st_parameter_open; st_parameter_open;
@ -275,6 +306,16 @@ st_parameter_filepos;
#define IOPARM_INQUIRE_HAS_WRITE (1 << 28) #define IOPARM_INQUIRE_HAS_WRITE (1 << 28)
#define IOPARM_INQUIRE_HAS_READWRITE (1 << 29) #define IOPARM_INQUIRE_HAS_READWRITE (1 << 29)
#define IOPARM_INQUIRE_HAS_CONVERT (1 << 30) #define IOPARM_INQUIRE_HAS_CONVERT (1 << 30)
#define IOPARM_INQUIRE_HAS_FLAGS2 (1 << 31)
#define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
#define IOPARM_INQUIRE_HAS_DECIMAL (1 << 1)
#define IOPARM_INQUIRE_HAS_ENCODING (1 << 2)
#define IOPARM_INQUIRE_HAS_PENDING (1 << 3)
#define IOPARM_INQUIRE_HAS_ROUND (1 << 4)
#define IOPARM_INQUIRE_HAS_SIGN (1 << 5)
#define IOPARM_INQUIRE_HAS_SIZE (1 << 6)
#define IOPARM_INQUIRE_HAS_ID (1 << 7)
typedef struct typedef struct
{ {
@ -299,6 +340,15 @@ typedef struct
CHARACTER1 (write); CHARACTER1 (write);
CHARACTER2 (readwrite); CHARACTER2 (readwrite);
CHARACTER1 (convert); CHARACTER1 (convert);
GFC_INTEGER_4 flags2;
CHARACTER1 (asynchronous);
CHARACTER1 (decimal);
CHARACTER1 (encoding);
CHARACTER1 (pending);
CHARACTER1 (round);
CHARACTER1 (sign);
GFC_INTEGER_4 *size;
GFC_IO_INT id;
} }
st_parameter_inquire; st_parameter_inquire;
@ -314,6 +364,15 @@ struct format_data;
#define IOPARM_DT_HAS_ADVANCE (1 << 13) #define IOPARM_DT_HAS_ADVANCE (1 << 13)
#define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14) #define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
#define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15) #define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
#define IOPARM_DT_HAS_ID (1 << 16)
#define IOPARM_DT_HAS_POS (1 << 17)
#define IOPARM_DT_HAS_ASYNCHRONOUS (1 << 18)
#define IOPARM_DT_HAS_BLANK (1 << 19)
#define IOPARM_DT_HAS_DECIMAL (1 << 20)
#define IOPARM_DT_HAS_DELIM (1 << 21)
#define IOPARM_DT_HAS_PAD (1 << 22)
#define IOPARM_DT_HAS_ROUND (1 << 23)
#define IOPARM_DT_HAS_SIGN (1 << 24)
/* Internal use bit. */ /* Internal use bit. */
#define IOPARM_DT_IONML_SET (1 << 31) #define IOPARM_DT_IONML_SET (1 << 31)
@ -327,6 +386,15 @@ typedef struct st_parameter_dt
CHARACTER2 (advance); CHARACTER2 (advance);
CHARACTER1 (internal_unit); CHARACTER1 (internal_unit);
CHARACTER2 (namelist_name); CHARACTER2 (namelist_name);
GFC_IO_INT *id;
GFC_IO_INT pos;
CHARACTER1 (asynchronous);
CHARACTER2 (blank);
CHARACTER1 (decimal);
CHARACTER2 (delim);
CHARACTER1 (pad);
CHARACTER2 (round);
CHARACTER1 (sign);
/* Private part of the structure. The compiler just needs /* Private part of the structure. The compiler just needs
to reserve enough space. */ to reserve enough space. */
union union
@ -341,7 +409,7 @@ typedef struct st_parameter_dt
int item_count; int item_count;
unit_mode mode; unit_mode mode;
unit_blank blank_status; unit_blank blank_status;
enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status; enum { SIGN_S, SIGN_SS, SIGN_SP } sign_status;
int scale_factor; int scale_factor;
int max_pos; /* Maximum righthand column written to. */ int max_pos; /* Maximum righthand column written to. */
/* Number of skips + spaces to be done for T and X-editing. */ /* Number of skips + spaces to be done for T and X-editing. */
@ -354,6 +422,7 @@ typedef struct st_parameter_dt
2 if an EOR was encountered due to a 2-bytes marker (CRLF) */ 2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
int sf_seen_eor; int sf_seen_eor;
unit_advance advance_status; unit_advance advance_status;
unit_decimal decimal_status;
unsigned reversion_flag : 1; /* Format reversion has occurred. */ unsigned reversion_flag : 1; /* Format reversion has occurred. */
unsigned first_item : 1; unsigned first_item : 1;
@ -422,6 +491,16 @@ extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad)
>= sizeof (((st_parameter_dt *) 0)->u.p) >= sizeof (((st_parameter_dt *) 0)->u.p)
? 1 : -1]; ? 1 : -1];
#define IOPARM_WAIT_HAS_ID (1 << 7)
typedef struct
{
st_parameter_common common;
CHARACTER1 (id);
}
st_parameter_wait;
#undef CHARACTER1 #undef CHARACTER1
#undef CHARACTER2 #undef CHARACTER2
@ -436,8 +515,13 @@ typedef struct
unit_position position; unit_position position;
unit_status status; unit_status status;
unit_pad pad; unit_pad pad;
unit_decimal decimal;
unit_encoding encoding;
unit_round round;
unit_sign sign;
unit_convert convert; unit_convert convert;
int has_recl; int has_recl;
unit_async async;
} }
unit_flags; unit_flags;
@ -504,7 +588,8 @@ typedef enum
FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL, FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F, FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
FMT_DP
} }
format_token; format_token;
@ -748,6 +833,9 @@ internal_proto(next_record);
extern void reverse_memcpy (void *, const void *, size_t); extern void reverse_memcpy (void *, const void *, size_t);
internal_proto (reverse_memcpy); internal_proto (reverse_memcpy);
extern void st_wait (st_parameter_wait *);
export_proto(st_wait);
/* read.c */ /* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int); extern void set_integer (void *, GFC_INTEGER_LARGEST, int);

39
libgfortran/io/list_read.c
View File

@ -1,6 +1,8 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Namelist input contributed by Paul Thomas Namelist input contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -52,12 +54,12 @@ Boston, MA 02110-1301, USA. */
case '5': case '6': case '7': case '8': case '9' case '5': case '6': case '7': case '8': case '9'
#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \ #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
case '\r' case '\r': case ';'
/* This macro assumes that we're operating on a variable. */ /* This macro assumes that we're operating on a variable. */
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \ #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
|| c == '\t' || c == '\r') || c == '\t' || c == '\r' || c == ';')
/* Maximum repeat count. Less than ten times the maximum signed int32. */ /* Maximum repeat count. Less than ten times the maximum signed int32. */
@ -323,6 +325,13 @@ eat_separator (st_parameter_dt *dtp)
switch (c) switch (c)
{ {
case ',': case ',':
if (dtp->u.p.decimal_status == DECIMAL_COMMA)
{
unget_char (dtp, c);
break;
}
/* Fall through. */
case ';':
dtp->u.p.comma_flag = 1; dtp->u.p.comma_flag = 1;
eat_spaces (dtp); eat_spaces (dtp);
break; break;
@ -666,6 +675,7 @@ read_logical (st_parameter_dt *dtp, int length)
unget_char (dtp, c); unget_char (dtp, c);
break; break;
case '.': case '.':
c = tolower (next_char (dtp)); c = tolower (next_char (dtp));
switch (c) switch (c)
@ -1115,6 +1125,9 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
c = next_char (dtp); c = next_char (dtp);
} }
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
if (!isdigit (c) && c != '.') if (!isdigit (c) && c != '.')
{ {
if (c == 'i' || c == 'I' || c == 'n' || c == 'N') if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
@ -1130,6 +1143,8 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
for (;;) for (;;)
{ {
c = next_char (dtp); c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c) switch (c)
{ {
CASE_DIGITS: CASE_DIGITS:
@ -1299,7 +1314,8 @@ eol_1:
else else
unget_char (dtp, c); unget_char (dtp, c);
if (next_char (dtp) != ',') if (next_char (dtp)
!= (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex; goto bad_complex;
eol_2: eol_2:
@ -1353,6 +1369,8 @@ read_real (st_parameter_dt *dtp, int length)
seen_dp = 0; seen_dp = 0;
c = next_char (dtp); c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c) switch (c)
{ {
CASE_DIGITS: CASE_DIGITS:
@ -1388,6 +1406,8 @@ read_real (st_parameter_dt *dtp, int length)
for (;;) for (;;)
{ {
c = next_char (dtp); c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c) switch (c)
{ {
CASE_DIGITS: CASE_DIGITS:
@ -1395,8 +1415,8 @@ read_real (st_parameter_dt *dtp, int length)
break; break;
case '.': case '.':
if (seen_dp) if (seen_dp)
goto bad_real; goto bad_real;
seen_dp = 1; seen_dp = 1;
push_char (dtp, c); push_char (dtp, c);
@ -1420,7 +1440,7 @@ read_real (st_parameter_dt *dtp, int length)
goto got_repeat; goto got_repeat;
CASE_SEPARATORS: CASE_SEPARATORS:
if (c != '\n' && c != ',' && c != '\r') if (c != '\n' && c != ',' && c != '\r' && c != ';')
unget_char (dtp, c); unget_char (dtp, c);
goto done; goto done;
@ -1452,6 +1472,9 @@ read_real (st_parameter_dt *dtp, int length)
c = next_char (dtp); c = next_char (dtp);
} }
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
if (!isdigit (c) && c != '.') if (!isdigit (c) && c != '.')
{ {
if (c == 'i' || c == 'I' || c == 'n' || c == 'N') if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
@ -1474,6 +1497,8 @@ read_real (st_parameter_dt *dtp, int length)
for (;;) for (;;)
{ {
c = next_char (dtp); c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c) switch (c)
{ {
CASE_DIGITS: CASE_DIGITS:

142
libgfortran/io/open.c
View File

@ -1,6 +1,7 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2007 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -97,6 +98,39 @@ static const st_option pad_opt[] =
{ NULL, 0} { NULL, 0}
}; };
static const st_option decimal_opt[] =
{
{ "point", DECIMAL_POINT},
{ "comma", DECIMAL_COMMA},
{ NULL, 0}
};
static const st_option encoding_opt[] =
{
{ "utf-8", ENCODING_UTF8},
{ "default", ENCODING_DEFAULT},
{ NULL, 0}
};
static const st_option round_opt[] =
{
{ "up", ROUND_UP},
{ "down", ROUND_DOWN},
{ "zero", ROUND_ZERO},
{ "nearest", ROUND_NEAREST},
{ "compatible", ROUND_COMPATIBLE},
{ "processor_defined", ROUND_PROCDEFINED},
{ NULL, 0}
};
static const st_option sign_opt[] =
{
{ "plus", SIGN_PLUS},
{ "suppress", SIGN_SUPPRESS},
{ "processor_defined", SIGN_PROCDEFINED},
{ NULL, 0}
};
static const st_option convert_opt[] = static const st_option convert_opt[] =
{ {
{ "native", GFC_CONVERT_NATIVE}, { "native", GFC_CONVERT_NATIVE},
@ -106,6 +140,12 @@ static const st_option convert_opt[] =
{ NULL, 0} { NULL, 0}
}; };
static const st_option async_opt[] =
{
{ "yes", ASYNC_YES},
{ "no", ASYNC_NO},
{ NULL, 0}
};
/* Given a unit, test to see if the file is positioned at the terminal /* Given a unit, test to see if the file is positioned at the terminal
point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE. point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
@ -179,6 +219,26 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in " "PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
if (flags->decimal != DECIMAL_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DECIMAL parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->encoding != ENCODING_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ENCODING parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->round != ROUND_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ROUND parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->sign != SIGN_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"SIGN parameter conflicts with UNFORMATTED form in "
"OPEN statement");
} }
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
@ -190,6 +250,14 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
u->flags.delim = flags->delim; u->flags.delim = flags->delim;
if (flags->pad != PAD_UNSPECIFIED) if (flags->pad != PAD_UNSPECIFIED)
u->flags.pad = flags->pad; u->flags.pad = flags->pad;
if (flags->decimal != DECIMAL_UNSPECIFIED)
u->flags.decimal = flags->decimal;
if (flags->encoding != ENCODING_UNSPECIFIED)
u->flags.encoding = flags->encoding;
if (flags->round != ROUND_UNSPECIFIED)
u->flags.round = flags->round;
if (flags->sign != SIGN_UNSPECIFIED)
u->flags.sign = flags->sign;
} }
/* Reposition the file if necessary. */ /* Reposition the file if necessary. */
@ -289,6 +357,62 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
} }
} }
if (flags->decimal == DECIMAL_UNSPECIFIED)
flags->decimal = DECIMAL_POINT;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DECIMAL parameter conflicts with UNFORMATTED form "
"in OPEN statement");
goto fail;
}
}
if (flags->encoding == ENCODING_UNSPECIFIED)
flags->encoding = ENCODING_DEFAULT;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ENCODING parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
/* NB: the value for ROUND when it's not specified by the user does not
have to be PROCESSOR_DEFINED; the standard says that it is
processor dependent, and requires that it is one of the
possible value (see F2003, 9.4.5.13). */
if (flags->round == ROUND_UNSPECIFIED)
flags->round = ROUND_PROCDEFINED;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ROUND parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->sign == SIGN_UNSPECIFIED)
flags->sign = SIGN_PROCDEFINED;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"SIGN parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT) if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{ {
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
@ -607,6 +731,22 @@ st_open (st_parameter_open *opp)
find_option (&opp->common, opp->pad, opp->pad_len, find_option (&opp->common, opp->pad, opp->pad_len,
pad_opt, "Bad PAD parameter in OPEN statement"); pad_opt, "Bad PAD parameter in OPEN statement");
flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&opp->common, opp->decimal, opp->decimal_len,
decimal_opt, "Bad DECIMAL parameter in OPEN statement");
flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
find_option (&opp->common, opp->encoding, opp->encoding_len,
encoding_opt, "Bad ENCODING parameter in OPEN statement");
flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
find_option (&opp->common, opp->round, opp->round_len,
round_opt, "Bad ROUND parameter in OPEN statement");
flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&opp->common, opp->sign, opp->sign_len,
sign_opt, "Bad SIGN parameter in OPEN statement");
flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED : flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
find_option (&opp->common, opp->form, opp->form_len, find_option (&opp->common, opp->form, opp->form_len,
form_opt, "Bad FORM parameter in OPEN statement"); form_opt, "Bad FORM parameter in OPEN statement");

12
libgfortran/io/read.c
View File

@ -1,5 +1,6 @@
/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2005, 2007, 2008 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -246,7 +247,8 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
dtp->u.p.sf_read_comma = 0; dtp->u.p.sf_read_comma = 0;
source = read_block (dtp, &w); source = read_block (dtp, &w);
dtp->u.p.sf_read_comma = 1; dtp->u.p.sf_read_comma =
dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
if (source == NULL) if (source == NULL)
return; return;
if (w > length) if (w > length)
@ -601,7 +603,7 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
/* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D') /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
is required at this point */ is required at this point */
if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D' if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
&& *p != 'e' && *p != 'E') && *p != 'e' && *p != 'E')
goto bad_float; goto bad_float;
@ -614,6 +616,10 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{ {
switch (*p) switch (*p)
{ {
case ',':
if (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ',')
*p = '.';
/* Fall through */
case '.': case '.':
if (seen_dp) if (seen_dp)
goto bad_float; goto bad_float;

101
libgfortran/io/transfer.c
View File

@ -1,7 +1,8 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas Namelist transfer functions contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -93,6 +94,26 @@ static const st_option advance_opt[] = {
}; };
static const st_option decimal_opt[] = {
{"point", DECIMAL_POINT},
{"comma", DECIMAL_COMMA},
{NULL, 0}
};
static const st_option sign_opt[] = {
{"plus", SIGN_SP},
{"suppress", SIGN_SS},
{"processor_defined", SIGN_S},
{NULL, 0}
};
static const st_option blank_opt[] = {
{"null", BLANK_NULL},
{"zero", BLANK_ZERO},
{NULL, 0}
};
typedef enum typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@ -910,7 +931,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
/* Set this flag so that commas in reads cause the read to complete before /* Set this flag so that commas in reads cause the read to complete before
the entire field has been read. The next read field will start right after the entire field has been read. The next read field will start right after
the comma in the stream. (Set to 0 for character reads). */ the comma in the stream. (Set to 0 for character reads). */
dtp->u.p.sf_read_comma = 1; dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.line_buffer = scratch; dtp->u.p.line_buffer = scratch;
for (;;) for (;;)
@ -923,7 +944,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
next_record (dtp, 0); next_record (dtp, 0);
} }
consume_data_flag = 1 ; consume_data_flag = 1;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break; break;
@ -1162,7 +1183,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
break; break;
case FMT_STRING: case FMT_STRING:
consume_data_flag = 0 ; consume_data_flag = 0;
if (dtp->u.p.mode == READING) if (dtp->u.p.mode == READING)
{ {
format_error (dtp, f, "Constant string in input format"); format_error (dtp, f, "Constant string in input format");
@ -1278,17 +1299,17 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
break; break;
case FMT_S: case FMT_S:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_S; dtp->u.p.sign_status = SIGN_S;
break; break;
case FMT_SS: case FMT_SS:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SS; dtp->u.p.sign_status = SIGN_SS;
break; break;
case FMT_SP: case FMT_SP:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SP; dtp->u.p.sign_status = SIGN_SP;
break; break;
@ -1298,22 +1319,32 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
break; break;
case FMT_BZ: case FMT_BZ:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.blank_status = BLANK_ZERO; dtp->u.p.blank_status = BLANK_ZERO;
break; break;
case FMT_DC:
consume_data_flag = 0;
dtp->u.p.decimal_status = DECIMAL_COMMA;
break;
case FMT_DP:
consume_data_flag = 0;
dtp->u.p.decimal_status = DECIMAL_POINT;
break;
case FMT_P: case FMT_P:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.scale_factor = f->u.k; dtp->u.p.scale_factor = f->u.k;
break; break;
case FMT_DOLLAR: case FMT_DOLLAR:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.seen_dollar = 1; dtp->u.p.seen_dollar = 1;
break; break;
case FMT_SLASH: case FMT_SLASH:
consume_data_flag = 0 ; consume_data_flag = 0;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0; dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
next_record (dtp, 0); next_record (dtp, 0);
break; break;
@ -1323,7 +1354,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
particular preventing another / descriptor from being particular preventing another / descriptor from being
processed) unless there is another data item to be processed) unless there is another data item to be
transferred. */ transferred. */
consume_data_flag = 0 ; consume_data_flag = 0;
if (n == 0) if (n == 0)
return; return;
break; break;
@ -1769,6 +1800,10 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
u_flags.delim = DELIM_UNSPECIFIED; u_flags.delim = DELIM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED; u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED; u_flags.pad = PAD_UNSPECIFIED;
u_flags.decimal = DECIMAL_UNSPECIFIED;
u_flags.encoding = ENCODING_UNSPECIFIED;
u_flags.round = ROUND_UNSPECIFIED;
u_flags.sign = SIGN_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN; u_flags.status = STATUS_UNKNOWN;
conv = get_unformatted_convert (dtp->common.unit); conv = get_unformatted_convert (dtp->common.unit);
@ -1958,6 +1993,35 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED) if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
dtp->u.p.advance_status = ADVANCE_YES; dtp->u.p.advance_status = ADVANCE_YES;
/* Check the decimal mode. */
dtp->u.p.decimal_status
= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&dtp->common, dtp->decimal, dtp->decimal_len, decimal_opt,
"Bad DECIMAL parameter in data transfer statement");
if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
/* Check the sign mode. */
dtp->u.p.sign_status
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
/* Check the blank mode. */
dtp->u.p.blank_status
= !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&dtp->common, dtp->blank, dtp->blank_len, blank_opt,
"Bad BLANK parameter in data transfer statement");
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
/* Sanity checks on the record number. */ /* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0) if ((cf & IOPARM_DT_HAS_REC) != 0)
{ {
@ -2023,11 +2087,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
dtp->u.p.current_unit->mode = dtp->u.p.mode; dtp->u.p.current_unit->mode = dtp->u.p.mode;
/* Set the initial value of flags. */
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
dtp->u.p.sign_status = SIGN_S;
/* Set the maximum position reached from the previous I/O operation. This /* Set the maximum position reached from the previous I/O operation. This
could be greater than zero from a previous non-advancing write. */ could be greater than zero from a previous non-advancing write. */
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos; dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
@ -2926,6 +2985,14 @@ st_write_done (st_parameter_dt *dtp)
library_end (); library_end ();
} }
/* F2003: This is a stub for the runtime portion of the WAIT statement. */
void
st_wait (st_parameter_wait *wtp __attribute__((unused)))
{
}
/* Receives the scalar information for namelist objects and stores it /* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */ in a linked list of namelist_info types. */

17
libgfortran/io/unit.c
View File

@ -1,5 +1,6 @@
/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2005, 2007, 2008 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -430,6 +431,7 @@ get_internal_unit (st_parameter_dt *dtp)
iunit->maxrec=0; iunit->maxrec=0;
iunit->current_record=0; iunit->current_record=0;
iunit->read_bad = 0; iunit->read_bad = 0;
iunit->endfile = NO_ENDFILE;
/* Set flags for the internal unit. */ /* Set flags for the internal unit. */
@ -438,7 +440,9 @@ get_internal_unit (st_parameter_dt *dtp)
iunit->flags.form = FORM_FORMATTED; iunit->flags.form = FORM_FORMATTED;
iunit->flags.pad = PAD_YES; iunit->flags.pad = PAD_YES;
iunit->flags.status = STATUS_UNSPECIFIED; iunit->flags.status = STATUS_UNSPECIFIED;
iunit->endfile = NO_ENDFILE; iunit->flags.sign = SIGN_SUPPRESS;
iunit->flags.decimal = DECIMAL_POINT;
iunit->flags.encoding = ENCODING_DEFAULT;
/* Initialize the data transfer parameters. */ /* Initialize the data transfer parameters. */
@ -524,6 +528,9 @@ init_units (void)
u->flags.blank = BLANK_NULL; u->flags.blank = BLANK_NULL;
u->flags.pad = PAD_YES; u->flags.pad = PAD_YES;
u->flags.position = POSITION_ASIS; u->flags.position = POSITION_ASIS;
u->flags.sign = SIGN_SUPPRESS;
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
u->recl = options.default_recl; u->recl = options.default_recl;
u->endfile = NO_ENDFILE; u->endfile = NO_ENDFILE;
@ -547,6 +554,9 @@ init_units (void)
u->flags.status = STATUS_OLD; u->flags.status = STATUS_OLD;
u->flags.blank = BLANK_NULL; u->flags.blank = BLANK_NULL;
u->flags.position = POSITION_ASIS; u->flags.position = POSITION_ASIS;
u->flags.sign = SIGN_SUPPRESS;
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
u->recl = options.default_recl; u->recl = options.default_recl;
u->endfile = AT_ENDFILE; u->endfile = AT_ENDFILE;
@ -570,6 +580,9 @@ init_units (void)
u->flags.status = STATUS_OLD; u->flags.status = STATUS_OLD;
u->flags.blank = BLANK_NULL; u->flags.blank = BLANK_NULL;
u->flags.position = POSITION_ASIS; u->flags.position = POSITION_ASIS;
u->flags.sign = SIGN_SUPPRESS;
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
u->recl = options.default_recl; u->recl = options.default_recl;
u->endfile = AT_ENDFILE; u->endfile = AT_ENDFILE;

85
libgfortran/io/unix.c
View File

@ -1,6 +1,7 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -93,8 +94,6 @@ id_from_fd (const int fd)
#endif #endif
#ifndef SSIZE_MAX #ifndef SSIZE_MAX
#define SSIZE_MAX SHRT_MAX #define SSIZE_MAX SHRT_MAX
#endif #endif
@ -153,7 +152,7 @@ typedef struct
int special_file; /* =1 if the fd refers to a special file */ int special_file; /* =1 if the fd refers to a special file */
int unbuffered; /* =1 if the stream is not buffered */ io_mode method; /* Method of stream I/O being used */
char *buffer; char *buffer;
char small_buffer[BUFFER_SIZE]; char small_buffer[BUFFER_SIZE];
@ -184,7 +183,7 @@ typedef struct
int special_file; /* =1 if the fd refers to a special file */ int special_file; /* =1 if the fd refers to a special file */
int unbuffered; /* =1 if the stream is not buffered */ io_mode method; /* Method of stream I/O being used */
char *buffer; char *buffer;
} }
@ -238,15 +237,15 @@ move_pos_offset (stream* st, int pos_off)
str->logical_offset += pos_off; str->logical_offset += pos_off;
if (str->dirty_offset + str->ndirty > str->logical_offset) if (str->dirty_offset + str->ndirty > str->logical_offset)
{ {
if (str->ndirty + pos_off > 0) if (str->ndirty + pos_off > 0)
str->ndirty += pos_off; str->ndirty += pos_off;
else else
{ {
str->dirty_offset += pos_off + pos_off; str->dirty_offset += pos_off + pos_off;
str->ndirty = 0; str->ndirty = 0;
} }
} }
return pos_off; return pos_off;
} }
@ -615,23 +614,23 @@ fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
|| where > s->dirty_offset + s->ndirty || where > s->dirty_offset + s->ndirty
|| s->dirty_offset > where + *len) || s->dirty_offset > where + *len)
{ /* Discontiguous blocks, start with a clean buffer. */ { /* Discontiguous blocks, start with a clean buffer. */
/* Flush the buffer. */ /* Flush the buffer. */
if (s->ndirty != 0) if (s->ndirty != 0)
fd_flush (s); fd_flush (s);
s->dirty_offset = where; s->dirty_offset = where;
s->ndirty = *len; s->ndirty = *len;
} }
else else
{ {
gfc_offset start; /* Merge with the existing data. */ gfc_offset start; /* Merge with the existing data. */
if (where < s->dirty_offset) if (where < s->dirty_offset)
start = where; start = where;
else else
start = s->dirty_offset; start = s->dirty_offset;
if (where + *len > s->dirty_offset + s->ndirty) if (where + *len > s->dirty_offset + s->ndirty)
s->ndirty = where + *len - start; s->ndirty = where + *len - start;
else else
s->ndirty = s->dirty_offset + s->ndirty - start; s->ndirty = s->dirty_offset + s->ndirty - start;
s->dirty_offset = start; s->dirty_offset = start;
} }
@ -655,7 +654,7 @@ fd_sfree (unix_stream * s)
{ {
if (s->ndirty != 0 && if (s->ndirty != 0 &&
(s->buffer != s->small_buffer || options.all_unbuffered || (s->buffer != s->small_buffer || options.all_unbuffered ||
s->unbuffered)) s->method == SYNC_UNBUFFERED))
return fd_flush (s); return fd_flush (s);
return SUCCESS; return SUCCESS;
@ -777,7 +776,7 @@ fd_read (unix_stream * s, void * buf, size_t * nbytes)
void *p; void *p;
int tmp, status; int tmp, status;
if (*nbytes < BUFFER_SIZE && !s->unbuffered) if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
{ {
tmp = *nbytes; tmp = *nbytes;
p = fd_alloc_r_at (s, &tmp, -1); p = fd_alloc_r_at (s, &tmp, -1);
@ -825,7 +824,7 @@ fd_write (unix_stream * s, const void * buf, size_t * nbytes)
void *p; void *p;
int tmp, status; int tmp, status;
if (*nbytes < BUFFER_SIZE && !s->unbuffered) if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
{ {
tmp = *nbytes; tmp = *nbytes;
p = fd_alloc_w_at (s, &tmp, -1); p = fd_alloc_w_at (s, &tmp, -1);
@ -874,7 +873,7 @@ fd_close (unix_stream * s)
if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO) if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO)
{ {
if (close (s->fd) < 0) if (close (s->fd) < 0)
return FAILURE; return FAILURE;
} }
free_mem (s); free_mem (s);
@ -887,7 +886,9 @@ static void
fd_open (unix_stream * s) fd_open (unix_stream * s)
{ {
if (isatty (s->fd)) if (isatty (s->fd))
s->unbuffered = 1; s->method = SYNC_UNBUFFERED;
else
s->method = SYNC_BUFFERED;
s->st.alloc_r_at = (void *) fd_alloc_r_at; s->st.alloc_r_at = (void *) fd_alloc_r_at;
s->st.alloc_w_at = (void *) fd_alloc_w_at; s->st.alloc_w_at = (void *) fd_alloc_w_at;
@ -1224,7 +1225,7 @@ tempfile (st_parameter_open *opp)
do do
#if defined(HAVE_CRLF) && defined(O_BINARY) #if defined(HAVE_CRLF) && defined(O_BINARY)
fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY, fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
S_IREAD | S_IWRITE); S_IREAD | S_IWRITE);
#else #else
fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE); fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
#endif #endif
@ -1335,11 +1336,11 @@ regular_file (st_parameter_open *opp, unit_flags *flags)
if (fd >=0) if (fd >=0)
{ {
flags->action = ACTION_READ; flags->action = ACTION_READ;
return fd; /* success */ return fd; /* success */
} }
if (errno != EACCES) if (errno != EACCES)
return fd; /* failure */ return fd; /* failure */
/* retry for write-only access */ /* retry for write-only access */
rwflag = O_WRONLY; rwflag = O_WRONLY;
@ -1347,9 +1348,9 @@ regular_file (st_parameter_open *opp, unit_flags *flags)
if (fd >=0) if (fd >=0)
{ {
flags->action = ACTION_WRITE; flags->action = ACTION_WRITE;
return fd; /* success */ return fd; /* success */
} }
return fd; /* failure */ return fd; /* failure */
} }
@ -1366,7 +1367,7 @@ open_external (st_parameter_open *opp, unit_flags *flags)
{ {
fd = tempfile (opp); fd = tempfile (opp);
if (flags->action == ACTION_UNSPECIFIED) if (flags->action == ACTION_UNSPECIFIED)
flags->action = ACTION_READWRITE; flags->action = ACTION_READWRITE;
#if HAVE_UNLINK_OPEN_FILE #if HAVE_UNLINK_OPEN_FILE
/* We can unlink scratch files now and it will go away when closed. */ /* We can unlink scratch files now and it will go away when closed. */
@ -1431,7 +1432,7 @@ output_stream (void)
s = fd_to_stream (STDOUT_FILENO, PROT_WRITE); s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
if (options.unbuffered_preconnected) if (options.unbuffered_preconnected)
((unix_stream *) s)->unbuffered = 1; ((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s; return s;
} }
@ -1450,7 +1451,7 @@ error_stream (void)
s = fd_to_stream (STDERR_FILENO, PROT_WRITE); s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
if (options.unbuffered_preconnected) if (options.unbuffered_preconnected)
((unix_stream *) s)->unbuffered = 1; ((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s; return s;
} }
@ -2050,13 +2051,13 @@ stream_offset (stream *s)
the solution used by f2c. Each record contains a pair of length the solution used by f2c. Each record contains a pair of length
markers: markers:
Length of record n in bytes Length of record n in bytes
Data of record n Data of record n
Length of record n in bytes Length of record n in bytes
Length of record n+1 in bytes Length of record n+1 in bytes
Data of record n+1 Data of record n+1
Length of record n+1 in bytes Length of record n+1 in bytes
The length is stored at the end of a record to allow backspacing to the The length is stored at the end of a record to allow backspacing to the
previous record. Between data transfer statements, the file pointer previous record. Between data transfer statements, the file pointer

29
libgfortran/io/write.c
View File

@ -1,6 +1,8 @@
/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Namelist output contributed by Paul Thomas Namelist output contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -361,7 +363,7 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
if (n < 0) if (n < 0)
n = -n; n = -n;
nsign = sign == SIGN_NONE ? 0 : 1; nsign = sign == S_NONE ? 0 : 1;
q = conv (n, itoa_buf, sizeof (itoa_buf)); q = conv (n, itoa_buf, sizeof (itoa_buf));
digits = strlen (q); digits = strlen (q);
@ -395,13 +397,13 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
switch (sign) switch (sign)
{ {
case SIGN_PLUS: case S_PLUS:
*p++ = '+'; *p++ = '+';
break; break;
case SIGN_MINUS: case S_MINUS:
*p++ = '-'; *p++ = '-';
break; break;
case SIGN_NONE: case S_NONE:
break; break;
} }
@ -729,11 +731,13 @@ write_real (st_parameter_dt *dtp, const char *source, int length)
static void static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size) write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{ {
char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
if (write_char (dtp, '(')) if (write_char (dtp, '('))
return; return;
write_real (dtp, source, kind); write_real (dtp, source, kind);
if (write_char (dtp, ',')) if (write_char (dtp, semi_comma))
return; return;
write_real (dtp, source + size / 2, kind); write_real (dtp, source + size / 2, kind);
@ -869,6 +873,11 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
size_t base_var_name_len; size_t base_var_name_len;
size_t tot_len; size_t tot_len;
unit_delim tmp_delim; unit_delim tmp_delim;
/* Set the character to be used to separate values
to a comma or semi-colon. */
char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
/* Write namelist variable names in upper case. If a derived type, /* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */ nothing is output. If a component, base and base_name are set. */
@ -1075,12 +1084,12 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
internal_error (&dtp->common, "Bad type for namelist write"); internal_error (&dtp->common, "Bad type for namelist write");
} }
/* Reset the leading blank suppression, write a comma and, if 5 /* Reset the leading blank suppression, write a comma (or semi-colon)
values have been output, write a newline and advance to column and, if 5 values have been output, write a newline and advance
2. Reset the repeat counter. */ to column 2. Reset the repeat counter. */
dtp->u.p.no_leading_blank = 0; dtp->u.p.no_leading_blank = 0;
write_character (dtp, ",", 1); write_character (dtp, &semi_comma, 1);
if (num > 5) if (num > 5)
{ {
num = 0; num = 0;

31
libgfortran/io/write_float.def
View File

@ -1,6 +1,7 @@
/* Copyright (C) 2007 Free Software Foundation, Inc. /* Copyright (C) 2007, 2008 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Write float code factoring to this file by Jerry DeLisle Write float code factoring to this file by Jerry DeLisle
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -31,7 +32,7 @@ Boston, MA 02110-1301, USA. */
#include "config.h" #include "config.h"
typedef enum typedef enum
{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS } { S_NONE, S_MINUS, S_PLUS }
sign_t; sign_t;
/* Given a flag that indicates if a value is negative or not, return a /* Given a flag that indicates if a value is negative or not, return a
@ -40,21 +41,21 @@ sign_t;
static sign_t static sign_t
calculate_sign (st_parameter_dt *dtp, int negative_flag) calculate_sign (st_parameter_dt *dtp, int negative_flag)
{ {
sign_t s = SIGN_NONE; sign_t s = S_NONE;
if (negative_flag) if (negative_flag)
s = SIGN_MINUS; s = S_MINUS;
else else
switch (dtp->u.p.sign_status) switch (dtp->u.p.sign_status)
{ {
case SIGN_SP: case SIGN_SP: /* Show sign. */
s = SIGN_PLUS; s = S_PLUS;
break; break;
case SIGN_SS: case SIGN_SS: /* Suppress sign. */
s = SIGN_NONE; s = S_NONE;
break; break;
case SIGN_S: case SIGN_S: /* Processor defined. */
s = options.optional_plus ? SIGN_PLUS : SIGN_NONE; s = options.optional_plus ? S_PLUS : S_NONE;
break; break;
} }
@ -336,7 +337,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
/* Pick a field size if none was specified. */ /* Pick a field size if none was specified. */
if (w <= 0) if (w <= 0)
w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1); w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
/* Create the ouput buffer. */ /* Create the ouput buffer. */
out = write_block (dtp, w); out = write_block (dtp, w);
@ -362,7 +363,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
/* Work out how much padding is needed. */ /* Work out how much padding is needed. */
nblanks = w - (nbefore + nzero + nafter + edigits + 1); nblanks = w - (nbefore + nzero + nafter + edigits + 1);
if (sign != SIGN_NONE) if (sign != S_NONE)
nblanks--; nblanks--;
/* Check the value fits in the specified field width. */ /* Check the value fits in the specified field width. */
@ -390,9 +391,9 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
} }
/* Output the initial sign (if any). */ /* Output the initial sign (if any). */
if (sign == SIGN_PLUS) if (sign == S_PLUS)
*(out++) = '+'; *(out++) = '+';
else if (sign == SIGN_MINUS) else if (sign == S_MINUS)
*(out++) = '-'; *(out++) = '-';
/* Output an optional leading zero. */ /* Output an optional leading zero. */
@ -421,7 +422,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
out += nbefore; out += nbefore;
} }
/* Output the decimal point. */ /* Output the decimal point. */
*(out++) = '.'; *(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
/* Output leading zeros after the decimal point. */ /* Output leading zeros after the decimal point. */
if (nzero > 0) if (nzero > 0)

8
libgfortran/libgfortran.h
View File

@ -1,5 +1,6 @@
/* Common declarations for all of libgfortran. /* Common declarations for all of libgfortran.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>, and Contributed by Paul Brook <paul@nowt.org>, and
Andy Vaught <andy@xena.eas.asu.edu> Andy Vaught <andy@xena.eas.asu.edu>
@ -507,6 +508,11 @@ st_parameter_common;
#define IOPARM_OPEN_HAS_DELIM (1 << 15) #define IOPARM_OPEN_HAS_DELIM (1 << 15)
#define IOPARM_OPEN_HAS_PAD (1 << 16) #define IOPARM_OPEN_HAS_PAD (1 << 16)
#define IOPARM_OPEN_HAS_CONVERT (1 << 17) #define IOPARM_OPEN_HAS_CONVERT (1 << 17)
#define IOPARM_OPEN_HAS_DECIMAL (1 << 18)
#define IOPARM_OPEN_HAS_ENCODING (1 << 19)
#define IOPARM_OPEN_HAS_ROUND (1 << 20)
#define IOPARM_OPEN_HAS_SIGN (1 << 21)
#define IOPARM_OPEN_HAS_ASYNCHRONOUS (1 << 22)
/* library start function and end macro. These can be expanded if needed /* library start function and end macro. These can be expanded if needed
in the future. cmp is st_parameter_common *cmp */ in the future. cmp is st_parameter_common *cmp */