[patch, libgfortran] PR24224 Generalized internal array IO not implemented.
Jerry DeLisle
jvdelisle@verizon.net
Sun Oct 16 00:31:00 GMT 2005
:ADDPATCH fortran: forgot to put in patch queue.
Jerry DeLisle wrote:
> The attached patch fixes this PR. One new test case provided, revised
> test case arrayio_4.f90 to reflect the new behavior.
>
> regtested on i686.
>
> RFC I have a common block of code in next_record_r and next_record_w
> that could be placed in its own function and called. It traverses the
> elements in the array based on the array descriptor, taking into account
> for strides.
>
> I will prepare a gomp version of this after commit to mainline.
>
> OK for mainline?
>
> We never committed the original patch to 4.0 is this OK for 4.0.3 also?
> If so, I will have to back port at least one other previous patch to 4.0
> for this to work.
>
> Comments much appreciated.
>
> 2005-10-15 Jerry DeLisle <jvdelisle@verizon.net>
>
> PR libgfortran/24224
> * libgfortran.h: Remove array stride error code.
> * runtime/error.c: Remove array stride error.
> * io/io.h: Change name of 'nml_loop_spec' to 'array_loop_spec'
> to be
> generic. Add pointer to array_loop_spec to gfc_unit structure.
> * io/list_read.c: Revise nml_loop_spec references to
> array_loop_spec.
> * io/transfer.c (next_record_r): Add array looping code.
> (next_record_w): Add array looping code.
> (finalize_transfer): Free memory allocated for array_loop_spec.
> * io/unit.c (get_array_unit_len) Add initialization of
> array_loop_spec.
>
> Regards,
>
> Jerry
>
>
> ------------------------------------------------------------------------
>
> Index: libgfortran.h
> ===================================================================
> RCS file: /cvs/gcc/gcc/libgfortran/libgfortran.h,v
> retrieving revision 1.38
> diff -c -3 -p -r1.38 libgfortran.h
> *** libgfortran.h 12 Oct 2005 20:21:31 -0000 1.38
> --- libgfortran.h 15 Oct 2005 23:27:48 -0000
> *************** typedef enum
> *** 392,398 ****
> ERROR_BAD_US,
> ERROR_READ_VALUE,
> ERROR_READ_OVERFLOW,
> - ERROR_ARRAY_STRIDE,
> ERROR_LAST /* Not a real error, the last error # + 1. */
> }
> error_codes;
> --- 392,397 ----
> Index: io/io.h
> ===================================================================
> RCS file: /cvs/gcc/gcc/libgfortran/io/io.h,v
> retrieving revision 1.33
> diff -c -3 -p -r1.33 io.h
> *** io/io.h 7 Oct 2005 20:02:28 -0000 1.33
> --- io/io.h 15 Oct 2005 23:27:48 -0000
> *************** stream;
> *** 78,103 ****
> #define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
> #define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
>
> ! /* Representation of a namelist object in libgfortran
> !
> ! Namelist Records
> ! &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
> ! or
> ! &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
> !
> ! The object can be a fully qualified, compound name for an instrinsic
> ! type, derived types or derived type components. So, a substring
> ! a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
> ! read. Hence full information about the structure of the object has
> ! to be available to list_read.c and write.
> !
> ! These requirements are met by the following data structures.
> !
> ! nml_loop_spec contains the variables for the loops over index ranges
> that are encountered. Since the variables can be negative, ssize_t
> is used. */
>
> ! typedef struct nml_loop_spec
> {
>
> /* Index counter for this dimension. */
> --- 78,88 ----
> #define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
> #define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
>
> ! /* The array_loop_spec contains the variables for the loops over index ranges
> that are encountered. Since the variables can be negative, ssize_t
> is used. */
>
> ! typedef struct array_loop_spec
> {
>
> /* Index counter for this dimension. */
> *************** typedef struct nml_loop_spec
> *** 112,121 ****
> /* Step for the index counter. */
> ssize_t step;
> }
> ! nml_loop_spec;
>
> ! /* namelist_info type contains all the scalar information about the
> ! object and arrays of descriptor_dimension and nml_loop_spec types for
> arrays. */
>
> typedef struct namelist_type
> --- 97,121 ----
> /* Step for the index counter. */
> ssize_t step;
> }
> ! array_loop_spec;
> !
> ! /* Representation of a namelist object in libgfortran
> !
> ! Namelist Records
> ! &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
> ! or
> ! &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
> !
> ! The object can be a fully qualified, compound name for an instrinsic
> ! type, derived types or derived type components. So, a substring
> ! a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
> ! read. Hence full information about the structure of the object has
> ! to be available to list_read.c and write.
> !
> ! These requirements are met by the following data structures.
>
> ! namelist_info type contains all the scalar information about the
> ! object and arrays of descriptor_dimension and array_loop_spec types for
> arrays. */
>
> typedef struct namelist_type
> *************** typedef struct namelist_type
> *** 146,152 ****
> index_type string_length;
>
> descriptor_dimension * dim;
> ! nml_loop_spec * ls;
> struct namelist_type * next;
> }
> namelist_info;
> --- 146,152 ----
> index_type string_length;
>
> descriptor_dimension * dim;
> ! array_loop_spec * ls;
> struct namelist_type * next;
> }
> namelist_info;
> *************** typedef struct gfc_unit
> *** 326,331 ****
> --- 326,332 ----
> maxrec -- Maximum record number in a direct access file
> bytes_left -- Bytes left in current record. */
>
> + array_loop_spec *ls; /* For traversing arrays */
> int file_len;
> char file[1]; /* Filename is allocated at the end of the structure. */
> }
> Index: io/list_read.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/libgfortran/io/list_read.c,v
> retrieving revision 1.28
> diff -c -3 -p -r1.28 list_read.c
> *** io/list_read.c 26 Sep 2005 20:24:44 -0000 1.28
> --- io/list_read.c 15 Oct 2005 23:27:49 -0000
> *************** calls:
> *** 1469,1475 ****
> static void nml_untouch_nodes (void)
> static namelist_info * find_nml_node (char * var_name)
> static int nml_parse_qualifier(descriptor_dimension * ad,
> ! nml_loop_spec * ls, int rank)
> static void nml_touch_nodes (namelist_info * nl)
> static int nml_read_obj (namelist_info * nl, index_type offset)
> calls:
> --- 1469,1475 ----
> static void nml_untouch_nodes (void)
> static namelist_info * find_nml_node (char * var_name)
> static int nml_parse_qualifier(descriptor_dimension * ad,
> ! array_loop_spec * ls, int rank)
> static void nml_touch_nodes (namelist_info * nl)
> static int nml_read_obj (namelist_info * nl, index_type offset)
> calls:
> *************** static index_type chigh;
> *** 1500,1506 ****
>
> static try
> nml_parse_qualifier(descriptor_dimension * ad,
> ! nml_loop_spec * ls, int rank)
> {
> int dim;
> int indx;
> --- 1500,1506 ----
>
> static try
> nml_parse_qualifier(descriptor_dimension * ad,
> ! array_loop_spec * ls, int rank)
> {
> int dim;
> int indx;
> *************** get_name:
> *** 2222,2228 ****
> if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
> {
> descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
> ! nml_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
>
> if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
> {
> --- 2222,2228 ----
> if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
> {
> descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
> ! array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
>
> if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
> {
> Index: io/transfer.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
> retrieving revision 1.63
> diff -c -3 -p -r1.63 transfer.c
> *** io/transfer.c 7 Oct 2005 20:02:28 -0000 1.63
> --- io/transfer.c 15 Oct 2005 23:27:50 -0000
> *************** data_transfer_init (int read_flag)
> *** 1460,1467 ****
> static void
> next_record_r (void)
> {
> ! int rlength, length, bytes_left;
> gfc_offset new;
> char *p;
>
> switch (current_mode ())
> --- 1460,1468 ----
> static void
> next_record_r (void)
> {
> ! int i, bytes_left, rlength, length, record, carry, rank;
> gfc_offset new;
> + array_loop_spec *ls;
> char *p;
>
> switch (current_mode ())
> *************** next_record_r (void)
> *** 1516,1526 ****
>
> 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
> {
> --- 1517,1565 ----
>
> if (is_internal_unit())
> {
> ! if (is_array_io())
> ! {
> ! /* Determine where the next record in the array is by moving
> ! through the loop specification. */
> !
> ! carry = 1;
> ! record = 0;
> ! rank = GFC_DESCRIPTOR_RANK(ioparm.internal_unit_desc);
> ! ls = current_unit->ls;
> ! for (i = 0; i < rank; i++)
> ! {
> ! if (carry)
> ! {
> ! ls[i].idx++;
> ! if (ls[i].idx > ls[i].end)
> ! {
> ! ls[i].idx = ls[i].start;
> ! carry = 1;
> ! }
> ! else
> ! carry = 0;
> ! }
> ! record = record + (ls[i].idx - 1) * ls[i].step;
> ! }
> !
> ! /* Now seek to this record */
> ! record = record * current_unit->recl;
> !
> ! if (sseek (current_unit->s, record) == FAILURE)
> ! {
> ! generate_error (ERROR_OS, NULL);
> ! break;
> ! }
> current_unit->bytes_left = current_unit->recl;
> ! }
> ! else
> ! {
> ! 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
> {
> *************** static void
> *** 1554,1560 ****
> next_record_w (void)
> {
> gfc_offset c, m;
> ! int length, bytes_left;
> char *p;
>
> /* Zero counters for X- and T-editing. */
> --- 1593,1601 ----
> next_record_w (void)
> {
> gfc_offset c, m;
> ! int bytes_left, carry, i, length, rank;
> ! gfc_offset record;
> ! array_loop_spec *ls;
> char *p;
>
> /* Zero counters for X- and T-editing. */
> *************** next_record_w (void)
> *** 1633,1638 ****
> --- 1674,1710 ----
> return;
> }
> memset(p, ' ', bytes_left);
> +
> + /* Now that the current record has been padded out,
> + determine where the next record in the array is by moving
> + through the loop specification. */
> +
> + carry = 1;
> + record = 0;
> + rank = GFC_DESCRIPTOR_RANK(ioparm.internal_unit_desc);
> + ls = current_unit->ls;
> + for (i = 0; i < rank; i++)
> + {
> + if (carry)
> + {
> + ls[i].idx++;
> + if (ls[i].idx > ls[i].end)
> + {
> + ls[i].idx = ls[i].start;
> + carry = 1;
> + }
> + else
> + carry = 0;
> + }
> + record = record + (ls[i].idx - 1) * ls[i].step;
> + }
> +
> + /* Now seek to this record */
> + record = record * current_unit->recl;
> +
> + if (sseek (current_unit->s, record) == FAILURE)
> + goto io_error;
> +
> current_unit->bytes_left = current_unit->recl;
> }
> else
> *************** finalize_transfer (void)
> *** 1766,1772 ****
> sfree (current_unit->s);
>
> if (is_internal_unit ())
> ! sclose (current_unit->s);
> }
>
>
> --- 1838,1848 ----
> sfree (current_unit->s);
>
> if (is_internal_unit ())
> ! {
> ! if (current_unit->ls != NULL)
> ! free_mem (current_unit->ls);
> ! sclose (current_unit->s);
> ! }
> }
>
>
> *************** st_set_nml_var (void * var_addr, char *
> *** 1957,1964 ****
> {
> nml->dim = (descriptor_dimension*)
> get_mem (nml->var_rank * sizeof (descriptor_dimension));
> ! nml->ls = (nml_loop_spec*)
> ! get_mem (nml->var_rank * sizeof (nml_loop_spec));
> }
> else
> {
> --- 2033,2040 ----
> {
> nml->dim = (descriptor_dimension*)
> get_mem (nml->var_rank * sizeof (descriptor_dimension));
> ! nml->ls = (array_loop_spec*)
> ! get_mem (nml->var_rank * sizeof (array_loop_spec));
> }
> else
> {
> Index: io/unit.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/libgfortran/io/unit.c,v
> retrieving revision 1.16
> diff -c -3 -p -r1.16 unit.c
> *** io/unit.c 1 Oct 2005 11:50:09 -0000 1.16
> --- io/unit.c 15 Oct 2005 23:27:50 -0000
> *************** gfc_offset
> *** 251,270 ****
> 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 0;
> ! }
> ! stride *= desc->dim[i].ubound;
> ! record_count *= desc->dim[i].ubound;
> }
> return record_count;
> }
> --- 251,276 ----
> get_array_unit_len (gfc_array_char *desc)
> {
> gfc_offset record_count;
> ! int i, rank;
> rank = GFC_DESCRIPTOR_RANK(desc);
> !
> ! record_count = 1;
> ! internal_unit.ls = (array_loop_spec*)
> ! get_mem (rank * sizeof (array_loop_spec));
> !
> ! for (i=0; i<rank; ++i)
> {
> ! /* Initialize the loop specification */
>
> ! internal_unit.ls[i].idx = 1;
> ! internal_unit.ls[i].start = desc->dim[i].lbound;
> ! internal_unit.ls[i].end = desc->dim[i].ubound;
> ! internal_unit.ls[i].step = desc->dim[i].stride;
> !
> ! /* Determine the number of records */
> !
> ! record_count += (desc->dim[i].ubound - desc->dim[i].lbound)
> ! * desc->dim[i].stride;
> }
> return record_count;
> }
> Index: runtime/error.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/libgfortran/runtime/error.c,v
> retrieving revision 1.16
> diff -c -3 -p -r1.16 error.c
> *** runtime/error.c 1 Oct 2005 11:50:09 -0000 1.16
> --- runtime/error.c 15 Oct 2005 23:27:50 -0000
> *************** translate_error (int code)
> *** 427,436 ****
> p = "Numeric overflow on read";
> break;
>
> - case ERROR_ARRAY_STRIDE:
> - p = "Array unit stride must be 1";
> - break;
> -
> default:
> p = "Unknown error code";
> break;
> --- 427,432 ----
More information about the Fortran
mailing list