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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@104276
138bc75d-0d04-0410-961f-
82ee72b054a4
+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
CHARACTER (advance);
CHARACTER (name);
CHARACTER (internal_unit);
+ gfc_array_char *internal_unit_desc;
CHARACTER (sequential);
CHARACTER (direct);
CHARACTER (formatted);
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);
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)
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)
static void
next_record_r (void)
{
- int rlength, length;
+ int rlength, length, bytes_left;
gfc_offset new;
char *p;
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);
next_record_w (void)
{
gfc_offset c, m;
- int length;
+ int length, bytes_left;
char *p;
/* Zero counters for X- and T-editing. */
break;
case FORMATTED_SEQUENTIAL:
+
+ 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;
+ length = 2;
#else
- length = 1;
+ length = 1;
#endif
- p = salloc_w (current_unit->s, &length);
-
- if (!is_internal_unit())
- {
+ p = salloc_w (current_unit->s, &length);
if (p)
{ /* No new line for internal writes. */
#ifdef HAVE_CRLF
goto io_error;
}
- if (sfree (current_unit->s) == FAILURE)
- goto io_error;
-
break;
io_error:
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. */
{
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 */
}
-/* 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)
}
+/* 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 */
#include <stdio.h>
#include <sys/stat.h>
#include <fcntl.h>
+#include <assert.h>
#ifdef HAVE_SYS_MMAN_H
#include <sys/mman.h>
{
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);
ERROR_BAD_US,
ERROR_READ_VALUE,
ERROR_READ_OVERFLOW,
+ ERROR_ARRAY_STRIDE,
ERROR_LAST /* Not a real error, the last error # + 1. */
}
error_codes;
p = "Numeric overflow on read";
break;
+ case ERROR_ARRAY_STRIDE:
+ p = "Array unit stride must be 1";
+ break;
+
default:
p = "Unknown error code";
break;
projects / platform / upstream / linaro-gcc.git / commitdiff