[patch, fortran/libgfortran] Fix PR22390 (FLUSH statement)
Janne Blomqvist
jblomqvi@cc.hut.fi
Sun Jul 10 21:48:00 GMT 2005
Hello,
attached patch implements the F2003 FLUSH statement. In addition to
the patch, there is also a new file libgfortran/io/file_pos.c that
combines the functionality of the file positioning statements
previously implemented as well as the new flush. Also, a simple
testcase that checks that compiling succeeds is attached.
--
Janne Blomqvist
-------------- next part --------------
gcc/fortran ChangeLog
2005-07-11 Janne Blomqvist <jblomqvi@cc.hut.fi>
PR fortran/22390
* dump-parse-tree.c (gfc_show_code_node): Add case for FLUSH.
* gfortran.h: Add enums for FLUSH.
* io.c (gfc_free_filepos): Modify comment
appropriately. (match_file_element): Likewise. (match_filepos):
Likewise. (gfc_match_flush): New function.
* match.c (gfc_match_if): Add match for flush.
* match.h: Add prototype.
* parse.c (decode_statement): Add flush to 'f'
case. (next_statement): Add case for flush. (gfc_ascii_statement):
Likewise.
* resolve.c (resolve_code): Add flush case.
* st.c (gfc_free_statement): Add flush case.
* trans-io.c: Add prototype for
flush. (gfc_build_io_library_fndecls): Build fndecl for
flush. (gfc_trans_flush): New function.
* trans-stmt.h: Add prototype.
* trans.c (gfc_trans_code): Add case for flush.
libgfortran ChangeLog
2005-07-11 Janne Blomqvist <jblomqvi@cc.hut.fi>
PR fortran/22390
* io/file_pos.c: New file, containing code for backspace, endfile,
rewind and flush.
* io/backspace.c: File removed, contents moved to io/file_pos.c.
* io/endfile.c: File removed, contents moved to io/file_pos.c.
* io/rewind.c: File removed, contents moved to io/file_pos.c.
* Makefile.am: Add file_pos.c to list, remove obsolete files.
-------------- next part --------------
Index: gcc/fortran/dump-parse-tree.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/dump-parse-tree.c,v
retrieving revision 1.18
diff -u -p -r1.18 dump-parse-tree.c
--- gcc/fortran/dump-parse-tree.c 25 Jun 2005 00:40:34 -0000 1.18
+++ gcc/fortran/dump-parse-tree.c 10 Jul 2005 21:05:55 -0000
@@ -1177,6 +1177,10 @@ gfc_show_code_node (int level, gfc_code
case EXEC_REWIND:
gfc_status ("REWIND");
+ goto show_filepos;
+
+ case EXEC_FLUSH:
+ gfc_status ("FLUSH");
show_filepos:
fp = c->ext.filepos;
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.75
diff -u -p -r1.75 gfortran.h
--- gcc/fortran/gfortran.h 7 Jul 2005 07:54:43 -0000 1.75
+++ gcc/fortran/gfortran.h 10 Jul 2005 21:05:58 -0000
@@ -193,7 +193,7 @@ typedef enum
ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
- ST_END_FILE, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE,
+ ST_END_FILE, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE,
ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE,
ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, ST_EXIT, ST_FORALL,
ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT,
@@ -1326,7 +1326,7 @@ typedef enum
EXEC_ALLOCATE, EXEC_DEALLOCATE,
EXEC_OPEN, EXEC_CLOSE,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
- EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND
+ EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH
}
gfc_exec_op;
Index: gcc/fortran/io.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/io.c,v
retrieving revision 1.28
diff -u -p -r1.28 io.c
--- gcc/fortran/io.c 7 Jul 2005 07:54:42 -0000 1.28
+++ gcc/fortran/io.c 10 Jul 2005 21:06:00 -0000
@@ -1340,7 +1340,7 @@ gfc_free_filepos (gfc_filepos * fp)
}
-/* Match elements of a REWIND, BACKSPACE or ENDFILE statement. */
+/* Match elements of a REWIND, BACKSPACE, ENDFILE or FLUSH statement. */
static match
match_file_element (gfc_filepos * fp)
@@ -1362,7 +1362,7 @@ match_file_element (gfc_filepos * fp)
/* Match the second half of the file-positioning statements, REWIND,
- BACKSPACE or ENDFILE. */
+ BACKSPACE, ENDFILE or FLUSH. */
static match
match_filepos (gfc_statement st, gfc_exec_op op)
@@ -1446,8 +1446,8 @@ gfc_resolve_filepos (gfc_filepos * fp)
}
-/* Match the file positioning statements: ENDFILE, BACKSPACE or
- REWIND. */
+/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND
+ and FLUSH. */
match
gfc_match_endfile (void)
@@ -1470,6 +1470,14 @@ gfc_match_rewind (void)
return match_filepos (ST_REWIND, EXEC_REWIND);
}
+match
+gfc_match_flush (void)
+{
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ return match_filepos (ST_FLUSH, EXEC_FLUSH);
+}
/******************** Data Transfer Statements *********************/
Index: gcc/fortran/match.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/match.c,v
retrieving revision 1.40
diff -u -p -r1.40 match.c
--- gcc/fortran/match.c 25 Jun 2005 00:40:35 -0000 1.40
+++ gcc/fortran/match.c 10 Jul 2005 21:06:03 -0000
@@ -1072,6 +1072,7 @@ gfc_match_if (gfc_statement * if_type)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
match ("exit", gfc_match_exit, ST_EXIT)
+ match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
match ("go to", gfc_match_goto, ST_GOTO)
match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
Index: gcc/fortran/match.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/match.h,v
retrieving revision 1.13
diff -u -p -r1.13 match.h
--- gcc/fortran/match.h 25 Jun 2005 00:40:35 -0000 1.13
+++ gcc/fortran/match.h 10 Jul 2005 21:06:03 -0000
@@ -154,6 +154,7 @@ match gfc_match_close (void);
match gfc_match_endfile (void);
match gfc_match_backspace (void);
match gfc_match_rewind (void);
+match gfc_match_flush (void);
match gfc_match_inquire (void);
match gfc_match_read (void);
match gfc_match_write (void);
Index: gcc/fortran/parse.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/parse.c,v
retrieving revision 1.28
diff -u -p -r1.28 parse.c
--- gcc/fortran/parse.c 25 Jun 2005 00:40:35 -0000 1.28
+++ gcc/fortran/parse.c 10 Jul 2005 21:06:06 -0000
@@ -212,6 +212,7 @@ decode_statement (void)
break;
case 'f':
+ match ("flush", gfc_match_flush, ST_FLUSH);
match ("format", gfc_match_format, ST_FORMAT);
break;
@@ -526,7 +527,8 @@ next_statement (void)
case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
- case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT
+ case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
+ case ST_LABEL_ASSIGNMENT: case ST_FLUSH
/* Statements that mark other executable statements. */
@@ -832,6 +834,9 @@ gfc_ascii_statement (gfc_statement st)
break;
case ST_EXIT:
p = "EXIT";
+ break;
+ case ST_FLUSH:
+ p = "FLUSH";
break;
case ST_FORALL_BLOCK: /* Fall through */
case ST_FORALL:
Index: gcc/fortran/resolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.45
diff -u -p -r1.45 resolve.c
--- gcc/fortran/resolve.c 25 Jun 2005 00:40:35 -0000 1.45
+++ gcc/fortran/resolve.c 10 Jul 2005 21:06:11 -0000
@@ -3948,6 +3948,7 @@ resolve_code (gfc_code * code, gfc_names
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
+ case EXEC_FLUSH:
if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
break;
Index: gcc/fortran/st.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/st.c,v
retrieving revision 1.8
diff -u -p -r1.8 st.c
--- gcc/fortran/st.c 25 Jun 2005 00:40:36 -0000 1.8
+++ gcc/fortran/st.c 10 Jul 2005 21:06:16 -0000
@@ -139,6 +139,7 @@ gfc_free_statement (gfc_code * p)
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
+ case EXEC_FLUSH:
gfc_free_filepos (p->ext.filepos);
break;
Index: gcc/fortran/trans-io.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.38
diff -u -p -r1.38 trans-io.c
--- gcc/fortran/trans-io.c 7 Jul 2005 07:54:43 -0000 1.38
+++ gcc/fortran/trans-io.c 10 Jul 2005 21:06:20 -0000
@@ -125,6 +125,7 @@ static GTY(()) tree iocall_iolength_done
static GTY(()) tree iocall_rewind;
static GTY(()) tree iocall_backspace;
static GTY(()) tree iocall_endfile;
+static GTY(()) tree iocall_flush;
static GTY(()) tree iocall_set_nml_val;
static GTY(()) tree iocall_set_nml_val_dim;
@@ -297,6 +298,11 @@ gfc_build_io_library_fndecls (void)
iocall_endfile =
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
gfc_int4_type_node, 0);
+
+ iocall_flush =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
+ gfc_int4_type_node, 0);
+
/* Library helpers */
iocall_read_done =
@@ -755,6 +761,16 @@ gfc_trans_rewind (gfc_code * code)
}
+/* Translate a FLUSH statement. */
+
+tree
+gfc_trans_flush (gfc_code * code)
+{
+
+ return build_filepos (iocall_flush, code);
+}
+
+
/* Translate the non-IOLENGTH form of an INQUIRE statement. */
Index: gcc/fortran/trans-stmt.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-stmt.h,v
retrieving revision 1.5
diff -u -p -r1.5 trans-stmt.h
--- gcc/fortran/trans-stmt.h 25 Jun 2005 00:40:36 -0000 1.5
+++ gcc/fortran/trans-stmt.h 10 Jul 2005 21:06:20 -0000
@@ -61,6 +61,7 @@ tree gfc_trans_backspace (gfc_code *);
tree gfc_trans_endfile (gfc_code *);
tree gfc_trans_inquire (gfc_code *);
tree gfc_trans_rewind (gfc_code *);
+tree gfc_trans_flush (gfc_code *);
tree gfc_trans_transfer (gfc_code *);
tree gfc_trans_dt_end (gfc_code *);
Index: gcc/fortran/trans.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans.c,v
retrieving revision 1.26
diff -u -p -r1.26 trans.c
--- gcc/fortran/trans.c 25 Jun 2005 00:40:36 -0000 1.26
+++ gcc/fortran/trans.c 10 Jul 2005 21:06:21 -0000
@@ -557,6 +557,10 @@ gfc_trans_code (gfc_code * code)
res = gfc_trans_select (code);
break;
+ case EXEC_FLUSH:
+ res = gfc_trans_flush (code);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.38
diff -u -p -r1.38 Makefile.am
--- libgfortran/Makefile.am 24 Jun 2005 23:07:13 -0000 1.38
+++ libgfortran/Makefile.am 10 Jul 2005 21:06:57 -0000
@@ -21,16 +21,15 @@ AM_CPPFLAGS = -iquote$(srcdir)/io
libgfortranincludedir = $(includedir)/gforio
gfor_io_src= \
-io/backspace.c \
io/close.c \
-io/endfile.c \
+io/file_pos.c \
io/format.c \
io/inquire.c \
io/list_read.c \
io/lock.c \
io/open.c \
io/read.c \
-io/rewind.c \
io/transfer.c \
io/unit.c \
io/unix.c \
-------------- next part --------------
/* Copyright (C) 2005 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 2, or (at your option)
any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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.
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
#include "config.h"
#include <string.h>
#include "libgfortran.h"
#include "io.h"
/* file_pos.c-- Implement the file positioning statements,
i.e. BACKSPACE, ENDFILE, REWIND and FLUSH. */
/* formatted_backspace(void)-- Move the file back one line. The
* current position is after the newline that terminates the previous
* record, and we have to sift backwards to find the newline before
* that or the start of the file, whichever comes first. */
#define READ_CHUNK 4096
static void
formatted_backspace (void)
{
gfc_offset base;
char *p;
int n;
base = file_position (current_unit->s) - 1;
do
{
n = (base < READ_CHUNK) ? base : READ_CHUNK;
base -= n;
p = salloc_r_at (current_unit->s, &n, base);
if (p == NULL)
goto io_error;
/* Because we've moved backwords from the current position, it
* should not be possible to get a short read. Because it isn't
* clear what to do about such thing, we ignore the possibility. */
/* There is no memrchr() in the C library, so we have to do it
* ourselves. */
n--;
while (n >= 0)
{
if (p[n] == '\n')
{
base += n + 1;
goto done;
}
n--;
}
}
while (base != 0);
/* base is the new pointer. Seek to it exactly */
done:
if (sseek (current_unit->s, base) == FAILURE)
goto io_error;
current_unit->last_record--;
current_unit->endfile = NO_ENDFILE;
return;
io_error:
generate_error (ERROR_OS, NULL);
}
/* unformatted_backspace()-- Move the file backwards for an
* unformatted sequential file. We are guaranteed to be between
* records on entry and we have to shift to the previous record. */
static void
unformatted_backspace (void)
{
gfc_offset m, new;
int length;
char *p;
length = sizeof (gfc_offset);
p = salloc_r_at (current_unit->s, &length,
file_position (current_unit->s) - length);
if (p == NULL)
goto io_error;
memcpy (&m, p, sizeof (gfc_offset));
new = file_position (current_unit->s) - m - 2*length;
if (sseek (current_unit->s, new) == FAILURE)
goto io_error;
current_unit->last_record--;
return;
io_error:
generate_error (ERROR_OS, NULL);
}
extern void st_backspace (void);
export_proto(st_backspace);
void
st_backspace (void)
{
gfc_unit *u;
library_start ();
u = find_unit (ioparm.unit);
if (u == NULL)
{
generate_error (ERROR_BAD_UNIT, NULL);
goto done;
}
current_unit = u;
/* Ignore direct access. Non-advancing I/O is only allowed for
* formatted sequential I/O and the next direct access transfer
* repositions the file anyway. */
if (u->flags.access == ACCESS_DIRECT)
goto done;
/* Check for special cases involving the ENDFILE record first */
if (u->endfile == AFTER_ENDFILE)
u->endfile = AT_ENDFILE;
else
{
if (file_position (u->s) == 0)
goto done; /* Common special case */
if (u->mode == WRITING)
{
flush (u->s);
struncate (u->s);
u->mode = READING;
}
if (u->flags.form == FORM_FORMATTED)
formatted_backspace ();
else
unformatted_backspace ();
u->endfile = NO_ENDFILE;
u->current_record = 0;
}
done:
library_end ();
}
extern void st_endfile (void);
export_proto(st_endfile);
void
st_endfile (void)
{
gfc_unit *u;
library_start ();
u = get_unit (0);
if (u != NULL)
{
current_unit = u; /* next_record() needs this set */
if (u->current_record)
next_record (1);
flush(u->s);
struncate (u->s);
u->endfile = AFTER_ENDFILE;
}
library_end ();
}
extern void st_rewind (void);
export_proto(st_rewind);
void
st_rewind (void)
{
gfc_unit *u;
library_start ();
u = find_unit (ioparm.unit);
if (u != NULL)
{
if (u->flags.access != ACCESS_SEQUENTIAL)
generate_error (ERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
{
/* If we have been writing to the file, the last written record
is the last record in the file, so truncate the file now.
Reset to read mode so two consecutive rewind statements
don't delete the file contents. Flush buffer when switching
mode. */
if (u->mode == WRITING)
{
flush (u->s);
struncate (u->s);
}
u->mode = READING;
u->last_record = 0;
if (sseek (u->s, 0) == FAILURE)
generate_error (ERROR_OS, NULL);
u->endfile = NO_ENDFILE;
u->current_record = 0;
test_endfile (u);
}
/* update position for INQUIRE */
u->flags.position = POSITION_REWIND;
}
library_end ();
}
extern void st_flush (void);
export_proto(st_flush);
void
st_flush (void)
{
gfc_unit *u;
library_start ();
u = get_unit (0);
if (u != NULL)
{
current_unit = u; /* Just to be sure. */
flush(u->s);
/* struncate (u->s);
u->endfile = AFTER_ENDFILE; */
}
library_end ();
}
-------------- next part --------------
! {dg-do run }
! {dg--options "--std=f2003" }
! PR 22390 Implement flush statement
program flush_1
integer :: iostatus
open (unit=10, access='SEQUENTIAL', status='SCRATCH')
write (10, *) 42
flush 10
flush (10)
flush (unit=10, iostat=iostatus)
end program flush_1
More information about the Fortran
mailing list