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

PR fortran/21875 Internal Unit Array I/O, NIST 

2005-09-14  Jerry DeLisle  <jvdelisle@verizon.net

	PR fortran/21875 Internal Unit Array I/O, NIST
	* libgfortran.h: Add run time error code for array stride.
	* runtime/error.c (translate_error): Add error message for
	array stride.
	* io/io.h: Add array descriptor pointer to IOPARM structure.
	Add prtotypes for two new functions.
	* io/transfer.c (data_transfer_init): Removed initialization and
	moved to unit.c (get_unit)
	* io/transfer.c (next_record_r): Include internal unit read
	functionality.
	* io/transfer.c (next_record_w): Include internal unit write
	functionality, including padding of character array records.
	* io/unit.c (get_array_unit_len): New function to return the number
	of records in the character array 'file' from the array descriptor.
	* io/unit.c (get_unit): Gathered initialization code from
	init_data_transfer for internal units and added initialization of
	character array unit.
	* io/unit.c (is_array_io): New function to determine if internal unit
	is an array.
	* io/unix.c (mem_alloc_w_at): Add error checks for bad record length
	and end of file.

From-SVN: r104276
This commit is contained in:
Jerry DeLisle 2005-09-14 20:18:19 +00:00 committed by Jerry DeLisle
parent 7ad00e1325
commit 59154ed24c
7 changed files with 133 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
libgfortran/ChangeLog
View File

@ -1,3 +1,27 @@
2005-09-14 Jerry DeLisle <jvdelisle@verizon.net
PR fortran/21875 Internal Unit Array I/O, NIST
* libgfortran.h: Add run time error code for array stride.
* runtime/error.c (translate_error): Add error message for
array stride.
* io/io.h: Add array descriptor pointer to IOPARM structure.
Add prtotypes for two new functions.
* io/transfer.c (data_transfer_init): Removed initialization and
moved to unit.c (get_unit)
* io/transfer.c (next_record_r): Include internal unit read
functionality.
* io/transfer.c (next_record_w): Include internal unit write
functionality, including padding of character array records.
* io/unit.c (get_array_unit_len): New function to return the number
of records in the character array 'file' from the array descriptor.
* io/unit.c (get_unit): Gathered initialization code from
init_data_transfer for internal units and added initialization of
character array unit.
* io/unit.c (is_array_io): New function to determine if internal unit
is an array.
* io/unix.c (mem_alloc_w_at): Add error checks for bad record length
and end of file.
2005-09-13 Richard Sandiford <richard@codesourcery.com>
PR target/19269

7
libgfortran/io/io.h
View File

@ -251,6 +251,7 @@ typedef struct
CHARACTER (advance);
CHARACTER (name);
CHARACTER (internal_unit);
gfc_array_char *internal_unit_desc;
CHARACTER (sequential);
CHARACTER (direct);
CHARACTER (formatted);
@ -525,6 +526,12 @@ internal_proto(close_unit);
extern int is_internal_unit (void);
internal_proto(is_internal_unit);
extern int is_array_io (void);
internal_proto(is_array_io);
extern gfc_offset get_array_unit_len (gfc_array_char *);
internal_proto(get_array_unit_len);
extern gfc_unit *find_unit (int);
internal_proto(find_unit);

71
libgfortran/io/transfer.c
View File

