OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR target/22539 (Internal compiler error with maximum sized array) 

gcc/fortran:
2007-05-04  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.

gcc/testsuite:
2007-05-01  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/22539
	* gfortran.dg/fseek.f90: New test.

libgfortran:
2007-05-04  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.

From-SVN: r124437
This commit is contained in:
Daniel Franke 2007-05-04 14:02:18 -04:00 committed by Daniel Franke
parent aa2bd2db03
commit dcdc26dfd5
12 changed files with 252 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View File

@ -1,3 +1,12 @@
2007-05-04 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.
2007-05-04 Tobias Burnus <burnus@net-b.de>
PR fortran/31803

38
gcc/fortran/check.c
View File

@ -2460,6 +2460,44 @@ gfc_check_fgetput (gfc_expr *c)
}
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 (kind_value_check (status, 3, 4) == FAILURE)
return FAILURE
if (scalar_check (status, 3) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
{

8
gcc/fortran/intrinsic.c
View File

@ -2313,7 +2313,8 @@ add_subroutines (void)
*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_subroutines (void)
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);

2
gcc/fortran/intrinsic.h
View File

@ -162,6 +162,7 @@ try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
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_exit (gfc_code *);
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 *);

68
gcc/fortran/intrinsic.texi
View File

@ -3966,10 +3966,31 @@ See @code{MALLOC} for an example.
@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 @@ GNU extension
Subroutine
@item @emph{Syntax}:
@item @emph{Arguments}:
@item @emph{Return value}:
@item @emph{Example}:
@item @emph{Specific names}:
@item @emph{See also}:
@uref{http://gcc.gnu.org/bugzilla/show_bug.cgi?id=19292, g77 features lacking in gfortran}
@code{CALL FSEEK(UNIT, OFFSET, WHENCE[, STATUS])}
@item @emph{Arguments}:
@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(4)}.
@end multitable
@item @emph{Example}:
@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}:
@ref{FTELL}
@end table

44
gcc/fortran/iresolve.c
View File

@ -2965,6 +2965,50 @@ gfc_resolve_fput_sub (gfc_code *c)
}
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)
{

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2007-05-04 Daniel Franke <franke.daniel@gmail.com>
PR fortran/22539
* gfortran.dg/fseek.f90: New test.
2007-05-04 Bob Wilson <bob.wilson@acm.org>
* g++.old-deja/g++.pt/static11.C: Remove xtensa-*-elf* xfail.

43
gcc/testsuite/gfortran.dg/fseek.f90 Normal file
View File

@ -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

8
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
2007-05-04 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.
2007-05-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR libfortran/31210

1
libgfortran/gfortran.map
View File

@ -128,6 +128,7 @@ GFORTRAN_1.0 {
_gfortran_fraction_r4;
_gfortran_fraction_r8;
_gfortran_free;
_gfortran_fseek_sub;
_gfortran_fstat_i4;
_gfortran_fstat_i4_sub;
_gfortran_fstat_i8;

28
libgfortran/io/intrinsics.c
View File

@ -228,6 +228,34 @@ flush_i8 (GFC_INTEGER_8 *unit)
}
}
/* 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 */

10
libgfortran/io/unix.c
View File

@ -601,10 +601,14 @@ fd_seek (unix_stream * s, gfc_offset offset)
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;
}