[patch, fortran] PR22539 implement FSEEK intrinsic

[Daniel Franke <franke dot daniel at gmail dot com>]

Follow-up to: http://gcc.gnu.org/ml/fortran/2007-04/msg00560.html

Although the patch was already more or less approved ("Do as you want"), 
here's an updated version that follows the suggestions made.

When resolving the subroutine, the offset is now converted to gfc_intio_kind, 
thus, only one library function is necessary (instead of four). Also added a 
testcase.

Thanks to everyone commenting on this!


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.
        * 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.


Regtested on i686-pc-linux-gnu, no regressions.
Ok for mainline?

Regards
	Daniel

Index: intrinsic.c
===================================================================
--- intrinsic.c	(revision 124320)
+++ 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 124274)
+++ 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 124274)
+++ 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 124274)
+++ 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 124320)
+++ intrinsic.texi	(working copy)
@@ -3966,11 +3966,31 @@
 @cindex file operation, seek
 @cindex file operation, position
 
-Not yet implemented in GNU Fortran.
-
 @table @asis
 @item @emph{Description}:
+Attempts to move @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 value unequal zero.
 
+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 +3998,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 the 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,34 @@
     }
 }
 
+/* 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);
+
+  if (status) *status = 0;
+
+  if (u == NULL || !is_seekable(u->s))
+    {
+      if (status) *status = -1; /* EBADF */
+    }
+  else if (*whence == 0)
+    sseek(u->s, *offset);                       /* SEEK_SET */
+  else if (*whence == 1)
+    sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */
+  else if (*whence == 2)
+    sseek(u->s, file_length(u->s) + *offset);   /* SEEK_END */
+  else if (status)
+    *status = -1;  /* EINVAL */
+}
+
+
+
 /* FTELL intrinsic */
 
 extern size_t PREFIX(ftell) (int *);
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()
+
+  ! set position (stay there)
+  CALL FSEEK(fd, 0, 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
+