This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [patch, fortran] PR22539 implement FSEEK intrinsic
I updated the patch according to comments of Brooks Moses and Jerry DeLisle.
Due to Brooks concers, I was also able to identify a possible problem in the
function fd_seek (libgfortran/io/unix.c), where the physical and logical
offsets of the internal representation of the file were changed, regardless
of the status of lseek. The patch now include a fix for this as well. The
testcase was updated to include a seek with a resulting negative offset.
Jerry asked:
> I have not seen what happens if we try to seek a read only file past its
> current end. That would be worth checking.
Nothing much. The position is moved beyond the end. Attempting to read there
results in a "Fortran runtime error: End of file". Moving beyond the end and
back works as expected, i.e. read works without problems.
With all the changes in place and no regressions on i686-pc-linux-gnu, ok for
trunk?
gcc/fortran:
2007-05-01 Daniel Franke <franke.daniel@gmail.com>
PR fortran/22539
* intrinsic.c (add_subroutines): Added FSEEK.
* intrinsic.h (gfc_resolve_fseek_sub, gfc_check_fseek_sub): New.
* iresolve.c (gfc_resolve_fseek_sub): New.
* check.c (gfc_check_fseek_sub): New.
* intrinsic.texi (FSEEK): Updated.
libgfortran:
2007-05-01 Daniel Franke <franke.daniel@gmail.com>
PR fortran/22539
* io/intrinsics.c (fseek_sub): New.
* io/unix.c (fd_fseek): Change logical and physical offsets only
if seek succeeds.
* gfortran.map (fseek_sub): New.
gcc/testsuite:
2007-05-01 Daniel Franke <franke.daniel@gmail.com>
PR fortran/22539
* gfortran.dg/fseek.f90: New test.
Regards
Daniel
Index: intrinsic.c
===================================================================
--- intrinsic.c (revision 124379)
+++ intrinsic.c (working copy)
@@ -2313,7 +2313,8 @@
*com = "command", *length = "length", *st = "status",
*val = "value", *num = "number", *name = "name",
*trim_name = "trim_name", *ut = "unit", *han = "handler",
- *sec = "seconds", *res = "result", *of = "offset", *md = "mode";
+ *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
+ *whence = "whence";
int di, dr, dc, dl, ii;
@@ -2489,6 +2490,11 @@
add_sym_1s ("free", NOT_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
+ add_sym_4s ("fseek", NOT_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_GNU,
+ gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
+ ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, di, REQUIRED,
+ whence, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
+
add_sym_2s ("ftell", NOT_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
Index: intrinsic.h
===================================================================
--- intrinsic.h (revision 124379)
+++ intrinsic.h (working copy)
@@ -162,6 +162,7 @@
try gfc_check_etime_sub (gfc_expr *, gfc_expr *);
try gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
+try gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_ftell_sub (gfc_expr *, gfc_expr *);
try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
@@ -456,6 +457,7 @@
void gfc_resolve_fdate_sub (gfc_code *);
void gfc_resolve_flush (gfc_code *);
void gfc_resolve_free (gfc_code *);
+void gfc_resolve_fseek_sub (gfc_code *);
void gfc_resolve_fstat_sub (gfc_code *);
void gfc_resolve_ftell_sub (gfc_code *);
void gfc_resolve_fgetc_sub (gfc_code *);
Index: iresolve.c
===================================================================
--- iresolve.c (revision 124379)
+++ iresolve.c (working copy)
@@ -2965,6 +2965,50 @@
}
+void
+gfc_resolve_fseek_sub (gfc_code *c)
+{
+ gfc_expr *unit;
+ gfc_expr *offset;
+ gfc_expr *whence;
+ gfc_expr *status;
+ gfc_typespec ts;
+
+ unit = c->ext.actual->expr;
+ offset = c->ext.actual->next->expr;
+ whence = c->ext.actual->next->next->expr;
+ status = c->ext.actual->next->next->next->expr;
+
+ if (unit->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (unit, &ts, 2);
+ }
+
+ if (offset->ts.kind != gfc_intio_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_intio_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (offset, &ts, 2);
+ }
+
+ if (whence->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (whence, &ts, 2);
+ }
+
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
+}
+
void
gfc_resolve_ftell_sub (gfc_code *c)
{
Index: check.c
===================================================================
--- check.c (revision 124379)
+++ check.c (working copy)
@@ -2461,6 +2461,41 @@
try
+gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
+{
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (offset, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (offset, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (whence, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (whence, 2) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 3) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+
+try
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
Index: intrinsic.texi
===================================================================
--- intrinsic.texi (revision 124379)
+++ intrinsic.texi (working copy)
@@ -3966,11 +3966,32 @@
@cindex file operation, seek
@cindex file operation, position
-Not yet implemented in GNU Fortran.
-
@table @asis
@item @emph{Description}:
+Moves @var{UNIT} to the specified @var{OFFSET}. If @var{WHENCE}
+is set to 0, the @var{OFFSET} is taken as an absolute value @code{SEEK_SET},
+if set to 1, @var{OFFSET} is taken to be relative to the current position
+@code{SEEK_CUR}, and if set to 2 relative to the end of the file @code{SEEK_END}.
+On error, @var{STATUS} is set to a non-zero value. If @var{STATUS} the seek
+fails silently.
+This intrinsic routine is not fully backwards compatible with @command{g77}.
+In @command{g77}, the @code{FSEEK} takes a statement label instead of a
+@var{STATUS} variable. If FSEEK is used in old code, change
+@smallexample
+ CALL FSEEK(UNIT, OFFSET, WHENCE, *label)
+@end smallexample
+to
+@smallexample
+ INTEGER :: status
+ CALL FSEEK(UNIT, OFFSET, WHENCE, status)
+ IF (status /= 0) GOTO label
+@end smallexample
+
+Please note that GNU Fortran provides the Fortran 2003 Stream facility.
+Programmers should consider the use of new stream IO feature in new code
+for future portability. See also @ref{Fortran 2003 status}.
+
@item @emph{Standard}:
GNU extension
@@ -3978,13 +3999,44 @@
Subroutine
@item @emph{Syntax}:
+@code{CALL FSEEK(UNIT, OFFSET, WHENCE[, STATUS])}
+
@item @emph{Arguments}:
-@item @emph{Return value}:
+@multitable @columnfractions .15 .70
+@item @var{UNIT} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{OFFSET} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{WHENCE} @tab Shall be a scalar of type @code{INTEGER}.
+Its value shall be either 0, 1 or 2.
+@item @var{STATUS} @tab (Optional) shall be a scalar of type
+@code{INTEGER}.
+@end multitable
+
@item @emph{Example}:
-@item @emph{Specific names}:
+@smallexample
+PROGRAM test_fseek
+ INTEGER, PARAMETER :: SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2
+ INTEGER :: fd, offset, ierr
+
+ ierr = 0
+ offset = 5
+ fd = 10
+
+ OPEN(UNIT=fd, FILE="fseek.test")
+ CALL FSEEK(fd, offset, SEEK_SET, ierr) ! move to OFFSET
+ print *, FTELL(fd), ierr
+
+ CALL FSEEK(fd, 0, SEEK_END, ierr) ! move to end
+ print *, FTELL(fd), ierr
+
+ CALL FSEEK(fd, 0, SEEK_SET, ierr) ! move to beginning
+ print *, FTELL(fd), ierr
+
+ CLOSE(UNIT=fd)
+END PROGRAM
+@end smallexample
+
@item @emph{See also}:
-@uref{http://gcc.gnu.org/bugzilla/show_bug.cgi?id=19292, g77 features lacking in gfortran}
-
+@ref{FTELL}
@end table
Index: io/intrinsics.c
===================================================================
--- io/intrinsics.c (revision 124260)
+++ io/intrinsics.c (working copy)
@@ -228,7 +228,35 @@
}
}
+/* FSEEK intrinsic */
+extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
+export_proto(fseek_sub);
+
+void
+fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
+{
+ gfc_unit * u = find_unit (*unit);
+ try result = FAILURE;
+
+ if (u != NULL && is_seekable(u->s))
+ {
+ if (*whence == 0)
+ result = sseek(u->s, *offset); /* SEEK_SET */
+ else if (*whence == 1)
+ result = sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */
+ else if (*whence == 2)
+ result = sseek(u->s, file_length(u->s) + *offset); /* SEEK_END */
+
+ unlock_unit (u);
+ }
+
+ if (status)
+ *status = (result == FAILURE ? -1 : 0);
+}
+
+
+
/* FTELL intrinsic */
extern size_t PREFIX(ftell) (int *);
Index: io/unix.c
===================================================================
--- io/unix.c (revision 124260)
+++ io/unix.c (working copy)
@@ -601,10 +601,14 @@
return SUCCESS;
}
- s->physical_offset = s->logical_offset = offset;
- s->active = 0;
+ if (lseek (s->fd, offset, SEEK_SET) >= 0)
+ {
+ s->physical_offset = s->logical_offset = offset;
+ s->active = 0;
+ return SUCCESS;
+ }
- return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
+ return FAILURE;
}
Index: gfortran.map
===================================================================
--- gfortran.map (revision 124260)
+++ gfortran.map (working copy)
@@ -128,6 +128,7 @@
_gfortran_fraction_r4;
_gfortran_fraction_r8;
_gfortran_free;
+ _gfortran_fseek_sub;
_gfortran_fstat_i4;
_gfortran_fstat_i4_sub;
_gfortran_fstat_i8;
Index: gfortran.dg/fseek.f90
===================================================================
--- gfortran.dg/fseek.f90 (revision 0)
+++ gfortran.dg/fseek.f90 (revision 0)
@@ -0,0 +1,43 @@
+! { dg-do run }
+
+PROGRAM test_fseek
+ INTEGER, PARAMETER :: SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2, fd=10
+ INTEGER :: ierr = 0
+
+ ! expected position: 12, one leading blank + 10 + newline
+ WRITE(fd, *) "1234567890"
+ IF (FTELL(fd) /= 12) CALL abort()
+
+ ! move backward from current position
+ CALL FSEEK(fd, -12, SEEK_CUR, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= 0) CALL abort()
+
+ ! move to negative position (error)
+ CALL FSEEK(fd, -1, SEEK_SET, ierr)
+ IF (ierr == 0 .OR. FTELL(fd) /= 0) CALL abort()
+
+ ! move forward from end (12 + 10)
+ CALL FSEEK(fd, 10, SEEK_END, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= 22) CALL abort()
+
+ ! set position (0)
+ CALL FSEEK(fd, 0, SEEK_SET, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= 0) CALL abort()
+
+ ! move forward from current position
+ CALL FSEEK(fd, 5, SEEK_CUR, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= 5) CALL abort()
+
+ CALL FSEEK(fd, HUGE(0_1), SEEK_SET, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= HUGE(0_1)) CALL abort()
+
+ CALL FSEEK(fd, HUGE(0_2), SEEK_SET, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= HUGE(0_2)) CALL abort()
+
+ CALL FSEEK(fd, HUGE(0_4), SEEK_SET, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= HUGE(0_4)) CALL abort()
+
+ CALL FSEEK(fd, -HUGE(0_4), SEEK_CUR, ierr)
+ IF (ierr /= 0 .OR. FTELL(fd) /= 0) CALL abort()
+END PROGRAM
+