@ -293,13 +293,13 @@ write_block (int length)
{
char *dest;
if (!is_internal_unit() && current_unit->bytes_left < length)
if (current_unit->bytes_left < length)
{
generate_error (ERROR_EOR, NULL);
return NULL;
}
current_unit->bytes_left -= length;
current_unit->bytes_left -= (gfc_offset)length;
dest = salloc_w (current_unit->s, &length);
if (ioparm.size != NULL)
@ -1021,15 +1021,6 @@ data_transfer_init (int read_flag)
if (current_unit == NULL)
return;
if (is_internal_unit())
{
current_unit->recl = file_length(current_unit->s);
if (g.mode==WRITING)
empty_internal_buffer (current_unit->s);
else
current_unit->bytes_left = current_unit->recl;
}
/* Check the action. */
if (read_flag && current_unit->flags.action == ACTION_WRITE)
@ -1267,7 +1258,7 @@ data_transfer_init (int read_flag)
static void
next_record_r (void)
{
int rlength, length;
int rlength, length, bytes_left;
gfc_offset new;
char *p;
@ -1321,16 +1312,18 @@ next_record_r (void)
break;
}
do
if (is_internal_unit())
{
bytes_left = (int) current_unit->bytes_left;
p = salloc_r (current_unit->s, &bytes_left);
if (p != NULL)
current_unit->bytes_left = current_unit->recl;
break;
}
else do
{
p = salloc_r (current_unit->s, &length);
/* In case of internal file, there may not be any '\n'. */
if (is_internal_unit() && p == NULL)
{
break;
}
if (p == NULL)
{
generate_error (ERROR_OS, NULL);
@ -1359,7 +1352,7 @@ static void
next_record_w (void)
{
gfc_offset c, m;
int length;
int length, bytes_left;
char *p;
/* Zero counters for X- and T-editing. */
@ -1422,15 +1415,36 @@ next_record_w (void)
break;
case FORMATTED_SEQUENTIAL:
#ifdef HAVE_CRLF
length = 2;
#else
length = 1;
#endif
p = salloc_w (current_unit->s, &length);
if (!is_internal_unit())
if (current_unit->bytes_left == 0)
break;
if (is_internal_unit())
{
if (is_array_io())
{
bytes_left = (int) current_unit->bytes_left;
p = salloc_w (current_unit->s, &bytes_left);
if (p != NULL)
{
memset(p, ' ', bytes_left);
current_unit->bytes_left = current_unit->recl;
}
}
else
{
length = 1;
p = salloc_w (current_unit->s, &length);
}
}
else
{
#ifdef HAVE_CRLF
length = 2;
#else
length = 1;
#endif
p = salloc_w (current_unit->s, &length);
if (p)
{ /* No new line for internal writes. */
#ifdef HAVE_CRLF
@ -1444,9 +1458,6 @@ next_record_w (void)
goto io_error;
}
if (sfree (current_unit->s) == FAILURE)
goto io_error;
break;
io_error:

47
libgfortran/io/unit.c
View File

@ -244,6 +244,32 @@ find_unit (int n)
return p;
}
/* get_array_unit_len()-- return the number of records in the array. */
gfc_offset
get_array_unit_len (gfc_array_char *desc)
{
gfc_offset record_count;
int i, rank, stride;
rank = GFC_DESCRIPTOR_RANK(desc);
record_count = stride = 1;
for (i=0;i<rank;++i)
{
/* Check that array is contiguous */
if (desc->dim[i].stride != stride)
{
generate_error (ERROR_ARRAY_STRIDE, NULL);
return NULL;
}
stride *= desc->dim[i].ubound;
record_count *= desc->dim[i].ubound;
}
return record_count;
}
/* get_unit()-- Returns the unit structure associated with the integer
* unit or the internal file. */
@ -252,8 +278,18 @@ get_unit (int read_flag __attribute__ ((unused)))
{
if (ioparm.internal_unit != NULL)
{
internal_unit.recl = ioparm.internal_unit_len;
if (is_array_io()) ioparm.internal_unit_len *=
get_array_unit_len(ioparm.internal_unit_desc);
internal_unit.s =
open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
internal_unit.bytes_left = internal_unit.recl;
internal_unit.last_record=0;
internal_unit.maxrec=0;
internal_unit.current_record=0;
if (g.mode==WRITING && !is_array_io())
empty_internal_buffer (internal_unit.s);
/* Set flags for the internal unit */
@ -271,8 +307,7 @@ get_unit (int read_flag __attribute__ ((unused)))
}
/* is_internal_unit()-- Determine if the current unit is internal or
* not */
/* is_internal_unit()-- Determine if the current unit is internal or not */
int
is_internal_unit (void)
@ -281,6 +316,14 @@ is_internal_unit (void)
}
/* is_array_io ()-- Determine if the I/O is to/from an array */
int
is_array_io (void)
{
return (ioparm.internal_unit_desc != NULL);
}
/*************************/
/* Initialize everything */

11
libgfortran/io/unix.c
View File

@ -38,6 +38,7 @@ Boston, MA 02110-1301, USA. */
#include <stdio.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <assert.h>
#ifdef HAVE_SYS_MMAN_H
#include <sys/mman.h>
@ -618,14 +619,22 @@ mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
{
gfc_offset m;
assert (*len >= 0); /* Negative values not allowed. */
if (where == -1)
where = s->logical_offset;
m = where + *len;
if (where < s->buffer_offset || m > s->buffer_offset + s->active)
if (where < s->buffer_offset)
return NULL;
if (m > s->file_length)
{
generate_error (ERROR_END, NULL);
return NULL;
}
s->logical_offset = m;
return s->buffer + (where - s->buffer_offset);

1
libgfortran/libgfortran.h
View File

@ -344,6 +344,7 @@ typedef enum
ERROR_BAD_US,
ERROR_READ_VALUE,
ERROR_READ_OVERFLOW,
ERROR_ARRAY_STRIDE,
ERROR_LAST /* Not a real error, the last error # + 1. */
}
error_codes;

4
libgfortran/runtime/error.c
View File

@ -431,6 +431,10 @@ translate_error (int code)
p = "Numeric overflow on read";
break;
case ERROR_ARRAY_STRIDE:
p = "Array unit stride must be 1";
break;
default:
p = "Unknown error code";
break;