diff options
Diffstat (limited to 'libgfortran/io')
| -rw-r--r-- | libgfortran/io/close.c | 1 | ||||
| -rw-r--r-- | libgfortran/io/fbuf.c | 4 | ||||
| -rw-r--r-- | libgfortran/io/fbuf.h | 81 | ||||
| -rw-r--r-- | libgfortran/io/file_pos.c | 2 | ||||
| -rw-r--r-- | libgfortran/io/format.c | 39 | ||||
| -rw-r--r-- | libgfortran/io/format.h | 118 | ||||
| -rw-r--r-- | libgfortran/io/inquire.c | 1 | ||||
| -rw-r--r-- | libgfortran/io/intrinsics.c | 2 | ||||
| -rw-r--r-- | libgfortran/io/io.h | 288 | ||||
| -rw-r--r-- | libgfortran/io/list_read.c | 2 | ||||
| -rw-r--r-- | libgfortran/io/open.c | 2 | ||||
| -rw-r--r-- | libgfortran/io/read.c | 1 | ||||
| -rw-r--r-- | libgfortran/io/transfer.c | 3 | ||||
| -rw-r--r-- | libgfortran/io/unit.c | 3 | ||||
| -rw-r--r-- | libgfortran/io/unix.c | 1 | ||||
| -rw-r--r-- | libgfortran/io/unix.h | 169 | ||||
| -rw-r--r-- | libgfortran/io/write.c | 265 | ||||
| -rw-r--r-- | libgfortran/io/write_float.def | 19 |
18 files changed, 670 insertions, 331 deletions
diff --git a/libgfortran/io/close.c b/libgfortran/io/close.c index 848b7c9e71a..1a4d7d16eb6 100644 --- a/libgfortran/io/close.c +++ b/libgfortran/io/close.c @@ -23,6 +23,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "unix.h" #include <limits.h> typedef enum diff --git a/libgfortran/io/fbuf.c b/libgfortran/io/fbuf.c index e1daa0d32d6..d79cf15c473 100644 --- a/libgfortran/io/fbuf.c +++ b/libgfortran/io/fbuf.c @@ -24,6 +24,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "io.h" +#include "fbuf.h" +#include "unix.h" #include <string.h> #include <stdlib.h> @@ -37,7 +39,7 @@ fbuf_init (gfc_unit * u, int len) if (len == 0) len = 512; /* Default size. */ - u->fbuf = get_mem (sizeof (fbuf)); + u->fbuf = get_mem (sizeof (struct fbuf)); u->fbuf->buf = get_mem (len); u->fbuf->len = len; u->fbuf->act = u->fbuf->pos = 0; diff --git a/libgfortran/io/fbuf.h b/libgfortran/io/fbuf.h new file mode 100644 index 00000000000..368cec28b2c --- /dev/null +++ b/libgfortran/io/fbuf.h @@ -0,0 +1,81 @@ +/* Copyright (C) 2009 + Free Software Foundation, Inc. + Contributed by Janne Blomqvist + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +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. + +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/>. */ + +#include "io.h" + +#ifndef GFOR_FBUF_H +#define GFOR_FBUF_H + + +/* Formatting buffer. This is a temporary scratch buffer used by + formatted read and writes. After every formatted I/O statement, + this buffer is flushed. This buffer is needed since not all devices + are seekable, and T or TL edit descriptors require moving backwards + in the record. However, advance='no' complicates the situation, so + the buffer must only be partially flushed from the end of the last + flush until the current position in the record. */ + +struct fbuf +{ + char *buf; /* Start of buffer. */ + int len; /* Length of buffer. */ + int act; /* Active bytes in buffer. */ + int pos; /* Current position in buffer. */ +}; + +extern void fbuf_init (gfc_unit *, int); +internal_proto(fbuf_init); + +extern void fbuf_destroy (gfc_unit *); +internal_proto(fbuf_destroy); + +extern int fbuf_reset (gfc_unit *); +internal_proto(fbuf_reset); + +extern char * fbuf_alloc (gfc_unit *, int); +internal_proto(fbuf_alloc); + +extern int fbuf_flush (gfc_unit *, unit_mode); +internal_proto(fbuf_flush); + +extern int fbuf_seek (gfc_unit *, int, int); +internal_proto(fbuf_seek); + +extern char * fbuf_read (gfc_unit *, int *); +internal_proto(fbuf_read); + +/* Never call this function, only use fbuf_getc(). */ +extern int fbuf_getc_refill (gfc_unit *); +internal_proto(fbuf_getc_refill); + +static inline int +fbuf_getc (gfc_unit * u) +{ + if (u->fbuf->pos < u->fbuf->act) + return (unsigned char) u->fbuf->buf[u->fbuf->pos++]; + return fbuf_getc_refill (u); +} + +#endif diff --git a/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c index c1690173658..f7d94996163 100644 --- a/libgfortran/io/file_pos.c +++ b/libgfortran/io/file_pos.c @@ -23,6 +23,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "fbuf.h" +#include "unix.h" #include <string.h> /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE, diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index 4ab70e8c3ad..cafea8732e4 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * interpretation during I/O statements */ #include "io.h" +#include "format.h" #include <ctype.h> #include <string.h> #include <stdbool.h> @@ -706,6 +707,13 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) goto data_desc; } + if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH + && t != FMT_POSINT) + { + fmt->error = "Comma required after P descriptor"; + goto finished; + } + fmt->saved_token = t; goto optional_comma; @@ -734,7 +742,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) goto between_desc; case FMT_STRING: - /* TODO: Find out why is is necessary to turn off format caching. */ + /* TODO: Find out why it is necessary to turn off format caching. */ saveit = false; get_fnode (fmt, &head, &tail, FMT_STRING); tail->u.string.p = fmt->string; @@ -851,19 +859,6 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) data_desc: switch (t) { - case FMT_P: - t = format_lex (fmt); - if (t == FMT_POSINT) - { - fmt->error = "Repeat count cannot follow P descriptor"; - goto finished; - } - - fmt->saved_token = t; - get_fnode (fmt, &head, &tail, FMT_P); - - goto optional_comma; - case FMT_L: t = format_lex (fmt); if (t != FMT_POSINT) @@ -940,7 +935,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) tail->u.real.d = fmt->value; break; } - if (t == FMT_F || dtp->u.p.mode == WRITING) + if (t == FMT_F && dtp->u.p.mode == WRITING) { if (u != FMT_POSINT && u != FMT_ZERO) { @@ -948,13 +943,10 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) goto finished; } } - else + else if (u != FMT_POSINT) { - if (u != FMT_POSINT) - { - fmt->error = posint_required; - goto finished; - } + fmt->error = posint_required; + goto finished; } tail->u.real.w = fmt->value; @@ -971,6 +963,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) } fmt->saved_token = t; tail->u.real.d = 0; + tail->u.real.e = -1; break; } @@ -982,11 +975,11 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok) } tail->u.real.d = fmt->value; + tail->u.real.e = -1; - if (t == FMT_D || t == FMT_F) + if (t2 == FMT_D || t2 == FMT_F) break; - tail->u.real.e = -1; /* Look for optional exponent */ t = format_lex (fmt); diff --git a/libgfortran/io/format.h b/libgfortran/io/format.h new file mode 100644 index 00000000000..c338daa1950 --- /dev/null +++ b/libgfortran/io/format.h @@ -0,0 +1,118 @@ +/* Copyright (C) 2009 + Free Software Foundation, Inc. + Contributed by Janne Blomqvist + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +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. + +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/>. */ + +#include "io.h" + +#ifndef GFOR_FORMAT_H +#define GFOR_FORMAT_H + +/* Format tokens. Only about half of these can be stored in the + format nodes. */ + +typedef enum +{ + FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, + 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_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_DC, + FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ +} +format_token; + + +/* Format nodes. A format string is converted into a tree of these + structures, which is traversed as part of a data transfer statement. */ + +struct fnode +{ + format_token format; + int repeat; + struct fnode *next; + char *source; + + union + { + struct + { + int w, d, e; + } + real; + + struct + { + int length; + char *p; + } + string; + + struct + { + int w, m; + } + integer; + + int w; + int k; + int r; + int n; + + struct fnode *child; + } + u; + + /* Members for traversing the tree during data transfer. */ + + int count; + struct fnode *current; + +}; + + +extern void parse_format (st_parameter_dt *); +internal_proto(parse_format); + +extern const fnode *next_format (st_parameter_dt *); +internal_proto(next_format); + +extern void unget_format (st_parameter_dt *, const fnode *); +internal_proto(unget_format); + +extern void format_error (st_parameter_dt *, const fnode *, const char *); +internal_proto(format_error); + +extern void free_format_data (struct format_data *); +internal_proto(free_format_data); + +extern void free_format_hash_table (gfc_unit *); +internal_proto(free_format_hash_table); + +extern void init_format_hash (st_parameter_dt *); +internal_proto(init_format_hash); + +extern void free_format_hash (st_parameter_dt *); +internal_proto(free_format_hash); + +#endif diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index 015b68a26f8..c36b9e5fa69 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see /* Implement the non-IOLENGTH variant of the INQUIRY statement */ #include "io.h" +#include "unix.h" static const char undefined[] = "UNDEFINED"; diff --git a/libgfortran/io/intrinsics.c b/libgfortran/io/intrinsics.c index 0e33e8490da..9428b759d15 100644 --- a/libgfortran/io/intrinsics.c +++ b/libgfortran/io/intrinsics.c @@ -24,6 +24,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "fbuf.h" +#include "unix.h" #ifdef HAVE_STDLIB_H #include <stdlib.h> diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 51143f548aa..b24f81026f0 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -42,63 +42,13 @@ typedef enum } bt; +/* Forward declarations. */ struct st_parameter_dt; - -typedef struct stream -{ - ssize_t (*read) (struct stream *, void *, ssize_t); - ssize_t (*write) (struct stream *, const void *, ssize_t); - off_t (*seek) (struct stream *, off_t, int); - off_t (*tell) (struct stream *); - /* Avoid keyword truncate due to AIX namespace collision. */ - int (*trunc) (struct stream *, off_t); - int (*flush) (struct stream *); - int (*close) (struct stream *); -} -stream; - -/* Inline functions for doing file I/O given a stream. */ -static inline ssize_t -sread (stream * s, void * buf, ssize_t nbyte) -{ - return s->read (s, buf, nbyte); -} - -static inline ssize_t -swrite (stream * s, const void * buf, ssize_t nbyte) -{ - return s->write (s, buf, nbyte); -} - -static inline off_t -sseek (stream * s, off_t offset, int whence) -{ - return s->seek (s, offset, whence); -} - -static inline off_t -stell (stream * s) -{ - return s->tell (s); -} - -static inline int -struncate (stream * s, off_t length) -{ - return s->trunc (s, length); -} - -static inline int -sflush (stream * s) -{ - return s->flush (s); -} - -static inline int -sclose (stream * s) -{ - return s->close (s); -} +typedef struct stream stream; +struct fbuf; +struct format_data; +typedef struct fnode fnode; +struct gfc_unit; /* Macros for testing what kinds of I/O we are doing. */ @@ -131,7 +81,7 @@ array_loop_spec; /* A stucture to build a hash table for format data. */ -#define FORMAT_HASH_SIZE 16 +#define FORMAT_HASH_SIZE 16 typedef struct format_hash_entry { @@ -386,8 +336,6 @@ typedef struct } st_parameter_inquire; -struct gfc_unit; -struct format_data; #define IOPARM_DT_LIST_FORMAT (1 << 7) #define IOPARM_DT_NAMELIST_READ_MODE (1 << 8) @@ -564,24 +512,6 @@ typedef struct unit_flags; -/* Formatting buffer. This is a temporary scratch buffer. Currently used only - by formatted writes. After every - formatted write statement, this buffer is flushed. This buffer is needed since - not all devices are seekable, and T or TL edit descriptors require - moving backwards in the record. However, advance='no' complicates the - situation, so the buffer must only be partially flushed from the end of the - last flush until the current position in the record. */ - -typedef struct fbuf -{ - char *buf; /* Start of buffer. */ - int len; /* Length of buffer. */ - int act; /* Active bytes in buffer. */ - int pos; /* Current position in buffer. */ -} -fbuf; - - typedef struct gfc_unit { int unit_number; @@ -645,152 +575,6 @@ typedef struct gfc_unit } gfc_unit; -/* Format tokens. Only about half of these can be stored in the - format nodes. */ - -typedef enum -{ - FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, - 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_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_DC, - FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ -} -format_token; - - -/* Format nodes. A format string is converted into a tree of these - structures, which is traversed as part of a data transfer statement. */ - -typedef struct fnode -{ - format_token format; - int repeat; - struct fnode *next; - char *source; - - union - { - struct - { - int w, d, e; - } - real; - - struct - { - int length; - char *p; - } - string; - - struct - { - int w, m; - } - integer; - - int w; - int k; - int r; - int n; - - struct fnode *child; - } - u; - - /* Members for traversing the tree during data transfer. */ - - int count; - struct fnode *current; - -} -fnode; - - -/* unix.c */ - -extern int compare_files (stream *, stream *); -internal_proto(compare_files); - -extern stream *open_external (st_parameter_open *, unit_flags *); -internal_proto(open_external); - -extern stream *open_internal (char *, int, gfc_offset); -internal_proto(open_internal); - -extern char * mem_alloc_w (stream *, int *); -internal_proto(mem_alloc_w); - -extern char * mem_alloc_r (stream *, int *); -internal_proto(mem_alloc_w); - -extern stream *input_stream (void); -internal_proto(input_stream); - -extern stream *output_stream (void); -internal_proto(output_stream); - -extern stream *error_stream (void); -internal_proto(error_stream); - -extern int compare_file_filename (gfc_unit *, const char *, int); -internal_proto(compare_file_filename); - -extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len); -internal_proto(find_file); - -extern int delete_file (gfc_unit *); -internal_proto(delete_file); - -extern int file_exists (const char *file, gfc_charlen_type file_len); -internal_proto(file_exists); - -extern const char *inquire_sequential (const char *, int); -internal_proto(inquire_sequential); - -extern const char *inquire_direct (const char *, int); -internal_proto(inquire_direct); - -extern const char *inquire_formatted (const char *, int); -internal_proto(inquire_formatted); - -extern const char *inquire_unformatted (const char *, int); -internal_proto(inquire_unformatted); - -extern const char *inquire_read (const char *, int); -internal_proto(inquire_read); - -extern const char *inquire_write (const char *, int); -internal_proto(inquire_write); - -extern const char *inquire_readwrite (const char *, int); -internal_proto(inquire_readwrite); - -extern gfc_offset file_length (stream *); -internal_proto(file_length); - -extern int is_seekable (stream *); -internal_proto(is_seekable); - -extern int is_special (stream *); -internal_proto(is_special); - -extern void flush_if_preconnected (stream *); -internal_proto(flush_if_preconnected); - -extern void empty_internal_buffer(stream *); -internal_proto(empty_internal_buffer); - -extern int stream_isatty (stream *); -internal_proto(stream_isatty); - -extern char * stream_ttyname (stream *); -internal_proto(stream_ttyname); - -extern int unpack_filename (char *, const char *, int); -internal_proto(unpack_filename); /* unit.c */ @@ -847,31 +631,6 @@ internal_proto(get_unique_unit_number); extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *); internal_proto(new_unit); -/* format.c */ - -extern void parse_format (st_parameter_dt *); -internal_proto(parse_format); - -extern const fnode *next_format (st_parameter_dt *); -internal_proto(next_format); - -extern void unget_format (st_parameter_dt *, const fnode *); -internal_proto(unget_format); - -extern void format_error (st_parameter_dt *, const fnode *, const char *); -internal_proto(format_error); - -extern void free_format_data (struct format_data *); -internal_proto(free_format_data); - -extern void free_format_hash_table (gfc_unit *); -internal_proto(free_format_hash_table); - -extern void init_format_hash (st_parameter_dt *); -internal_proto(init_format_hash); - -extern void free_format_hash (st_parameter_dt *); -internal_proto(free_format_hash); /* transfer.c */ @@ -1014,39 +773,6 @@ internal_proto(size_from_real_kind); extern size_t size_from_complex_kind (int); internal_proto(size_from_complex_kind); -/* fbuf.c */ -extern void fbuf_init (gfc_unit *, int); -internal_proto(fbuf_init); - -extern void fbuf_destroy (gfc_unit *); -internal_proto(fbuf_destroy); - -extern int fbuf_reset (gfc_unit *); -internal_proto(fbuf_reset); - -extern char * fbuf_alloc (gfc_unit *, int); -internal_proto(fbuf_alloc); - -extern int fbuf_flush (gfc_unit *, unit_mode); -internal_proto(fbuf_flush); - -extern int fbuf_seek (gfc_unit *, int, int); -internal_proto(fbuf_seek); - -extern char * fbuf_read (gfc_unit *, int *); -internal_proto(fbuf_read); - -/* Never call this function, only use fbuf_getc(). */ -extern int fbuf_getc_refill (gfc_unit *); -internal_proto(fbuf_getc_refill); - -static inline int -fbuf_getc (gfc_unit * u) -{ - if (u->fbuf->pos < u->fbuf->act) - return (unsigned char) u->fbuf->buf[u->fbuf->pos++]; - return fbuf_getc_refill (u); -} /* lock.c */ extern void free_ionml (st_parameter_dt *); diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index d8ad602e593..c281e34eacf 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -27,6 +27,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "io.h" +#include "fbuf.h" +#include "unix.h" #include <string.h> #include <stdlib.h> #include <ctype.h> diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index d5b4007ea23..bca21062956 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "fbuf.h" +#include "unix.h" #include <unistd.h> #include <string.h> #include <errno.h> diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index 23a8fa3019d..a5cb97a00e5 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "format.h" #include <string.h> #include <errno.h> #include <ctype.h> diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 06a1d2eb984..b5f52b1ccf3 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -29,6 +29,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see /* transfer.c -- Top level handling of data transfer statements. */ #include "io.h" +#include "fbuf.h" +#include "format.h" +#include "unix.h" #include <string.h> #include <assert.h> #include <stdlib.h> diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index 5dc3538f264..3eb66e9d26d 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "fbuf.h" +#include "format.h" +#include "unix.h" #include <stdlib.h> #include <string.h> diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 4ecba3a8f69..d385b040c9e 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see /* Unix stream I/O module */ #include "io.h" +#include "unix.h" #include <stdlib.h> #include <limits.h> diff --git a/libgfortran/io/unix.h b/libgfortran/io/unix.h new file mode 100644 index 00000000000..721c63c02e4 --- /dev/null +++ b/libgfortran/io/unix.h @@ -0,0 +1,169 @@ +/* Copyright (C) 2009 + Free Software Foundation, Inc. + Contributed by Janne Blomqvist + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +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. + +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/>. */ + +#include "io.h" + +#ifndef GFOR_UNIX_H +#define GFOR_UNIX_H + +struct stream +{ + ssize_t (*read) (struct stream *, void *, ssize_t); + ssize_t (*write) (struct stream *, const void *, ssize_t); + off_t (*seek) (struct stream *, off_t, int); + off_t (*tell) (struct stream *); + /* Avoid keyword truncate due to AIX namespace collision. */ + int (*trunc) (struct stream *, off_t); + int (*flush) (struct stream *); + int (*close) (struct stream *); +}; + +/* Inline functions for doing file I/O given a stream. */ +static inline ssize_t +sread (stream * s, void * buf, ssize_t nbyte) +{ + return s->read (s, buf, nbyte); +} + +static inline ssize_t +swrite (stream * s, const void * buf, ssize_t nbyte) +{ + return s->write (s, buf, nbyte); +} + +static inline off_t +sseek (stream * s, off_t offset, int whence) +{ + return s->seek (s, offset, whence); +} + +static inline off_t +stell (stream * s) +{ + return s->tell (s); +} + +static inline int +struncate (stream * s, off_t length) +{ + return s->trunc (s, length); +} + +static inline int +sflush (stream * s) +{ + return s->flush (s); +} + +static inline int +sclose (stream * s) +{ + return s->close (s); +} + + +extern int compare_files (stream *, stream *); +internal_proto(compare_files); + +extern stream *open_external (st_parameter_open *, unit_flags *); +internal_proto(open_external); + +extern stream *open_internal (char *, int, gfc_offset); +internal_proto(open_internal); + +extern char * mem_alloc_w (stream *, int *); +internal_proto(mem_alloc_w); + +extern char * mem_alloc_r (stream *, int *); +internal_proto(mem_alloc_w); + +extern stream *input_stream (void); +internal_proto(input_stream); + +extern stream *output_stream (void); +internal_proto(output_stream); + +extern stream *error_stream (void); +internal_proto(error_stream); + +extern int compare_file_filename (gfc_unit *, const char *, int); +internal_proto(compare_file_filename); + +extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len); +internal_proto(find_file); + +extern int delete_file (gfc_unit *); +internal_proto(delete_file); + +extern int file_exists (const char *file, gfc_charlen_type file_len); +internal_proto(file_exists); + +extern const char *inquire_sequential (const char *, int); +internal_proto(inquire_sequential); + +extern const char *inquire_direct (const char *, int); +internal_proto(inquire_direct); + +extern const char *inquire_formatted (const char *, int); +internal_proto(inquire_formatted); + +extern const char *inquire_unformatted (const char *, int); +internal_proto(inquire_unformatted); + +extern const char *inquire_read (const char *, int); +internal_proto(inquire_read); + +extern const char *inquire_write (const char *, int); +internal_proto(inquire_write); + +extern const char *inquire_readwrite (const char *, int); +internal_proto(inquire_readwrite); + +extern gfc_offset file_length (stream *); +internal_proto(file_length); + +extern int is_seekable (stream *); +internal_proto(is_seekable); + +extern int is_special (stream *); +internal_proto(is_special); + +extern void flush_if_preconnected (stream *); +internal_proto(flush_if_preconnected); + +extern void empty_internal_buffer(stream *); +internal_proto(empty_internal_buffer); + +extern int stream_isatty (stream *); +internal_proto(stream_isatty); + +extern char * stream_ttyname (stream *); +internal_proto(stream_ttyname); + +extern int unpack_filename (char *, const char *, int); +internal_proto(unpack_filename); + + +#endif diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 3c16a43b9ab..63482461cc2 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -26,6 +26,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ #include "io.h" +#include "format.h" +#include "unix.h" #include <assert.h> #include <string.h> #include <ctype.h> @@ -446,9 +448,10 @@ extract_uint (const void *p, int len) } break; #ifdef HAVE_GFC_INTEGER_16 + case 10: case 16: { - GFC_INTEGER_16 tmp; + GFC_INTEGER_16 tmp = 0; memcpy ((void *) &tmp, p, len); i = (GFC_UINTEGER_16) tmp; } @@ -482,20 +485,14 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) static void -write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len, - const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t)) +write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) { - GFC_UINTEGER_LARGEST n = 0; int w, m, digits, nzero, nblank; char *p; - const char *q; - char itoa_buf[GFC_BTOA_BUF_SIZE]; w = f->u.integer.w; m = f->u.integer.m; - n = extract_uint (source, len); - /* Special case: */ if (m == 0 && n == 0) @@ -511,7 +508,6 @@ write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len, goto done; } - q = conv (n, itoa_buf, sizeof (itoa_buf)); digits = strlen (q); /* Select a width if none was specified. The idea here is to always @@ -538,7 +534,6 @@ write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len, goto done; } - if (!dtp->u.p.no_leading_blank) { memset (p, ' ', nblank); @@ -706,6 +701,202 @@ btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) return p; } +/* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed + to convert large reals with kind sizes that exceed the largest integer type + available on certain platforms. In these cases, byte by byte conversion is + performed. Endianess is taken into account. */ + +/* Conversion to binary. */ + +static const char * +btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) +{ + char *q; + int i, j; + + q = buffer; + if (big_endian) + { + const char *p = s; + for (i = 0; i < len; i++) + { + char c = *p; + + /* Test for zero. Needed by write_boz later. */ + if (*p != 0) + *n = 1; + + for (j = 0; j < 8; j++) + { + *q++ = (c & 128) ? '1' : '0'; + c <<= 1; + } + p++; + } + } + else + { + const char *p = s + len - 1; + for (i = 0; i < len; i++) + { + char c = *p; + + /* Test for zero. Needed by write_boz later. */ + if (*p != 0) + *n = 1; + + for (j = 0; j < 8; j++) + { + *q++ = (c & 128) ? '1' : '0'; + c <<= 1; + } + p--; + } + } + + *q = '\0'; + + if (*n == 0) + return "0"; + + /* Move past any leading zeros. */ + while (*buffer == '0') + buffer++; + + return buffer; + +} + +/* Conversion to octal. */ + +static const char * +otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) +{ + char *q; + int i, j, k; + uint8_t octet; + + q = buffer + GFC_OTOA_BUF_SIZE - 1; + *q = '\0'; + i = k = octet = 0; + + if (big_endian) + { + const char *p = s + len - 1; + char c = *p; + while (i < len) + { + /* Test for zero. Needed by write_boz later. */ + if (*p != 0) + *n = 1; + + for (j = 0; j < 3 && i < len; j++) + { + octet |= (c & 1) << j; + c >>= 1; + if (++k > 7) + { + i++; + k = 0; + c = *--p; + } + } + *--q = '0' + octet; + octet = 0; + } + } + else + { + const char *p = s; + char c = *p; + while (i < len) + { + /* Test for zero. Needed by write_boz later. */ + if (*p != 0) + *n = 1; + + for (j = 0; j < 3 && i < len; j++) + { + octet |= (c & 1) << j; + c >>= 1; + if (++k > 7) + { + i++; + k = 0; + c = *++p; + } + } + *--q = '0' + octet; + octet = 0; + } + } + + if (*n == 0) + return "0"; + + /* Move past any leading zeros. */ + while (*q == '0') + q++; + + return q; +} + +/* Conversion to hexidecimal. */ + +static const char * +ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) +{ + static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'}; + + char *q; + uint8_t h, l; + int i; + + q = buffer; + + if (big_endian) + { + const char *p = s; + for (i = 0; i < len; i++) + { + /* Test for zero. Needed by write_boz later. */ + if (*p != 0) + *n = 1; + + h = (*p >> 4) & 0x0F; + l = *p++ & 0x0F; + *q++ = a[h]; + *q++ = a[l]; + } + } + else + { + const char *p = s + len - 1; + for (i = 0; i < len; i++) + { + /* Test for zero. Needed by write_boz later. */ + if (*p != 0) + *n = 1; + + h = (*p >> 4) & 0x0F; + l = *p-- & 0x0F; + *q++ = a[h]; + *q++ = a[l]; + } + } + + *q = '\0'; + + if (*n == 0) + return "0"; + + /* Move past any leading zeros. */ + while (*buffer == '0') + buffer++; + + return buffer; +} /* gfc_itoa()-- Integer to decimal conversion. The itoa function is a widespread non-standard extension to standard @@ -757,22 +948,64 @@ write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len) void -write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len) +write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len) { - write_int (dtp, f, p, len, btoa); + const char *p; + char itoa_buf[GFC_BTOA_BUF_SIZE]; + GFC_UINTEGER_LARGEST n = 0; + + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) + { + p = btoa_big (source, itoa_buf, len, &n); + write_boz (dtp, f, p, n); + } + else + { + n = extract_uint (source, len); + p = btoa (n, itoa_buf, sizeof (itoa_buf)); + write_boz (dtp, f, p, n); + } } void -write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len) +write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len) { - write_int (dtp, f, p, len, otoa); + const char *p; + char itoa_buf[GFC_OTOA_BUF_SIZE]; + GFC_UINTEGER_LARGEST n = 0; + + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) + { + p = otoa_big (source, itoa_buf, len, &n); + write_boz (dtp, f, p, n); + } + else + { + n = extract_uint (source, len); + p = otoa (n, itoa_buf, sizeof (itoa_buf)); + write_boz (dtp, f, p, n); + } } void -write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len) +write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len) { - write_int (dtp, f, p, len, gfc_xtoa); + const char *p; + char itoa_buf[GFC_XTOA_BUF_SIZE]; + GFC_UINTEGER_LARGEST n = 0; + + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) + { + p = ztoa_big (source, itoa_buf, len, &n); + write_boz (dtp, f, p, n); + } + else + { + n = extract_uint (source, len); + p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf)); + write_boz (dtp, f, p, n); + } } diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def index e6880027a86..eca0e56a5e9 100644 --- a/libgfortran/io/write_float.def +++ b/libgfortran/io/write_float.def @@ -141,6 +141,13 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, switch (ft) { case FMT_F: + if (d == 0 && e <= 0 && dtp->u.p.scale_factor == 0) + { + memmove (digits + 1, digits, ndigits - 1); + digits[0] = '0'; + e++; + } + nbefore = e + dtp->u.p.scale_factor; if (nbefore < 0) { @@ -255,7 +262,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, case ROUND_NEAREST: /* Round compatible unless there is a tie. A tie is a 5 with all trailing zero's. */ - i = nafter + 1; + i = nafter + nbefore; if (digits[i] == '5') { for(i++ ; i < ndigits; i++) @@ -264,7 +271,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, goto do_rnd; } /* It is a tie so round to even. */ - switch (digits[nafter]) + switch (digits[nafter + nbefore - 1]) { case '1': case '3': @@ -818,14 +825,6 @@ sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \ return;\ }\ tmp = sign_bit ? -tmp : tmp;\ - if (f->u.real.d == 0 && f->format == FMT_F\ - && dtp->u.p.scale_factor == 0)\ - {\ - if (tmp < 0.5)\ - tmp = 0.0;\ - else if (tmp < 1.0)\ - tmp = 1.0;\ - }\ zero_flag = (tmp == 0.0);\ \ DTOA ## y\ |