[RFC] fseek, an alternative implementation (PR22359)

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

While working on the docs last week, I learned, that the FSEEK intrinsic is 
not implemented yet. 

The FSEEK implementation of g77 takes a statement label to jump to, if an 
error occurs. Since there is no other intrinsic that takes a statement label, 
considerable effort would be necessary to implement the framework needed. As 
demand is low (one PR, no dupes, no usage of FSEEK shown by google-code 
search), it might be worthwile to implement the FSEEK intrinsic for 
completeness and replace the statement label by a status flag:

  g77:        CALL FSEEK(unit, offset, whence, *100)
  gfortran:   CALL FSEEK(unit, offset, whence, status)
              IF (status /= 0) goto 100

This is not 100% compability, but reasonable close.

Please find a preliminary patch that implements FSEEK using a status flag 
attached. Of course, this implementation (still) has the same problems with 
casting/assigning of the status flag as the other intrinsics. 

gcc/fortran:
	* 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:
	* io/intrinsics.c (fseek_i[1248]_sub): New.
	* gfortran.map (fseek_i[1248]_sub): New.

Comments are highly welcome :)

	Daniel

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 124274)
+++ gcc/fortran/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", 0, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
 	      NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
 
+  add_sym_4s ("fseek", 0, 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", 0, 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: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 124274)
+++ gcc/fortran/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: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 124274)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -2965,6 +2965,43 @@
 }
 
 
+void 
+gfc_resolve_fseek_sub (gfc_code *c)
+{
+  const char *name;
+  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 (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);
+    }
+
+  name = gfc_get_string (PREFIX ("fseek_i%d_sub"), offset->ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
 void
 gfc_resolve_ftell_sub (gfc_code *c)
 {
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 124274)
+++ gcc/fortran/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: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi	(revision 124275)
+++ gcc/fortran/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, if set to 1,
+@var{OFFSET} is taken to be relative to the current position, and if set 
+to 2 relative to the end of the file. 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 has to used, change
+@smallexample
+  CALL FSEEK(UNIT, OFFSET, WHENCE, *100)
+@end smallexample 
+to
+@smallexample
+  INTEGER :: status
+  CALL FSEEK(UNIT, OFFSET, WHENCE, status)
+  IF (status /= 0) GOTO 100
+@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: libgfortran/io/intrinsics.c
===================================================================
--- libgfortran/io/intrinsics.c	(revision 124260)
+++ libgfortran/io/intrinsics.c	(working copy)
@@ -228,7 +228,36 @@
     }
 }
 
+/* FSEEK intrinsic */
 
+#define FSEEK_SUB(kind) \
+  extern void fseek_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *, int *, int *); \
+  export_proto(fseek_i ## kind ## _sub); \
+  void \
+  fseek_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset, int * whence, int * status) \
+  { \
+    gfc_unit * u = find_unit (*unit); \
+    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 */ \
+  }
+
+FSEEK_SUB(1)
+FSEEK_SUB(2)
+FSEEK_SUB(4)
+FSEEK_SUB(8)
+
+
+
 /* FTELL intrinsic */
 
 extern size_t PREFIX(ftell) (int *);
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 124260)
+++ libgfortran/gfortran.map	(working copy)
@@ -128,6 +128,10 @@
     _gfortran_fraction_r4;
     _gfortran_fraction_r8;
     _gfortran_free;
+    _gfortran_fseek_i1_sub;
+    _gfortran_fseek_i2_sub;
+    _gfortran_fseek_i4_sub;
+    _gfortran_fseek_i8_sub;
     _gfortran_fstat_i4;
     _gfortran_fstat_i4_sub;
     _gfortran_fstat_i8;