[RFC PATCH] _gfortran_{ioparm,filename,line} vs. thread-safety
Jakub Jelinek
jakub@redhat.com
Wed Oct 5 06:43:00 GMT 2005
On Mon, Oct 03, 2005 at 04:27:20PM -0400, Jakub Jelinek wrote:
> Here is the current version of the patch.
> It compiles and that's all I can test ATM (as it needs matching
> trans-io.c changes).
The patch below already has the corresponding Fortran backend changes
and even 100% passes make check-gfortran on x86_64-linux.
What I wrote on Monday below still holds, but the further changes
shouldn't hopefully impact library's ABI (except maybe for the size of
the libgfortran's private area in st_parameter_dt).
> There are still many global vars left, some of them are going to stay global
> and need gthr.h locking (e.g. g.unit_root) while others still need analysis
> and hopefully they can be moved into st_parameter_dt's u.p if they
> are only live accross data transfer commands, etc.
--- libgfortran/libgfortran.h.jj 2005-10-03 22:28:00.000000000 +0200
+++ libgfortran/libgfortran.h 2005-10-04 19:53:55.000000000 +0200
@@ -428,11 +428,11 @@ iexport_data_proto(filename);
/* main.c */
-extern void library_start (void);
+struct st_parameter_common;
+extern void library_start (struct st_parameter_common *);
internal_proto(library_start);
-extern void library_end (void);
-internal_proto(library_end);
+#define library_end()
extern void set_args (int, char **);
export_proto(set_args);
@@ -456,13 +456,14 @@ internal_proto(xtoa);
extern void os_error (const char *) __attribute__ ((noreturn));
internal_proto(os_error);
-extern void show_locus (void);
+extern void show_locus (struct st_parameter_common *);
internal_proto(show_locus);
extern void runtime_error (const char *) __attribute__ ((noreturn));
iexport_proto(runtime_error);
-extern void internal_error (const char *) __attribute__ ((noreturn));
+extern void internal_error (struct st_parameter_common *, const char *)
+ __attribute__ ((noreturn));
internal_proto(internal_error);
extern const char *get_oserror (void);
@@ -482,7 +483,7 @@ internal_proto(st_sprintf);
extern const char *translate_error (int);
internal_proto(translate_error);
-extern void generate_error (int, const char *);
+extern void generate_error (struct st_parameter_common *, int, const char *);
internal_proto(generate_error);
/* memory.c */
@@ -512,7 +513,8 @@ internal_proto(show_variables);
/* string.c */
-extern int find_option (const char *, int, const st_option *, const char *);
+extern int find_option (struct st_parameter_common *, const char *, int,
+ const st_option *, const char *);
internal_proto(find_option);
extern int fstrlen (const char *, int);
--- libgfortran/runtime/string.c.jj 2005-09-29 14:07:48.000000000 +0200
+++ libgfortran/runtime/string.c 2005-10-04 19:53:55.000000000 +0200
@@ -31,7 +31,7 @@ Boston, MA 02110-1301, USA. */
#include <string.h>
#include "libgfortran.h"
-
+#include "../io/io.h"
/* Compare a C-style string with a fortran style string in a case-insensitive
manner. Used for decoding string options to various statements. Returns
@@ -104,14 +104,14 @@ cf_strcpy (char *dest, int dest_len, con
if no default is provided. */
int
-find_option (const char *s1, int s1_len, const st_option * opts,
- const char *error_message)
+find_option (st_parameter_common *cmp, const char *s1, int s1_len,
+ const st_option * opts, const char *error_message)
{
for (; opts->name; opts++)
if (compare0 (s1, s1_len, opts->name))
return opts->value;
- generate_error (ERROR_BAD_OPTION, error_message);
+ generate_error (cmp, ERROR_BAD_OPTION, error_message);
return -1;
}
--- libgfortran/runtime/stop.c.jj 2005-08-27 10:13:10.000000000 +0200
+++ libgfortran/runtime/stop.c 2005-10-04 19:53:55.000000000 +0200
@@ -37,8 +37,6 @@ Boston, MA 02110-1301, USA. */
void
stop_numeric (GFC_INTEGER_4 code)
{
- show_locus ();
-
if (code == -1)
st_printf ("STOP\n");
else
@@ -55,8 +53,6 @@ export_proto(stop_string);
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
- show_locus ();
-
st_printf ("STOP ");
while (len--)
st_printf ("%c", *(string++));
--- libgfortran/runtime/pause.c.jj 2005-08-27 10:13:10.000000000 +0200
+++ libgfortran/runtime/pause.c 2005-10-04 19:53:55.000000000 +0200
@@ -55,8 +55,6 @@ export_proto(pause_numeric);
void
pause_numeric (GFC_INTEGER_4 code)
{
- show_locus ();
-
if (code == -1)
st_printf ("PAUSE\n");
else
@@ -71,8 +69,6 @@ export_proto(pause_string);
void
pause_string (char *string, GFC_INTEGER_4 len)
{
- show_locus ();
-
st_printf ("PAUSE ");
while (len--)
st_printf ("%c", *(string++));
--- libgfortran/runtime/error.c.jj 2005-09-30 23:44:33.000000000 +0200
+++ libgfortran/runtime/error.c 2005-10-04 19:53:55.000000000 +0200
@@ -53,17 +53,6 @@ Boston, MA 02110-1301, USA. */
* Other error returns are reserved for the STOP statement with a numeric code.
*/
-/* locus variables. These are optionally set by a caller before a
- * library subroutine is called. They are always cleared on exit so
- * that files that report loci and those that do not can be linked
- * together without reporting an erroneous position. */
-
-char *filename = 0;
-iexport_data(filename);
-
-unsigned line = 0;
-iexport_data(line);
-
/* gfc_itoa()-- Integer to decimal conversion. */
const char *
@@ -159,7 +148,7 @@ st_printf (const char *format, ...)
if (count != 0)
{
- p = salloc_w (s, &count);
+ p = salloc_w (s, NULL, &count);
memmove (p, format, count);
sfree (s);
}
@@ -174,7 +163,7 @@ st_printf (const char *format, ...)
case 'c':
count = 1;
- p = salloc_w (s, &count);
+ p = salloc_w (s, NULL, &count);
*p = (char) va_arg (arg, int);
sfree (s);
@@ -184,7 +173,7 @@ st_printf (const char *format, ...)
q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
count = strlen (q);
- p = salloc_w (s, &count);
+ p = salloc_w (s, NULL, &count);
memmove (p, q, count);
sfree (s);
break;
@@ -193,7 +182,7 @@ st_printf (const char *format, ...)
q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf));
count = strlen (q);
- p = salloc_w (s, &count);
+ p = salloc_w (s, NULL, &count);
memmove (p, q, count);
sfree (s);
break;
@@ -202,7 +191,7 @@ st_printf (const char *format, ...)
q = va_arg (arg, char *);
count = strlen (q);
- p = salloc_w (s, &count);
+ p = salloc_w (s, NULL, &count);
memmove (p, q, count);
sfree (s);
break;
@@ -212,7 +201,7 @@ st_printf (const char *format, ...)
default:
count = 2;
- p = salloc_w (s, &count);
+ p = salloc_w (s, NULL, &count);
p[0] = format[-1];
p[1] = format[0];
sfree (s);
@@ -288,12 +277,12 @@ st_sprintf (char *buffer, const char *fo
* something went wrong */
void
-show_locus (void)
+show_locus (st_parameter_common *cmp)
{
- if (!options.locus || filename == NULL)
+ if (!options.locus || cmp == NULL || cmp->filename == NULL)
return;
- st_printf ("At line %d of file %s\n", line, filename);
+ st_printf ("At line %d of file %s\n", cmp->line, cmp->filename);
}
@@ -324,7 +313,6 @@ void
os_error (const char *message)
{
recursion_check ();
- show_locus ();
st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
sys_exit (1);
}
@@ -337,7 +325,6 @@ void
runtime_error (const char *message)
{
recursion_check ();
- show_locus ();
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
@@ -348,10 +335,10 @@ iexport(runtime_error);
* that indicate something deeply wrong. */
void
-internal_error (const char *message)
+internal_error (st_parameter_common *cmp, const char *message)
{
recursion_check ();
- show_locus ();
+ show_locus (cmp);
st_printf ("Internal Error: %s\n", message);
sys_exit (3);
}
@@ -449,48 +436,52 @@ translate_error (int code)
* the most recent operating system error is used. */
void
-generate_error (int family, const char *message)
+generate_error (st_parameter_common *cmp, int family, const char *message)
{
/* Set the error status. */
- if (ioparm.iostat != NULL)
- *ioparm.iostat = family;
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ *cmp->iostat = family;
if (message == NULL)
message =
(family == ERROR_OS) ? get_oserror () : translate_error (family);
- if (ioparm.iomsg)
- cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
+ if (cmp->flags & IOPARM_HAS_IOMSG)
+ cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
/* Report status back to the compiler. */
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
switch (family)
{
case ERROR_EOR:
- ioparm.library_return = LIBRARY_EOR;
- if (ioparm.eor != 0)
+ cmp->flags |= IOPARM_LIBRETURN_EOR;
+ if ((cmp->flags & IOPARM_EOR))
return;
break;
case ERROR_END:
- ioparm.library_return = LIBRARY_END;
- if (ioparm.end != 0)
+ cmp->flags |= IOPARM_LIBRETURN_END;
+ if ((cmp->flags & IOPARM_END))
return;
break;
default:
- ioparm.library_return = LIBRARY_ERROR;
- if (ioparm.err != 0)
+ cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ if ((cmp->flags & IOPARM_ERR))
return;
break;
}
/* Return if the user supplied an iostat variable. */
- if (ioparm.iostat != NULL)
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
return;
/* Terminate the program */
- runtime_error (message);
+ recursion_check ();
+ show_locus (cmp);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
}
@@ -508,7 +499,6 @@ notify_std (int std, const char * messag
if ((compile_options.allow_std & std) != 0 && !warning)
return SUCCESS;
- show_locus ();
if (!warning)
{
st_printf ("Fortran runtime error: %s\n", message);
--- libgfortran/io/io.h.jj 2005-09-27 22:09:50.000000000 +0200
+++ libgfortran/io/io.h 2005-10-05 00:27:21.000000000 +0200
@@ -48,9 +48,12 @@ typedef enum
{ SUCCESS = 1, FAILURE }
try;
+struct st_parameter_dt;
+
typedef struct stream
{
- char *(*alloc_w_at) (struct stream *, int *, gfc_offset);
+ char *(*alloc_w_at) (struct stream *, struct st_parameter_dt *,
+ int *, gfc_offset);
char *(*alloc_r_at) (struct stream *, int *, gfc_offset);
try (*sfree) (struct stream *);
try (*close) (struct stream *);
@@ -66,10 +69,10 @@ stream;
#define sclose(s) ((s)->close)(s)
#define salloc_r(s, len) ((s)->alloc_r_at)(s, len, -1)
-#define salloc_w(s, len) ((s)->alloc_w_at)(s, len, -1)
+#define salloc_w(s, dtp, len) ((s)->alloc_w_at)(s, dtp, len, -1)
#define salloc_r_at(s, len, where) ((s)->alloc_r_at)(s, len, where)
-#define salloc_w_at(s, len, where) ((s)->alloc_w_at)(s, len, where)
+#define salloc_w_at(s, dtp, len, where) ((s)->alloc_w_at)(s, dtp, len, where)
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s)
@@ -199,83 +202,185 @@ typedef enum
{READING, WRITING}
unit_mode;
-/* Statement parameters. These are all the things that can appear in
- an I/O statement. Some are inputs and some are outputs, but none
- are both. All of these values are initially zeroed and are zeroed
- at the end of a library statement. The relevant values need to be
- set before entry to an I/O statement. This structure needs to be
- duplicated by the back end. */
+#define CHARACTER1(name) \
+ char * name; \
+ gfc_charlen_type name ## _len
+#define CHARACTER2(name) \
+ gfc_charlen_type name ## _len; \
+ char * name
+
+#define IOPARM_LIBRETURN_MASK (3 << 0)
+#define IOPARM_LIBRETURN_OK (0 << 0)
+#define IOPARM_LIBRETURN_ERROR (1 << 0)
+#define IOPARM_LIBRETURN_END (2 << 0)
+#define IOPARM_LIBRETURN_EOR (3 << 0)
+#define IOPARM_ERR (1 << 2)
+#define IOPARM_END (1 << 3)
+#define IOPARM_EOR (1 << 4)
+#define IOPARM_HAS_IOSTAT (1 << 5)
+#define IOPARM_HAS_IOMSG (1 << 6)
-typedef struct
+#define IOPARM_COMMON_MASK ((1 << 7) - 1)
+
+typedef struct st_parameter_common
{
+ GFC_INTEGER_4 flags;
GFC_INTEGER_4 unit;
- GFC_INTEGER_4 err, end, eor, list_format; /* These are flags, not values. */
+ const char *filename;
+ GFC_INTEGER_4 line;
+ CHARACTER2 (iomsg);
+ GFC_INTEGER_4 *iostat;
+}
+st_parameter_common;
+
+#define IOPARM_OPEN_HAS_RECL_IN (1 << 7)
+#define IOPARM_OPEN_HAS_FILE (1 << 8)
+#define IOPARM_OPEN_HAS_STATUS (1 << 9)
+#define IOPARM_OPEN_HAS_ACCESS (1 << 10)
+#define IOPARM_OPEN_HAS_FORM (1 << 11)
+#define IOPARM_OPEN_HAS_BLANK (1 << 12)
+#define IOPARM_OPEN_HAS_POSITION (1 << 13)
+#define IOPARM_OPEN_HAS_ACTION (1 << 14)
+#define IOPARM_OPEN_HAS_DELIM (1 << 15)
+#define IOPARM_OPEN_HAS_PAD (1 << 16)
-/* Return values from library statements. These are returned only if
- the labels are specified in the statement itself and the condition
- occurs. In most cases, none of the labels are specified and the
- return value does not have to be checked. Must be consistent with
- the front end. */
+typedef struct
+{
+ st_parameter_common common;
+ GFC_INTEGER_4 recl_in;
+ CHARACTER2 (file);
+ CHARACTER1 (status);
+ CHARACTER2 (access);
+ CHARACTER1 (form);
+ CHARACTER2 (blank);
+ CHARACTER1 (position);
+ CHARACTER2 (action);
+ CHARACTER1 (delim);
+ CHARACTER2 (pad);
+}
+st_parameter_open;
- enum
- {
- LIBRARY_OK = 0,
- LIBRARY_ERROR,
- LIBRARY_END,
- LIBRARY_EOR
- }
- library_return;
+#define IOPARM_CLOSE_HAS_STATUS (1 << 7)
- GFC_INTEGER_4 *iostat, *exist, *opened, *number, *named;
- GFC_INTEGER_4 rec;
- GFC_INTEGER_4 *nextrec, *size;
+typedef struct
+{
+ st_parameter_common common;
+ CHARACTER1 (status);
+}
+st_parameter_close;
- GFC_INTEGER_4 recl_in;
- GFC_INTEGER_4 *recl_out;
+typedef struct
+{
+ st_parameter_common common;
+}
+st_parameter_filepos;
- GFC_INTEGER_4 *iolength;
+#define IOPARM_INQUIRE_HAS_EXIST (1 << 7)
+#define IOPARM_INQUIRE_HAS_OPENED (1 << 8)
+#define IOPARM_INQUIRE_HAS_NUMBER (1 << 9)
+#define IOPARM_INQUIRE_HAS_NAMED (1 << 10)
+#define IOPARM_INQUIRE_HAS_NEXTREC (1 << 11)
+#define IOPARM_INQUIRE_HAS_RECL_OUT (1 << 12)
+#define IOPARM_INQUIRE_HAS_FILE (1 << 13)
+#define IOPARM_INQUIRE_HAS_ACCESS (1 << 14)
+#define IOPARM_INQUIRE_HAS_FORM (1 << 15)
+#define IOPARM_INQUIRE_HAS_BLANK (1 << 16)
+#define IOPARM_INQUIRE_HAS_POSITION (1 << 17)
+#define IOPARM_INQUIRE_HAS_ACTION (1 << 18)
+#define IOPARM_INQUIRE_HAS_DELIM (1 << 19)
+#define IOPARM_INQUIRE_HAS_PAD (1 << 20)
+#define IOPARM_INQUIRE_HAS_NAME (1 << 21)
+#define IOPARM_INQUIRE_HAS_SEQUENTIAL (1 << 22)
+#define IOPARM_INQUIRE_HAS_DIRECT (1 << 23)
+#define IOPARM_INQUIRE_HAS_FORMATTED (1 << 24)
+#define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 25)
+#define IOPARM_INQUIRE_HAS_READ (1 << 26)
+#define IOPARM_INQUIRE_HAS_WRITE (1 << 27)
+#define IOPARM_INQUIRE_HAS_READWRITE (1 << 28)
+
+typedef struct
+{
+ st_parameter_common common;
+ GFC_INTEGER_4 *exist, *opened, *number, *named;
+ GFC_INTEGER_4 *nextrec, *recl_out;
+ CHARACTER1 (file);
+ CHARACTER2 (access);
+ CHARACTER1 (form);
+ CHARACTER2 (blank);
+ CHARACTER1 (position);
+ CHARACTER2 (action);
+ CHARACTER1 (delim);
+ CHARACTER2 (pad);
+ CHARACTER1 (name);
+ CHARACTER2 (sequential);
+ CHARACTER1 (direct);
+ CHARACTER2 (formatted);
+ CHARACTER1 (unformatted);
+ CHARACTER2 (read);
+ CHARACTER1 (write);
+ CHARACTER2 (readwrite);
+}
+st_parameter_inquire;
+
+struct gfc_unit;
+
+#define IOPARM_DT_LIST_FORMAT (1 << 7)
+#define IOPARM_DT_NAMELIST_READ_MODE (1 << 8)
+#define IOPARM_DT_HAS_REC (1 << 9)
+#define IOPARM_DT_HAS_SIZE (1 << 10)
+#define IOPARM_DT_HAS_IOLENGTH (1 << 11)
+#define IOPARM_DT_HAS_FORMAT (1 << 12)
+#define IOPARM_DT_HAS_ADVANCE (1 << 13)
+#define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
+#define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
+/* Internal use bit. */
+#define IOPARM_DT_IONML_SET (1 << 31)
-#define CHARACTER(name) \
- char * name; \
- gfc_charlen_type name ## _len
- CHARACTER (file);
- CHARACTER (status);
- CHARACTER (access);
- CHARACTER (form);
- CHARACTER (blank);
- CHARACTER (position);
- CHARACTER (action);
- CHARACTER (delim);
- CHARACTER (pad);
- CHARACTER (format);
- CHARACTER (advance);
- CHARACTER (name);
- CHARACTER (internal_unit);
+typedef struct st_parameter_dt
+{
+ st_parameter_common common;
+ GFC_INTEGER_4 rec;
+ GFC_INTEGER_4 *size, *iolength;
gfc_array_char *internal_unit_desc;
- CHARACTER (sequential);
- CHARACTER (direct);
- CHARACTER (formatted);
- CHARACTER (unformatted);
- CHARACTER (read);
- CHARACTER (write);
- CHARACTER (readwrite);
-
-/* namelist related data */
- CHARACTER (namelist_name);
- GFC_INTEGER_4 namelist_read_mode;
-
- /* iomsg */
- CHARACTER (iomsg);
-
-#undef CHARACTER
+ CHARACTER1 (format);
+ CHARACTER2 (advance);
+ CHARACTER1 (internal_unit);
+ CHARACTER2 (namelist_name);
+ /* Private part of the structure. The compiler just needs
+ to reserve enough space. */
+ union
+ {
+ struct
+ {
+ void (*transfer) (struct st_parameter_dt *, bt, void *, int, size_t);
+ struct gfc_unit *current_unit;
+ int item_count; /* Item number in a formatted data transfer. */
+ unit_mode mode;
+ unit_blank blank_status;
+ enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
+ int scale_factor;
+ int max_pos; /* Maximum righthand column written to. */
+ int skips; /* Number of skips + spaces to be done for T and X-editing. */
+ int pending_spaces; /* Number of spaces to be done for T and X-editing. */
+ unit_advance advance_status;
+ char reversion_flag; /* Format reversion has occurred. */
+ char first_item;
+ char seen_dollar;
+ char sf_seen_eor;
+ char eor_condition;
+ char no_leading_blank;
+ char nml_delim;
+ char char_flag;
+ char *line_buffer;
+ namelist_info *ionml;
+ } p;
+ char pad[16 * sizeof (char *) + 32 * sizeof (int)];
+ } u;
}
-st_parameter;
-
-extern st_parameter ioparm;
-iexport_data_proto(ioparm);
+st_parameter_dt;
-extern namelist_info * ionml;
-internal_proto(ionml);
+#undef CHARACTER1
+#undef CHARACTER2
typedef struct
{
@@ -313,7 +418,7 @@ typedef struct gfc_unit
{ NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
endfile;
- unit_mode mode;
+ unit_mode mode;
unit_flags flags;
gfc_offset recl, last_record, maxrec, bytes_left;
@@ -332,21 +437,8 @@ gfc_unit;
typedef struct
{
- int in_library; /* Nonzero if a library call is being processed. */
- int size; /* Bytes processed by the current data-transfer statement. */
gfc_offset max_offset; /* Maximum file offset. */
- int item_count; /* Item number in a formatted data transfer. */
- int reversion_flag; /* Format reversion has occurred. */
- int first_item;
-
gfc_unit *unit_root;
- int seen_dollar;
-
- unit_mode mode;
-
- unit_blank blank_status;
- enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
- int scale_factor;
jmp_buf eof_jump;
}
global_t;
@@ -354,9 +446,6 @@ global_t;
extern global_t g;
internal_proto(g);
-extern gfc_unit *current_unit;
-internal_proto(current_unit);
-
/* Format tokens. Only about half of these can be stored in the
format nodes. */
@@ -431,7 +520,7 @@ internal_proto(compare_files);
extern stream *init_error_stream (void);
internal_proto(init_error_stream);
-extern stream *open_external (unit_flags *);
+extern stream *open_external (st_parameter_open *, unit_flags *);
internal_proto(open_external);
extern stream *open_internal (char *, int);
@@ -449,7 +538,7 @@ internal_proto(error_stream);
extern int compare_file_filename (stream *, const char *, int);
internal_proto(compare_file_filename);
-extern gfc_unit *find_file (void);
+extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
internal_proto(find_file);
extern int stream_at_bof (stream *);
@@ -461,7 +550,7 @@ internal_proto(stream_at_eof);
extern int delete_file (gfc_unit *);
internal_proto(delete_file);
-extern int file_exists (void);
+extern int file_exists (const char *file, gfc_charlen_type file_len);
internal_proto(file_exists);
extern const char *inquire_sequential (const char *, int);
@@ -523,19 +612,19 @@ internal_proto(insert_unit);
extern int close_unit (gfc_unit *);
internal_proto(close_unit);
-extern int is_internal_unit (void);
+extern int is_internal_unit (st_parameter_dt *);
internal_proto(is_internal_unit);
-extern int is_array_io (void);
+extern int is_array_io (st_parameter_dt *);
internal_proto(is_array_io);
-extern gfc_offset get_array_unit_len (gfc_array_char *);
+extern gfc_offset get_array_unit_len (st_parameter_dt *, gfc_array_char *);
internal_proto(get_array_unit_len);
extern gfc_unit *find_unit (int);
internal_proto(find_unit);
-extern gfc_unit *get_unit (int);
+extern gfc_unit *get_unit (st_parameter_dt *);
internal_proto(get_unit);
/* open.c */
@@ -543,21 +632,21 @@ internal_proto(get_unit);
extern void test_endfile (gfc_unit *);
internal_proto(test_endfile);
-extern void new_unit (unit_flags *);
+extern void new_unit (st_parameter_open *, unit_flags *);
internal_proto(new_unit);
/* format.c */
-extern void parse_format (void);
+extern void parse_format (st_parameter_dt *);
internal_proto(parse_format);
-extern fnode *next_format (void);
+extern fnode *next_format (st_parameter_dt *);
internal_proto(next_format);
extern void unget_format (fnode *);
internal_proto(unget_format);
-extern void format_error (fnode *, const char *);
+extern void format_error (st_parameter_dt *, fnode *, const char *);
internal_proto(format_error);
extern void free_fnodes (void);
@@ -573,13 +662,13 @@ internal_proto(scratch);
extern const char *type_name (bt);
internal_proto(type_name);
-extern void *read_block (int *);
+extern void *read_block (st_parameter_dt *, int *);
internal_proto(read_block);
-extern void *write_block (int);
+extern void *write_block (st_parameter_dt *, int);
internal_proto(write_block);
-extern void next_record (int);
+extern void next_record (st_parameter_dt *, int);
internal_proto(next_record);
/* read.c */
@@ -590,87 +679,91 @@ internal_proto(set_integer);
extern GFC_UINTEGER_LARGEST max_value (int, int);
internal_proto(max_value);
-extern int convert_real (void *, const char *, int);
+extern int convert_real (st_parameter_dt *, void *, const char *, int);
internal_proto(convert_real);
-extern void read_a (fnode *, char *, int);
+extern void read_a (st_parameter_dt *, fnode *, char *, int);
internal_proto(read_a);
-extern void read_f (fnode *, char *, int);
+extern void read_f (st_parameter_dt *, fnode *, char *, int);
internal_proto(read_f);
-extern void read_l (fnode *, char *, int);
+extern void read_l (st_parameter_dt *, fnode *, char *, int);
internal_proto(read_l);
-extern void read_x (int);
+extern void read_x (st_parameter_dt *, int);
internal_proto(read_x);
-extern void read_radix (fnode *, char *, int, int);
+extern void read_radix (st_parameter_dt *, fnode *, char *, int, int);
internal_proto(read_radix);
-extern void read_decimal (fnode *, char *, int);
+extern void read_decimal (st_parameter_dt *, fnode *, char *, int);
internal_proto(read_decimal);
/* list_read.c */
-extern void list_formatted_read (bt, void *, int, size_t);
+extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t);
internal_proto(list_formatted_read);
-extern void finish_list_read (void);
+extern void finish_list_read (st_parameter_dt *);
internal_proto(finish_list_read);
extern void init_at_eol (void);
internal_proto(init_at_eol);
-extern void namelist_read (void);
+extern void namelist_read (st_parameter_dt *);
internal_proto(namelist_read);
-extern void namelist_write (void);
+extern void namelist_write (st_parameter_dt *);
internal_proto(namelist_write);
/* write.c */
-extern void write_a (fnode *, const char *, int);
+extern void write_a (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_a);
-extern void write_b (fnode *, const char *, int);
+extern void write_b (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_b);
-extern void write_d (fnode *, const char *, int);
+extern void write_d (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_d);
-extern void write_e (fnode *, const char *, int);
+extern void write_e (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_e);
-extern void write_en (fnode *, const char *, int);
+extern void write_en (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_en);
-extern void write_es (fnode *, const char *, int);
+extern void write_es (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_es);
-extern void write_f (fnode *, const char *, int);
+extern void write_f (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_f);
-extern void write_i (fnode *, const char *, int);
+extern void write_i (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_i);
-extern void write_l (fnode *, char *, int);
+extern void write_l (st_parameter_dt *, fnode *, char *, int);
internal_proto(write_l);
-extern void write_o (fnode *, const char *, int);
+extern void write_o (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_o);
-extern void write_x (int, int);
+extern void write_x (st_parameter_dt *, int, int);
internal_proto(write_x);
-extern void write_z (fnode *, const char *, int);
+extern void write_z (st_parameter_dt *, fnode *, const char *, int);
internal_proto(write_z);
-extern void list_formatted_write (bt, void *, int, size_t);
+extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t);
internal_proto(list_formatted_write);
/* error.c */
extern try notify_std (int, const char *);
internal_proto(notify_std);
+/* lock.c */
+extern void free_ionml (st_parameter_dt *);
+internal_proto(free_ionml);
+
#endif
--- libgfortran/io/open.c.jj 2005-09-30 23:14:21.000000000 +0200
+++ libgfortran/io/open.c 2005-10-04 20:42:43.000000000 +0200
@@ -115,56 +115,57 @@ test_endfile (gfc_unit * u)
changed. */
static void
-edit_modes (gfc_unit * u, unit_flags * flags)
+edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
/* Complain about attempts to change the unchangeable. */
if (flags->status != STATUS_UNSPECIFIED &&
u->flags.status != flags->status)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change STATUS parameter in OPEN statement");
if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change ACCESS parameter in OPEN statement");
if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change FORM parameter in OPEN statement");
- if (ioparm.recl_in != 0 && ioparm.recl_in != u->recl)
- generate_error (ERROR_BAD_OPTION,
+ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
+ && opp->recl_in != u->recl)
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change RECL parameter in OPEN statement");
if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change ACTION parameter in OPEN statement");
/* Status must be OLD if present. */
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"OPEN statement must have a STATUS of OLD");
if (u->flags.form == FORM_UNFORMATTED)
{
if (flags->delim != DELIM_UNSPECIFIED)
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->blank != BLANK_UNSPECIFIED)
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->pad != PAD_UNSPECIFIED)
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"PAD paramter conflicts with UNFORMATTED form in "
"OPEN statement");
}
- if (ioparm.library_return == LIBRARY_OK)
+ if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
/* Change the changeable: */
if (flags->blank != BLANK_UNSPECIFIED)
@@ -202,7 +203,7 @@ edit_modes (gfc_unit * u, unit_flags * f
break;
seek_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&opp->common, ERROR_OS, NULL);
break;
}
}
@@ -211,7 +212,7 @@ edit_modes (gfc_unit * u, unit_flags * f
/* Open an unused unit. */
void
-new_unit (unit_flags * flags)
+new_unit (st_parameter_open *opp, unit_flags * flags)
{
gfc_unit *u;
stream *s;
@@ -235,7 +236,7 @@ new_unit (unit_flags * flags)
{
if (flags->form == FORM_UNFORMATTED)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto cleanup;
@@ -248,7 +249,7 @@ new_unit (unit_flags * flags)
{
if (flags->form == FORM_UNFORMATTED)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto cleanup;
@@ -261,7 +262,7 @@ new_unit (unit_flags * flags)
{
if (flags->form == FORM_UNFORMATTED)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"PAD paramter conflicts with UNFORMATTED form in "
"OPEN statement");
goto cleanup;
@@ -270,7 +271,7 @@ new_unit (unit_flags * flags)
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"ACCESS parameter conflicts with SEQUENTIAL access in "
"OPEN statement");
goto cleanup;
@@ -285,16 +286,17 @@ new_unit (unit_flags * flags)
/* Checks. */
- if (flags->access == ACCESS_DIRECT && ioparm.recl_in == 0)
+ if (flags->access == ACCESS_DIRECT
+ && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
{
- generate_error (ERROR_MISSING_OPTION,
+ generate_error (&opp->common, ERROR_MISSING_OPTION,
"Missing RECL parameter in OPEN statement");
goto cleanup;
}
- if (ioparm.recl_in != 0 && ioparm.recl_in <= 0)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
{
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"RECL parameter is non-positive in OPEN statement");
goto cleanup;
}
@@ -302,10 +304,10 @@ new_unit (unit_flags * flags)
switch (flags->status)
{
case STATUS_SCRATCH:
- if (ioparm.file == NULL)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
break;
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"FILE parameter must not be present in OPEN statement");
return;
@@ -313,36 +315,38 @@ new_unit (unit_flags * flags)
case STATUS_NEW:
case STATUS_REPLACE:
case STATUS_UNKNOWN:
- if (ioparm.file != NULL)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
break;
- ioparm.file = tmpname;
- ioparm.file_len = sprintf(ioparm.file, "fort.%d", ioparm.unit);
+ opp->file = tmpname;
+ opp->file_len = sprintf(opp->file, "fort.%d", opp->common.unit);
break;
default:
- internal_error ("new_unit(): Bad status");
+ internal_error (&opp->common, "new_unit(): Bad status");
}
/* Make sure the file isn't already open someplace else.
Do not error if opening file preconnected to stdin, stdout, stderr. */
- u = find_file ();
+ u = NULL;
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
+ u = find_file (opp->file, opp->file_len);
if (u != NULL
&& (options.stdin_unit < 0 || u->unit_number != options.stdin_unit)
&& (options.stdout_unit < 0 || u->unit_number != options.stdout_unit)
&& (options.stderr_unit < 0 || u->unit_number != options.stderr_unit))
{
- generate_error (ERROR_ALREADY_OPEN, NULL);
+ generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
goto cleanup;
}
/* Open file. */
- s = open_external (flags);
+ s = open_external (opp, flags);
if (s == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&opp->common, ERROR_OS, NULL);
goto cleanup;
}
@@ -351,23 +355,26 @@ new_unit (unit_flags * flags)
/* Create the unit structure. */
- u = get_mem (sizeof (gfc_unit) + ioparm.file_len);
- memset (u, '\0', sizeof (gfc_unit) + ioparm.file_len);
+ u = get_mem (sizeof (gfc_unit) + opp->file_len);
+ memset (u, '\0', sizeof (gfc_unit) + opp->file_len);
- u->unit_number = ioparm.unit;
+ u->unit_number = opp->common.unit;
u->s = s;
u->flags = *flags;
if (flags->position == POSITION_APPEND)
{
if (sseek (u->s, file_length (u->s)) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ generate_error (&opp->common, ERROR_OS, NULL);
u->endfile = AT_ENDFILE;
}
/* Unspecified recl ends up with a processor dependent value. */
- u->recl = (ioparm.recl_in != 0) ? ioparm.recl_in : g.max_offset;
+ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
+ u->recl = opp->recl_in;
+ else
+ u->recl = g.max_offset;
u->last_record = 0;
u->current_record = 0;
@@ -378,8 +385,8 @@ new_unit (unit_flags * flags)
if (flags->access == ACCESS_DIRECT)
u->maxrec = g.max_offset / u->recl;
- memmove (u->file, ioparm.file, ioparm.file_len);
- u->file_len = ioparm.file_len;
+ memmove (u->file, opp->file, opp->file_len);
+ u->file_len = opp->file_len;
insert_unit (u);
@@ -396,7 +403,7 @@ new_unit (unit_flags * flags)
/* Free memory associated with a temporary filename. */
if (flags->status == STATUS_SCRATCH)
- free_mem (ioparm.file);
+ free_mem (opp->file);
}
@@ -404,103 +411,106 @@ new_unit (unit_flags * flags)
modes or closing what is there now and opening the new file. */
static void
-already_open (gfc_unit * u, unit_flags * flags)
+already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
- if (ioparm.file == NULL)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
- edit_modes (u, flags);
+ edit_modes (opp, u, flags);
return;
}
/* If the file is connected to something else, close it and open a
new unit. */
- if (!compare_file_filename (u->s, ioparm.file, ioparm.file_len))
+ if (!compare_file_filename (u->s, opp->file, opp->file_len))
{
if (close_unit (u))
{
- generate_error (ERROR_OS, "Error closing file in OPEN statement");
+ generate_error (&opp->common, ERROR_OS,
+ "Error closing file in OPEN statement");
return;
}
- new_unit (flags);
+ new_unit (opp, flags);
return;
}
- edit_modes (u, flags);
+ edit_modes (opp, u, flags);
}
/* Open file. */
-extern void st_open (void);
+extern void st_open (st_parameter_open *opp);
export_proto(st_open);
void
-st_open (void)
+st_open (st_parameter_open *opp)
{
unit_flags flags;
gfc_unit *u = NULL;
+ GFC_INTEGER_4 cf = opp->common.flags;
- library_start ();
+ library_start (&opp->common);
/* Decode options. */
- flags.access = (ioparm.access == NULL) ? ACCESS_UNSPECIFIED :
- find_option (ioparm.access, ioparm.access_len, access_opt,
- "Bad ACCESS parameter in OPEN statement");
-
- flags.action = (ioparm.action == NULL) ? ACTION_UNSPECIFIED :
- find_option (ioparm.action, ioparm.action_len, action_opt,
- "Bad ACTION parameter in OPEN statement");
-
- flags.blank = (ioparm.blank == NULL) ? BLANK_UNSPECIFIED :
- find_option (ioparm.blank, ioparm.blank_len, blank_opt,
- "Bad BLANK parameter in OPEN statement");
-
- flags.delim = (ioparm.delim == NULL) ? DELIM_UNSPECIFIED :
- find_option (ioparm.delim, ioparm.delim_len, delim_opt,
- "Bad DELIM parameter in OPEN statement");
-
- flags.pad = (ioparm.pad == NULL) ? PAD_UNSPECIFIED :
- find_option (ioparm.pad, ioparm.pad_len, pad_opt,
- "Bad PAD parameter in OPEN statement");
-
- flags.form = (ioparm.form == NULL) ? FORM_UNSPECIFIED :
- find_option (ioparm.form, ioparm.form_len, form_opt,
- "Bad FORM parameter in OPEN statement");
-
- flags.position = (ioparm.position == NULL) ? POSITION_UNSPECIFIED :
- find_option (ioparm.position, ioparm.position_len, position_opt,
- "Bad POSITION parameter in OPEN statement");
-
- flags.status = (ioparm.status == NULL) ? STATUS_UNSPECIFIED :
- find_option (ioparm.status, ioparm.status_len, status_opt,
- "Bad STATUS parameter in OPEN statement");
-
- if (ioparm.unit < 0)
- generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
+ flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
+ find_option (&opp->common, opp->access, opp->access_len,
+ access_opt, "Bad ACCESS parameter in OPEN statement");
+
+ flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
+ find_option (&opp->common, opp->action, opp->action_len,
+ action_opt, "Bad ACTION parameter in OPEN statement");
+
+ flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
+ find_option (&opp->common, opp->blank, opp->blank_len,
+ blank_opt, "Bad BLANK parameter in OPEN statement");
+
+ flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
+ find_option (&opp->common, opp->delim, opp->delim_len,
+ delim_opt, "Bad DELIM parameter in OPEN statement");
+
+ flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
+ find_option (&opp->common, opp->pad, opp->pad_len,
+ pad_opt, "Bad PAD parameter in OPEN statement");
+
+ flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
+ find_option (&opp->common, opp->form, opp->form_len,
+ form_opt, "Bad FORM parameter in OPEN statement");
+
+ flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
+ find_option (&opp->common, opp->position, opp->position_len,
+ position_opt, "Bad POSITION parameter in OPEN statement");
+
+ flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
+ find_option (&opp->common, opp->status, opp->status_len,
+ status_opt, "Bad STATUS parameter in OPEN statement");
+
+ if (opp->common.unit < 0)
+ generate_error (&opp->common, ERROR_BAD_OPTION,
+ "Bad unit number in OPEN statement");
if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot use POSITION with direct access files");
if (flags.position == POSITION_UNSPECIFIED)
flags.position = POSITION_ASIS;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((opp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
return;
}
- u = find_unit (ioparm.unit);
+ u = find_unit (opp->common.unit);
if (u == NULL)
- new_unit (&flags);
+ new_unit (opp, &flags);
else
- already_open (u, &flags);
+ already_open (opp, u, &flags);
library_end ();
}
--- libgfortran/io/file_pos.c.jj 2005-08-27 10:13:09.000000000 +0200
+++ libgfortran/io/file_pos.c 2005-10-04 19:53:55.000000000 +0200
@@ -36,7 +36,7 @@ Boston, MA 02110-1301, USA. */
ENDFILE, and REWIND as well as the FLUSH statement. */
-/* formatted_backspace(void)-- Move the file back one line. The
+/* formatted_backspace(fpp, u)-- Move the file back one line. The
current position is after the newline that terminates the previous
record, and we have to sift backwards to find the newline before
that or the start of the file, whichever comes first. */
@@ -44,20 +44,20 @@ Boston, MA 02110-1301, USA. */
#define READ_CHUNK 4096
static void
-formatted_backspace (void)
+formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset base;
char *p;
int n;
- base = file_position (current_unit->s) - 1;
+ base = file_position (u->s) - 1;
do
{
n = (base < READ_CHUNK) ? base : READ_CHUNK;
base -= n;
- p = salloc_r_at (current_unit->s, &n, base);
+ p = salloc_r_at (u->s, &n, base);
if (p == NULL)
goto io_error;
@@ -84,24 +84,24 @@ formatted_backspace (void)
/* base is the new pointer. Seek to it exactly. */
done:
- if (sseek (current_unit->s, base) == FAILURE)
+ if (sseek (u->s, base) == FAILURE)
goto io_error;
- current_unit->last_record--;
- current_unit->endfile = NO_ENDFILE;
+ u->last_record--;
+ u->endfile = NO_ENDFILE;
return;
io_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&fpp->common, ERROR_OS, NULL);
}
-/* unformatted_backspace() -- Move the file backwards for an unformatted
+/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
sequential file. We are guaranteed to be between records on entry and
we have to shift to the previous record. */
static void
-unformatted_backspace (void)
+unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset m, new;
int length;
@@ -109,43 +109,41 @@ unformatted_backspace (void)
length = sizeof (gfc_offset);
- p = salloc_r_at (current_unit->s, &length,
- file_position (current_unit->s) - length);
+ p = salloc_r_at (u->s, &length,
+ file_position (u->s) - length);
if (p == NULL)
goto io_error;
memcpy (&m, p, sizeof (gfc_offset));
- new = file_position (current_unit->s) - m - 2*length;
- if (sseek (current_unit->s, new) == FAILURE)
+ new = file_position (u->s) - m - 2*length;
+ if (sseek (u->s, new) == FAILURE)
goto io_error;
- current_unit->last_record--;
+ u->last_record--;
return;
io_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&fpp->common, ERROR_OS, NULL);
}
-extern void st_backspace (void);
+extern void st_backspace (st_parameter_filepos *);
export_proto(st_backspace);
void
-st_backspace (void)
+st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = find_unit (ioparm.unit);
+ u = find_unit (fpp->common.unit);
if (u == NULL)
{
- generate_error (ERROR_BAD_UNIT, NULL);
+ generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
goto done;
}
- current_unit = u;
-
/* Ignore direct access. Non-advancing I/O is only allowed for formatted
sequential I/O and the next direct access transfer repositions the file
anyway. */
@@ -170,9 +168,9 @@ st_backspace (void)
}
if (u->flags.form == FORM_FORMATTED)
- formatted_backspace ();
+ formatted_backspace (fpp, u);
else
- unformatted_backspace ();
+ unformatted_backspace (fpp, u);
u->endfile = NO_ENDFILE;
u->current_record = 0;
@@ -183,24 +181,29 @@ st_backspace (void)
}
-extern void st_endfile (void);
+extern void st_endfile (st_parameter_filepos *);
export_proto(st_endfile);
void
-st_endfile (void)
+st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = get_unit (0);
+ u = find_unit (fpp->common.unit);
if (u != NULL)
{
- current_unit = u; /* next_record() needs this set. */
if (u->current_record)
- next_record (1);
+ {
+ st_parameter_dt dtp;
+ dtp.common = fpp->common;
+ memset (&dtp.u.p, 0, sizeof (dtp.u.p));
+ dtp.u.p.current_unit = u;
+ next_record (&dtp, 1);
+ }
- flush(u->s);
+ flush (u->s);
struncate (u->s);
u->endfile = AFTER_ENDFILE;
}
@@ -209,21 +212,21 @@ st_endfile (void)
}
-extern void st_rewind (void);
+extern void st_rewind (st_parameter_filepos *);
export_proto(st_rewind);
void
-st_rewind (void)
+st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = find_unit (ioparm.unit);
+ u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->flags.access != ACCESS_SEQUENTIAL)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&fpp->common, ERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
{
@@ -239,7 +242,7 @@ st_rewind (void)
u->mode = READING;
u->last_record = 0;
if (sseek (u->s, 0) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ generate_error (&fpp->common, ERROR_OS, NULL);
u->endfile = NO_ENDFILE;
u->current_record = 0;
@@ -253,22 +256,19 @@ st_rewind (void)
}
-extern void st_flush (void);
+extern void st_flush (st_parameter_filepos *);
export_proto(st_flush);
void
-st_flush (void)
+st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = get_unit (0);
+ u = find_unit (fpp->common.unit);
if (u != NULL)
- {
- current_unit = u; /* Just to be sure. */
- flush(u->s);
- }
+ flush (u->s);
library_end ();
}
--- libgfortran/io/transfer.c.jj 2005-09-29 14:09:41.000000000 +0200
+++ libgfortran/io/transfer.c 2005-10-05 00:30:31.000000000 +0200
@@ -63,39 +63,26 @@ Boston, MA 02110-1301, USA. */
st_write(), an error inhibits any data from actually being
transferred. */
-extern void transfer_integer (void *, int);
+extern void transfer_integer (st_parameter_dt *, void *, int);
export_proto(transfer_integer);
-extern void transfer_real (void *, int);
+extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
-extern void transfer_logical (void *, int);
+extern void transfer_logical (st_parameter_dt *, void *, int);
export_proto(transfer_logical);
-extern void transfer_character (void *, int);
+extern void transfer_character (st_parameter_dt *, void *, int);
export_proto(transfer_character);
-extern void transfer_complex (void *, int);
+extern void transfer_complex (st_parameter_dt *, void *, int);
export_proto(transfer_complex);
-extern void transfer_array (gfc_array_char *, gfc_charlen_type);
+extern void transfer_array (st_parameter_dt *, gfc_array_char *,
+ gfc_charlen_type);
export_proto(transfer_array);
-gfc_unit *current_unit = NULL;
-static int sf_seen_eor = 0;
-static int eor_condition = 0;
-
-/* Maximum righthand column written to. */
-static int max_pos;
-/* Number of skips + spaces to be done for T and X-editing. */
-static int skips;
-/* Number of spaces to be done for T and X-editing. */
-static int pending_spaces;
-
char scratch[SCRATCH_SIZE];
-static char *line_buffer = NULL;
-
-static unit_advance advance_status;
static const st_option advance_opt[] = {
{"yes", ADVANCE_YES},
@@ -104,9 +91,6 @@ static const st_option advance_opt[] = {
};
-static void (*transfer) (bt, void *, int, size_t);
-
-
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT
@@ -115,18 +99,18 @@ file_mode;
static file_mode
-current_mode (void)
+current_mode (st_parameter_dt *dtp)
{
file_mode m;
- if (current_unit->flags.access == ACCESS_DIRECT)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- m = current_unit->flags.form == FORM_FORMATTED ?
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_DIRECT : UNFORMATTED_DIRECT;
}
else
{
- m = current_unit->flags.form == FORM_FORMATTED ?
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
}
@@ -151,20 +135,18 @@ current_mode (void)
heap. Hopefully this won't happen very often. */
static char *
-read_sf (int *length)
+read_sf (st_parameter_dt *dtp, int *length)
{
- static char data[SCRATCH_SIZE];
char *base, *p, *q;
int n, readlen;
if (*length > SCRATCH_SIZE)
- p = base = line_buffer = get_mem (*length);
- else
- p = base = data;
+ dtp->u.p.line_buffer = get_mem (*length);
+ p = base = dtp->u.p.line_buffer;
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
- if (sf_seen_eor)
+ if (dtp->u.p.sf_seen_eor)
{
*length = 0;
return base;
@@ -175,14 +157,14 @@ read_sf (int *length)
do
{
- if (is_internal_unit())
+ if (is_internal_unit (dtp))
{
/* readlen may be modified inside salloc_r if
is_internal_unit() is true. */
readlen = 1;
}
- q = salloc_r (current_unit->s, &readlen);
+ q = salloc_r (dtp->u.p.current_unit->s, &readlen);
if (q == NULL)
break;
@@ -190,7 +172,7 @@ read_sf (int *length)
EOR below. */
if (readlen < 1 && n == 0)
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
@@ -200,33 +182,33 @@ read_sf (int *length)
/* If we see an EOR during non-advancing I/O, we need to skip
the rest of the I/O statement. Set the corresponding flag. */
- if (advance_status == ADVANCE_NO || g.seen_dollar)
- eor_condition = 1;
+ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
+ dtp->u.p.eor_condition = 1;
/* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned,
so we can just continue with a short read. */
- if (current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
- current_unit->bytes_left = 0;
+ dtp->u.p.current_unit->bytes_left = 0;
*length = n;
- sf_seen_eor = 1;
+ dtp->u.p.sf_seen_eor = 1;
break;
}
n++;
*p++ = *q;
- sf_seen_eor = 0;
+ dtp->u.p.sf_seen_eor = 0;
}
while (n < *length);
- current_unit->bytes_left -= *length;
+ dtp->u.p.current_unit->bytes_left -= *length;
- if (ioparm.size != NULL)
- *ioparm.size += *length;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += *length;
return base;
}
@@ -243,41 +225,42 @@ read_sf (int *length)
short reads. */
void *
-read_block (int *length)
+read_block (st_parameter_dt *dtp, int *length)
{
char *source;
int nread;
- if (current_unit->flags.form == FORM_FORMATTED &&
- current_unit->flags.access == ACCESS_SEQUENTIAL)
- return read_sf (length); /* Special case. */
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ return read_sf (dtp, length); /* Special case. */
- if (current_unit->bytes_left < *length)
+ if (dtp->u.p.current_unit->bytes_left < *length)
{
- if (current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
- generate_error (ERROR_EOR, NULL); /* Not enough data left. */
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ /* Not enough data left. */
return NULL;
}
- *length = current_unit->bytes_left;
+ *length = dtp->u.p.current_unit->bytes_left;
}
- current_unit->bytes_left -= *length;
+ dtp->u.p.current_unit->bytes_left -= *length;
nread = *length;
- source = salloc_r (current_unit->s, &nread);
+ source = salloc_r (dtp->u.p.current_unit->s, &nread);
- if (ioparm.size != NULL)
- *ioparm.size += nread;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += nread;
if (nread != *length)
{ /* Short read, this shouldn't happen. */
- if (current_unit->flags.pad == PAD_YES)
+ if (dtp->u.p.current_unit->flags.pad == PAD_YES)
*length = nread;
else
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
source = NULL;
}
}
@@ -292,21 +275,21 @@ read_block (int *length)
fill in. Returns NULL on error. */
void *
-write_block (int length)
+write_block (st_parameter_dt *dtp, int length)
{
char *dest;
- if (current_unit->bytes_left < length)
+ if (dtp->u.p.current_unit->bytes_left < length)
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
- current_unit->bytes_left -= (gfc_offset)length;
- dest = salloc_w (current_unit->s, &length);
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset)length;
+ dest = salloc_w (dtp->u.p.current_unit->s, dtp, &length);
- if (ioparm.size != NULL)
- *ioparm.size += length;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += length;
return dest;
}
@@ -315,7 +298,8 @@ write_block (int length)
/* Master function for unformatted reads. */
static void
-unformatted_read (bt type, void *dest, int length, size_t nelems)
+unformatted_read (st_parameter_dt *dtp, bt type, void *dest,
+ int length, size_t nelems)
{
void *source;
int w;
@@ -329,7 +313,7 @@ unformatted_read (bt type, void *dest, i
length *= 2;
w = length;
- source = read_block (&w);
+ source = read_block (dtp, &w);
if (source != NULL)
{
@@ -342,7 +326,8 @@ unformatted_read (bt type, void *dest, i
/* Master function for unformatted writes. */
static void
-unformatted_write (bt type, void *source, int length, size_t nelems)
+unformatted_write (st_parameter_dt *dtp, bt type, void *source, int length,
+ size_t nelems)
{
void *dest;
size_t len;
@@ -353,7 +338,7 @@ unformatted_write (bt type, void *source
if (type == BT_COMPLEX)
len *= 2;
- dest = write_block (len);
+ dest = write_block (dtp, len);
if (dest != NULL)
memcpy (dest, source, len);
}
@@ -384,7 +369,7 @@ type_name (bt type)
p = "COMPLEX";
break;
default:
- internal_error ("type_name(): Bad type");
+ internal_error (NULL, "type_name(): Bad type");
}
return p;
@@ -396,7 +381,7 @@ type_name (bt type)
in it. The length in the format node is the true length. */
static void
-write_constant_string (fnode * f)
+write_constant_string (st_parameter_dt *dtp, fnode * f)
{
char c, delimiter, *p, *q;
int length;
@@ -405,7 +390,7 @@ write_constant_string (fnode * f)
if (length == 0)
return;
- p = write_block (length);
+ p = write_block (dtp, length);
if (p == NULL)
return;
@@ -426,7 +411,7 @@ write_constant_string (fnode * f)
nonzero if something went wrong. */
static int
-require_type (bt expected, bt actual, fnode * f)
+require_type (st_parameter_dt *dtp, bt expected, bt actual, fnode * f)
{
char buffer[100];
@@ -434,9 +419,9 @@ require_type (bt expected, bt actual, fn
return 0;
st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
- type_name (expected), g.item_count, type_name (actual));
+ type_name (expected), dtp->u.p.item_count, type_name (actual));
- format_error (f, buffer);
+ format_error (dtp, f, buffer);
return 1;
}
@@ -450,8 +435,9 @@ require_type (bt expected, bt actual, fn
of the next element, then comes back here to process it. */
static void
-formatted_transfer_scalar (bt type, void *p, int len)
+formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len)
{
+ char scratch[SCRATCH_SIZE];
int pos, bytes_used;
fnode *f;
format_token t;
@@ -466,77 +452,79 @@ formatted_transfer_scalar (bt type, void
/* If there's an EOR condition, we simulate finalizing the transfer
by doing nothing. */
- if (eor_condition)
+ if (dtp->u.p.eor_condition)
return;
+ dtp->u.p.line_buffer = scratch;
for (;;)
{
/* If reversion has occurred and there is another real data item,
then we have to move to the next record. */
- if (g.reversion_flag && n > 0)
+ if (dtp->u.p.reversion_flag && n > 0)
{
- g.reversion_flag = 0;
- next_record (0);
+ dtp->u.p.reversion_flag = 0;
+ next_record (dtp, 0);
}
consume_data_flag = 1 ;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break;
- f = next_format ();
+ f = next_format (dtp);
if (f == NULL)
return; /* No data descriptors left (already raised). */
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
t = f->format;
- if (g.mode == WRITING && skips != 0
+ if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
|| t == FMT_L || t == FMT_A || t == FMT_D))
|| t == FMT_STRING))
{
- if (skips > 0)
+ if (dtp->u.p.skips > 0)
{
- write_x (skips, pending_spaces);
- max_pos = (int)(current_unit->recl - current_unit->bytes_left);
+ write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+ dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
}
- if (skips < 0)
+ if (dtp->u.p.skips < 0)
{
- move_pos_offset (current_unit->s, skips);
- current_unit->bytes_left -= (gfc_offset)skips;
+ move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
}
- skips = pending_spaces = 0;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
- bytes_used = (int)(current_unit->recl - current_unit->bytes_left);
+ bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
switch (t)
{
case FMT_I:
if (n == 0)
goto need_data;
- if (require_type (BT_INTEGER, type, f))
+ if (require_type (dtp, BT_INTEGER, type, f))
return;
- if (g.mode == READING)
- read_decimal (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_decimal (dtp, f, p, len);
else
- write_i (f, p, len);
+ write_i (dtp, f, p, len);
break;
case FMT_B:
if (n == 0)
goto need_data;
- if (require_type (BT_INTEGER, type, f))
+ if (require_type (dtp, BT_INTEGER, type, f))
return;
- if (g.mode == READING)
- read_radix (f, p, len, 2);
+ if (dtp->u.p.mode == READING)
+ read_radix (dtp, f, p, len, 2);
else
- write_b (f, p, len);
+ write_b (dtp, f, p, len);
break;
@@ -544,10 +532,10 @@ formatted_transfer_scalar (bt type, void
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_radix (f, p, len, 8);
+ if (dtp->u.p.mode == READING)
+ read_radix (dtp, f, p, len, 8);
else
- write_o (f, p, len);
+ write_o (dtp, f, p, len);
break;
@@ -555,10 +543,10 @@ formatted_transfer_scalar (bt type, void
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_radix (f, p, len, 16);
+ if (dtp->u.p.mode == READING)
+ read_radix (dtp, f, p, len, 16);
else
- write_z (f, p, len);
+ write_z (dtp, f, p, len);
break;
@@ -566,10 +554,10 @@ formatted_transfer_scalar (bt type, void
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_a (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_a (dtp, f, p, len);
else
- write_a (f, p, len);
+ write_a (dtp, f, p, len);
break;
@@ -577,94 +565,94 @@ formatted_transfer_scalar (bt type, void
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_l (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_l (dtp, f, p, len);
else
- write_l (f, p, len);
+ write_l (dtp, f, p, len);
break;
case FMT_D:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_d (f, p, len);
+ write_d (dtp, f, p, len);
break;
case FMT_E:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_e (f, p, len);
+ write_e (dtp, f, p, len);
break;
case FMT_EN:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_en (f, p, len);
+ write_en (dtp, f, p, len);
break;
case FMT_ES:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_es (f, p, len);
+ write_es (dtp, f, p, len);
break;
case FMT_F:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_f (f, p, len);
+ write_f (dtp, f, p, len);
break;
case FMT_G:
if (n == 0)
goto need_data;
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
switch (type)
{
case BT_INTEGER:
- read_decimal (f, p, len);
+ read_decimal (dtp, f, p, len);
break;
case BT_LOGICAL:
- read_l (f, p, len);
+ read_l (dtp, f, p, len);
break;
case BT_CHARACTER:
- read_a (f, p, len);
+ read_a (dtp, f, p, len);
break;
case BT_REAL:
- read_f (f, p, len);
+ read_f (dtp, f, p, len);
break;
default:
goto bad_type;
@@ -673,32 +661,33 @@ formatted_transfer_scalar (bt type, void
switch (type)
{
case BT_INTEGER:
- write_i (f, p, len);
+ write_i (dtp, f, p, len);
break;
case BT_LOGICAL:
- write_l (f, p, len);
+ write_l (dtp, f, p, len);
break;
case BT_CHARACTER:
- write_a (f, p, len);
+ write_a (dtp, f, p, len);
break;
case BT_REAL:
- write_d (f, p, len);
+ write_d (dtp, f, p, len);
break;
default:
bad_type:
- internal_error ("formatted_transfer(): Bad type");
+ internal_error (&dtp->common,
+ "formatted_transfer(): Bad type");
}
break;
case FMT_STRING:
consume_data_flag = 0 ;
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
- format_error (f, "Constant string in input format");
+ format_error (dtp, f, "Constant string in input format");
return;
}
- write_constant_string (f);
+ write_constant_string (dtp, f);
break;
/* Format codes that don't transfer data. */
@@ -706,14 +695,14 @@ formatted_transfer_scalar (bt type, void
case FMT_TR:
consume_data_flag = 0 ;
- pos = bytes_used + f->u.n + skips;
- skips = f->u.n + skips;
- pending_spaces = pos - max_pos;
+ pos = bytes_used + f->u.n + dtp->u.p.skips;
+ dtp->u.p.skips = f->u.n + dtp->u.p.skips;
+ dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
/* Writes occur just before the switch on f->format, above, so that
trailing blanks are suppressed. */
- if (g.mode == READING)
- read_x (f->u.n);
+ if (dtp->u.p.mode == READING)
+ read_x (dtp, f->u.n);
break;
@@ -733,23 +722,25 @@ formatted_transfer_scalar (bt type, void
bring us back again. */
pos = pos < 0 ? 0 : pos;
- skips = skips + pos - bytes_used;
- pending_spaces = pending_spaces + pos - max_pos;
+ dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ + pos - dtp->u.p.max_pos;
- if (skips == 0)
+ if (dtp->u.p.skips == 0)
break;
/* Writes occur just before the switch on f->format, above, so that
trailing blanks are suppressed. */
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
- if (skips > 0)
- read_x (skips);
- if (skips < 0)
+ if (dtp->u.p.skips > 0)
+ read_x (dtp, dtp->u.p.skips);
+ if (dtp->u.p.skips < 0)
{
- move_pos_offset (current_unit->s, skips);
- current_unit->bytes_left -= (gfc_offset)skips;
- skips = pending_spaces = 0;
+ move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ dtp->u.p.current_unit->bytes_left
+ -= (gfc_offset) dtp->u.p.skips;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
}
@@ -757,43 +748,43 @@ formatted_transfer_scalar (bt type, void
case FMT_S:
consume_data_flag = 0 ;
- g.sign_status = SIGN_S;
+ dtp->u.p.sign_status = SIGN_S;
break;
case FMT_SS:
consume_data_flag = 0 ;
- g.sign_status = SIGN_SS;
+ dtp->u.p.sign_status = SIGN_SS;
break;
case FMT_SP:
consume_data_flag = 0 ;
- g.sign_status = SIGN_SP;
+ dtp->u.p.sign_status = SIGN_SP;
break;
case FMT_BN:
consume_data_flag = 0 ;
- g.blank_status = BLANK_NULL;
+ dtp->u.p.blank_status = BLANK_NULL;
break;
case FMT_BZ:
consume_data_flag = 0 ;
- g.blank_status = BLANK_ZERO;
+ dtp->u.p.blank_status = BLANK_ZERO;
break;
case FMT_P:
consume_data_flag = 0 ;
- g.scale_factor = f->u.k;
+ dtp->u.p.scale_factor = f->u.k;
break;
case FMT_DOLLAR:
consume_data_flag = 0 ;
- g.seen_dollar = 1;
+ dtp->u.p.seen_dollar = 1;
break;
case FMT_SLASH:
consume_data_flag = 0 ;
- skips = pending_spaces = 0;
- next_record (0);
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+ next_record (dtp, 0);
break;
case FMT_COLON:
@@ -807,17 +798,17 @@ formatted_transfer_scalar (bt type, void
break;
default:
- internal_error ("Bad format node");
+ internal_error (&dtp->common, "Bad format node");
}
/* Free a buffer that we had to allocate during a sequential
formatted read of a block that was larger than the static
buffer. */
- if (line_buffer != NULL)
+ if (dtp->u.p.line_buffer != scratch)
{
- free_mem (line_buffer);
- line_buffer = NULL;
+ free_mem (dtp->u.p.line_buffer);
+ dtp->u.p.line_buffer = scratch;
}
/* Adjust the item count and data pointer. */
@@ -828,11 +819,11 @@ formatted_transfer_scalar (bt type, void
p = ((char *) p) + len;
}
- if (g.mode == READING)
- skips = 0;
+ if (dtp->u.p.mode == READING)
+ dtp->u.p.skips = 0;
- pos = (int)(current_unit->recl - current_unit->bytes_left);
- max_pos = (max_pos > pos) ? max_pos : pos;
+ pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+ dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
}
@@ -846,7 +837,8 @@ formatted_transfer_scalar (bt type, void
}
static void
-formatted_transfer (bt type, void *p, int len, size_t nelems)
+formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int len,
+ size_t nelems)
{
size_t elem;
int size;
@@ -862,8 +854,8 @@ formatted_transfer (bt type, void *p, in
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
- g.item_count++;
- formatted_transfer_scalar (type, tmp + size*elem, len);
+ dtp->u.p.item_count++;
+ formatted_transfer_scalar (dtp, type, tmp + size*elem, len);
}
}
@@ -874,52 +866,53 @@ formatted_transfer (bt type, void *p, in
share a common enum with the compiler. */
void
-transfer_integer (void *p, int kind)
+transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_INTEGER, p, kind, 1);
+ dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, 1);
}
void
-transfer_real (void *p, int kind)
+transfer_real (st_parameter_dt *dtp, void *p, int kind)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_REAL, p, kind, 1);
+ dtp->u.p.transfer (dtp, BT_REAL, p, kind, 1);
}
void
-transfer_logical (void *p, int kind)
+transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_LOGICAL, p, kind, 1);
+ dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, 1);
}
void
-transfer_character (void *p, int len)
+transfer_character (st_parameter_dt *dtp, void *p, int len)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_CHARACTER, p, len, 1);
+ dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, 1);
}
void
-transfer_complex (void *p, int kind)
+transfer_complex (st_parameter_dt *dtp, void *p, int kind)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_COMPLEX, p, kind, 1);
+ dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, 1);
}
void
-transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc,
+ gfc_charlen_type charlen)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
@@ -929,7 +922,7 @@ transfer_array (gfc_array_char *desc, gf
char *data;
bt iotype;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
type = GFC_DESCRIPTOR_TYPE (desc);
@@ -967,10 +960,11 @@ transfer_array (gfc_array_char *desc, gf
kind = charlen;
break;
case GFC_DTYPE_DERIVED:
- internal_error ("Derived type I/O should have been handled via the frontend.");
+ internal_error (&dtp->common,
+ "Derived type I/O should have been handled via the frontend.");
break;
default:
- internal_error ("transfer_array(): Bad type");
+ internal_error (&dtp->common, "transfer_array(): Bad type");
}
if (desc->dim[0].stride == 0)
@@ -1002,7 +996,7 @@ transfer_array (gfc_array_char *desc, gf
while (data)
{
- transfer (iotype, data, kind, tsize);
+ dtp->u.p.transfer (dtp, iotype, data, kind, tsize);
data += stride0 * size * tsize;
count[0] += tsize;
n = 0;
@@ -1029,26 +1023,26 @@ transfer_array (gfc_array_char *desc, gf
/* Preposition a sequential unformatted file while reading. */
static void
-us_read (void)
+us_read (st_parameter_dt *dtp)
{
char *p;
int n;
gfc_offset i;
n = sizeof (gfc_offset);
- p = salloc_r (current_unit->s, &n);
+ p = salloc_r (dtp->u.p.current_unit->s, &n);
if (n == 0)
return; /* end of file */
if (p == NULL || n != sizeof (gfc_offset))
{
- generate_error (ERROR_BAD_US, NULL);
+ generate_error (&dtp->common, ERROR_BAD_US, NULL);
return;
}
memcpy (&i, p, sizeof (gfc_offset));
- current_unit->bytes_left = i;
+ dtp->u.p.current_unit->bytes_left = i;
}
@@ -1056,30 +1050,30 @@ us_read (void)
amount to writing a bogus length that will be filled in later. */
static void
-us_write (void)
+us_write (st_parameter_dt *dtp)
{
char *p;
int length;
length = sizeof (gfc_offset);
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, dtp, &length);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
memset (p, '\0', sizeof (gfc_offset)); /* Bogus value for now. */
- if (sfree (current_unit->s) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
/* For sequential unformatted, we write until we have more bytes than
can fit in the record markers. If disk space runs out first, it will
error on the write. */
- current_unit->recl = g.max_offset;
+ dtp->u.p.current_unit->recl = g.max_offset;
- current_unit->bytes_left = current_unit->recl;
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
@@ -1088,29 +1082,29 @@ us_write (void)
record. */
static void
-pre_position (void)
+pre_position (st_parameter_dt *dtp)
{
- if (current_unit->current_record)
+ if (dtp->u.p.current_unit->current_record)
return; /* Already positioned. */
- switch (current_mode ())
+ switch (current_mode (dtp))
{
case UNFORMATTED_SEQUENTIAL:
- if (g.mode == READING)
- us_read ();
+ if (dtp->u.p.mode == READING)
+ us_read (dtp);
else
- us_write ();
+ us_write (dtp);
break;
case FORMATTED_SEQUENTIAL:
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
- current_unit->bytes_left = current_unit->recl;
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
break;
}
- current_unit->current_record = 1;
+ dtp->u.p.current_unit->current_record = 1;
}
@@ -1118,21 +1112,28 @@ pre_position (void)
both reading and writing. */
static void
-data_transfer_init (int read_flag)
+data_transfer_init (st_parameter_dt *dtp, int read_flag)
{
unit_flags u_flags; /* Used for creating a unit if needed. */
+ GFC_INTEGER_4 cf = dtp->common.flags;
+ namelist_info *ionml;
- g.mode = read_flag ? READING : WRITING;
+ ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
+ memset (&dtp->u.p, 0, sizeof (dtp->u.p));
+ dtp->u.p.ionml = ionml;
+ dtp->u.p.mode = read_flag ? READING : WRITING;
- if (ioparm.size != NULL)
- *ioparm.size = 0; /* Initialize the count. */
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size = 0; /* Initialize the count. */
- current_unit = get_unit (read_flag);
- if (current_unit == NULL)
+ dtp->u.p.current_unit = get_unit (dtp);
+ if (dtp->u.p.current_unit == NULL)
{ /* Open the unit with some default flags. */
- if (ioparm.unit < 0)
+ st_parameter_open opp;
+ if (dtp->common.unit < 0)
{
- generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Bad unit number in OPEN statement");
library_end ();
return;
}
@@ -1140,7 +1141,7 @@ data_transfer_init (int read_flag)
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
/* Is it unformatted? */
- if (ioparm.format == NULL && !ioparm.list_format)
+ if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
u_flags.form = FORM_UNFORMATTED;
else
u_flags.form = FORM_UNSPECIFIED;
@@ -1148,211 +1149,221 @@ data_transfer_init (int read_flag)
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN;
- new_unit(&u_flags);
- current_unit = get_unit (read_flag);
+ opp.common = dtp->common;
+ opp.common.flags &= IOPARM_COMMON_MASK;
+ new_unit (&opp, &u_flags);
+ dtp->common.flags &= ~IOPARM_COMMON_MASK;
+ dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
+ dtp->u.p.current_unit = get_unit (dtp);
}
- if (current_unit == NULL)
+ if (dtp->u.p.current_unit == NULL)
return;
/* Check the action. */
- if (read_flag && current_unit->flags.action == ACTION_WRITE)
- generate_error (ERROR_BAD_ACTION,
+ if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
+ generate_error (&dtp->common, ERROR_BAD_ACTION,
"Cannot read from file opened for WRITE");
- if (!read_flag && current_unit->flags.action == ACTION_READ)
- generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
+ if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
+ generate_error (&dtp->common, ERROR_BAD_ACTION,
+ "Cannot write to file opened for READ");
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
+ dtp->u.p.first_item = 1;
+
/* Check the format. */
- if (ioparm.format)
- parse_format ();
+ if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
+ parse_format (dtp);
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- if (current_unit->flags.form == FORM_UNFORMATTED
- && (ioparm.format != NULL || ioparm.list_format))
- generate_error (ERROR_OPTION_CONFLICT,
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
+ && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
+ != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Format present for UNFORMATTED data transfer");
- if (ioparm.namelist_name != NULL && ionml != NULL)
+ if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
{
- if(ioparm.format != NULL)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"A format cannot be specified with a namelist");
}
- else if (current_unit->flags.form == FORM_FORMATTED &&
- ioparm.format == NULL && !ioparm.list_format)
- generate_error (ERROR_OPTION_CONFLICT,
+ else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Missing format for FORMATTED data transfer");
- if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
- generate_error (ERROR_OPTION_CONFLICT,
+ if (is_internal_unit (dtp)
+ && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED data transfer");
/* Check the record number. */
- if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
+ && (cf & IOPARM_DT_HAS_REC) == 0)
{
- generate_error (ERROR_MISSING_OPTION,
+ generate_error (&dtp->common, ERROR_MISSING_OPTION,
"Direct access data transfer requires record number");
return;
}
- if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+ && (cf & IOPARM_DT_HAS_REC) != 0)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Record number not allowed for sequential access data transfer");
return;
}
/* Process the ADVANCE option. */
- advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
- find_option (ioparm.advance, ioparm.advance_len, advance_opt,
- "Bad ADVANCE parameter in data transfer statement");
+ dtp->u.p.advance_status
+ = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
+ find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
+ "Bad ADVANCE parameter in data transfer statement");
- if (advance_status != ADVANCE_UNSPECIFIED)
+ if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
{
- if (current_unit->flags.access == ACCESS_DIRECT)
- generate_error (ERROR_OPTION_CONFLICT,
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with sequential access");
- if (is_internal_unit ())
- generate_error (ERROR_OPTION_CONFLICT,
+ if (is_internal_unit (dtp))
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with internal file");
- if (ioparm.format == NULL || ioparm.list_format)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
+ != IOPARM_DT_HAS_FORMAT)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification requires an explicit format");
}
if (read_flag)
{
- if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
- generate_error (ERROR_MISSING_OPTION,
+ if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+ generate_error (&dtp->common, ERROR_MISSING_OPTION,
"EOR specification requires an ADVANCE specification of NO");
- if (ioparm.size != NULL && advance_status != ADVANCE_NO)
- generate_error (ERROR_MISSING_OPTION,
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+ generate_error (&dtp->common, ERROR_MISSING_OPTION,
"SIZE specification requires an ADVANCE specification of NO");
}
else
{ /* Write constraints. */
- if (ioparm.end != 0)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_END) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"END specification cannot appear in a write statement");
- if (ioparm.eor != 0)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_EOR) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"EOR specification cannot appear in a write statement");
- if (ioparm.size != 0)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"SIZE specification cannot appear in a write statement");
}
- if (advance_status == ADVANCE_UNSPECIFIED)
- advance_status = ADVANCE_YES;
- if (ioparm.library_return != LIBRARY_OK)
+ if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
+ dtp->u.p.advance_status = ADVANCE_YES;
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
/* Sanity checks on the record number. */
- if (ioparm.rec)
+ if ((cf & IOPARM_DT_HAS_REC) != 0)
{
- if (ioparm.rec <= 0)
+ if (dtp->rec <= 0)
{
- generate_error (ERROR_BAD_OPTION, "Record number must be positive");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Record number must be positive");
return;
}
- if (ioparm.rec >= current_unit->maxrec)
+ if (dtp->rec >= dtp->u.p.current_unit->maxrec)
{
- generate_error (ERROR_BAD_OPTION, "Record number too large");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Record number too large");
return;
}
/* Check to see if we might be reading what we wrote before */
- if (g.mode == READING && current_unit->mode == WRITING)
- flush(current_unit->s);
+ if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING)
+ flush(dtp->u.p.current_unit->s);
/* Check whether the record exists to be read. Only
a partial record needs to exist. */
- if (g.mode == READING && (ioparm.rec -1)
- * current_unit->recl >= file_length (current_unit->s))
+ if (dtp->u.p.mode == READING && (dtp->rec -1)
+ * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
{
- generate_error (ERROR_BAD_OPTION, "Non-existing record number");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Non-existing record number");
return;
}
/* Position the file. */
- if (sseek (current_unit->s,
- (ioparm.rec - 1) * current_unit->recl) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s,
+ (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
}
/* Overwriting an existing sequential file ?
it is always safe to truncate the file on the first write */
- if (g.mode == WRITING
- && current_unit->flags.access == ACCESS_SEQUENTIAL
- && current_unit->last_record == 0 && !is_preconnected(current_unit->s))
- struncate(current_unit->s);
+ if (dtp->u.p.mode == WRITING
+ && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+ && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
+ struncate(dtp->u.p.current_unit->s);
- current_unit->mode = g.mode;
+ dtp->u.p.current_unit->mode = dtp->u.p.mode;
/* Set the initial value of flags. */
- g.blank_status = current_unit->flags.blank;
- g.sign_status = SIGN_S;
- g.scale_factor = 0;
- g.seen_dollar = 0;
- g.first_item = 1;
- g.item_count = 0;
- sf_seen_eor = 0;
- eor_condition = 0;
+ dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+ dtp->u.p.sign_status = SIGN_S;
- pre_position ();
+ pre_position (dtp);
/* Set up the subroutine that will handle the transfers. */
if (read_flag)
{
- if (current_unit->flags.form == FORM_UNFORMATTED)
- transfer = unformatted_read;
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_read;
else
{
- if (ioparm.list_format)
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
- transfer = list_formatted_read;
+ dtp->u.p.transfer = list_formatted_read;
init_at_eol();
}
else
- transfer = formatted_transfer;
+ dtp->u.p.transfer = formatted_transfer;
}
}
else
{
- if (current_unit->flags.form == FORM_UNFORMATTED)
- transfer = unformatted_write;
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_write;
else
{
- if (ioparm.list_format)
- transfer = list_formatted_write;
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_write;
else
- transfer = formatted_transfer;
+ dtp->u.p.transfer = formatted_transfer;
}
}
@@ -1360,26 +1371,24 @@ data_transfer_init (int read_flag)
if (read_flag)
{
- if (current_unit->read_bad)
+ if (dtp->u.p.current_unit->read_bad)
{
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE");
return;
}
}
else
{
- if (advance_status == ADVANCE_YES && !g.seen_dollar)
- current_unit->read_bad = 1;
+ if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
+ dtp->u.p.current_unit->read_bad = 1;
}
- /* Reset counters for T and X-editing. */
- max_pos = skips = pending_spaces = 0;
-
/* Start the data transfer if we are doing a formatted transfer. */
- if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
- && ioparm.namelist_name == NULL && ionml == NULL)
- formatted_transfer (0, NULL, 0, 1);
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+ && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
+ && dtp->u.p.ionml == NULL)
+ formatted_transfer (dtp, 0, NULL, 0, 1);
}
@@ -1390,49 +1399,49 @@ data_transfer_init (int read_flag)
#define MAX_READ 4096
static void
-next_record_r (void)
+next_record_r (st_parameter_dt *dtp)
{
int rlength, length, bytes_left;
gfc_offset new;
char *p;
- switch (current_mode ())
+ switch (current_mode (dtp))
{
case UNFORMATTED_SEQUENTIAL:
- current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */
+ dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */
/* Fall through... */
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
- if (current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
break;
- if (is_seekable (current_unit->s))
+ if (is_seekable (dtp->u.p.current_unit->s))
{
- new = file_position (current_unit->s) + current_unit->bytes_left;
+ new = file_position (dtp->u.p.current_unit->s) + dtp->u.p.current_unit->bytes_left;
/* Direct access files do not generate END conditions,
only I/O errors. */
- if (sseek (current_unit->s, new) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
}
else
{ /* Seek by reading data. */
- while (current_unit->bytes_left > 0)
+ while (dtp->u.p.current_unit->bytes_left > 0)
{
- rlength = length = (MAX_READ > current_unit->bytes_left) ?
- MAX_READ : current_unit->bytes_left;
+ rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
+ MAX_READ : dtp->u.p.current_unit->bytes_left;
- p = salloc_r (current_unit->s, &rlength);
+ p = salloc_r (dtp->u.p.current_unit->s, &rlength);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
- current_unit->bytes_left -= length;
+ dtp->u.p.current_unit->bytes_left -= length;
}
}
break;
@@ -1440,33 +1449,33 @@ next_record_r (void)
case FORMATTED_SEQUENTIAL:
length = 1;
/* sf_read has already terminated input because of an '\n' */
- if (sf_seen_eor)
+ if (dtp->u.p.sf_seen_eor)
{
- sf_seen_eor=0;
+ dtp->u.p.sf_seen_eor = 0;
break;
}
- if (is_internal_unit())
+ if (is_internal_unit (dtp))
{
- bytes_left = (int) current_unit->bytes_left;
- p = salloc_r (current_unit->s, &bytes_left);
+ bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+ p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
if (p != NULL)
- current_unit->bytes_left = current_unit->recl;
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
break;
}
else do
{
- p = salloc_r (current_unit->s, &length);
+ p = salloc_r (dtp->u.p.current_unit->s, &length);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
if (length == 0)
{
- current_unit->endfile = AT_ENDFILE;
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
}
@@ -1475,100 +1484,100 @@ next_record_r (void)
break;
}
- if (current_unit->flags.access == ACCESS_SEQUENTIAL)
- test_endfile (current_unit);
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ test_endfile (dtp->u.p.current_unit);
}
/* Position to the next record in write mode. */
static void
-next_record_w (void)
+next_record_w (st_parameter_dt *dtp)
{
gfc_offset c, m;
int length, bytes_left;
char *p;
/* Zero counters for X- and T-editing. */
- max_pos = skips = pending_spaces = 0;
+ dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
- switch (current_mode ())
+ switch (current_mode (dtp))
{
case FORMATTED_DIRECT:
- if (current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
break;
- length = current_unit->bytes_left;
- p = salloc_w (current_unit->s, &length);
+ length = dtp->u.p.current_unit->bytes_left;
+ p = salloc_w (dtp->u.p.current_unit->s, dtp, &length);
if (p == NULL)
goto io_error;
- memset (p, ' ', current_unit->bytes_left);
- if (sfree (current_unit->s) == FAILURE)
+ memset (p, ' ', dtp->u.p.current_unit->bytes_left);
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
break;
case UNFORMATTED_DIRECT:
- if (sfree (current_unit->s) == FAILURE)
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
break;
case UNFORMATTED_SEQUENTIAL:
- m = current_unit->recl - current_unit->bytes_left; /* Bytes written. */
- c = file_position (current_unit->s);
+ m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left; /* Bytes written. */
+ c = file_position (dtp->u.p.current_unit->s);
length = sizeof (gfc_offset);
/* Write the length tail. */
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, dtp, &length);
if (p == NULL)
goto io_error;
memcpy (p, &m, sizeof (gfc_offset));
- if (sfree (current_unit->s) == FAILURE)
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
/* Seek to the head and overwrite the bogus length with the real
length. */
- p = salloc_w_at (current_unit->s, &length, c - m - length);
+ p = salloc_w_at (dtp->u.p.current_unit->s, dtp, &length, c - m - length);
if (p == NULL)
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
memcpy (p, &m, sizeof (gfc_offset));
- if (sfree (current_unit->s) == FAILURE)
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
/* Seek past the end of the current record. */
- if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
goto io_error;
break;
case FORMATTED_SEQUENTIAL:
- if (current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
break;
- if (is_internal_unit())
+ if (is_internal_unit (dtp))
{
- if (is_array_io())
+ if (is_array_io (dtp))
{
- bytes_left = (int) current_unit->bytes_left;
- p = salloc_w (current_unit->s, &bytes_left);
+ bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+ p = salloc_w (dtp->u.p.current_unit->s, dtp, &bytes_left);
if (p != NULL)
{
memset(p, ' ', bytes_left);
- current_unit->bytes_left = current_unit->recl;
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
}
else
{
length = 1;
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, dtp, &length);
}
}
else
@@ -1578,7 +1587,7 @@ next_record_w (void)
#else
length = 1;
#endif
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, dtp, &length);
if (p)
{ /* No new line for internal writes. */
#ifdef HAVE_CRLF
@@ -1595,7 +1604,7 @@ next_record_w (void)
break;
io_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
}
@@ -1607,33 +1616,33 @@ next_record_w (void)
the next record. */
void
-next_record (int done)
+next_record (st_parameter_dt *dtp, int done)
{
gfc_offset fp; /* File position. */
- current_unit->read_bad = 0;
+ dtp->u.p.current_unit->read_bad = 0;
- if (g.mode == READING)
- next_record_r ();
+ if (dtp->u.p.mode == READING)
+ next_record_r (dtp);
else
- next_record_w ();
+ next_record_w (dtp);
/* keep position up to date for INQUIRE */
- current_unit->flags.position = POSITION_ASIS;
+ dtp->u.p.current_unit->flags.position = POSITION_ASIS;
- current_unit->current_record = 0;
- if (current_unit->flags.access == ACCESS_DIRECT)
+ dtp->u.p.current_unit->current_record = 0;
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- fp = file_position (current_unit->s);
+ fp = file_position (dtp->u.p.current_unit->s);
/* Calculate next record, rounding up partial records. */
- current_unit->last_record = (fp + current_unit->recl - 1)
- / current_unit->recl;
+ dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
+ / dtp->u.p.current_unit->recl;
}
else
- current_unit->last_record++;
+ dtp->u.p.current_unit->last_record++;
if (!done)
- pre_position ();
+ pre_position (dtp);
}
@@ -1642,59 +1651,61 @@ next_record (int done)
steam associated with the unit. */
static void
-finalize_transfer (void)
+finalize_transfer (st_parameter_dt *dtp)
{
+ GFC_INTEGER_4 cf = dtp->common.flags;
- if (eor_condition)
+ if (dtp->u.p.eor_condition)
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return;
}
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- if ((ionml != NULL) && (ioparm.namelist_name != NULL))
+ if ((dtp->u.p.ionml != NULL)
+ && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
{
- if (ioparm.namelist_read_mode)
- namelist_read();
+ if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
+ namelist_read (dtp);
else
- namelist_write();
+ namelist_write (dtp);
}
- transfer = NULL;
- if (current_unit == NULL)
+ dtp->u.p.transfer = NULL;
+ if (dtp->u.p.current_unit == NULL)
return;
if (setjmp (g.eof_jump))
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return;
}
- if (ioparm.list_format && g.mode == READING)
- finish_list_read ();
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
+ finish_list_read (dtp);
else
{
free_fnodes ();
- if (advance_status == ADVANCE_NO || g.seen_dollar)
+ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
{
/* Most systems buffer lines, so force the partial record
to be written out. */
- flush (current_unit->s);
- g.seen_dollar = 0;
+ flush (dtp->u.p.current_unit->s);
+ dtp->u.p.seen_dollar = 0;
return;
}
- next_record (1);
- current_unit->current_record = 0;
+ next_record (dtp, 1);
+ dtp->u.p.current_unit->current_record = 0;
}
- sfree (current_unit->s);
+ sfree (dtp->u.p.current_unit->s);
- if (is_internal_unit ())
- sclose (current_unit->s);
+ if (is_internal_unit (dtp))
+ sclose (dtp->u.p.current_unit->s);
}
@@ -1702,15 +1713,16 @@ finalize_transfer (void)
data transfer, it just updates the length counter. */
static void
-iolength_transfer (bt type, void *dest __attribute__ ((unused)),
+iolength_transfer (st_parameter_dt *dtp, bt type,
+ void *dest __attribute__ ((unused)),
int len, size_t nelems)
{
- if (ioparm.iolength != NULL)
+ if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
{
if (type == BT_COMPLEX)
- *ioparm.iolength += 2 * len * nelems;
+ *dtp->iolength += 2 * len * nelems;
else
- *ioparm.iolength += len * nelems;
+ *dtp->iolength += len * nelems;
}
}
@@ -1720,16 +1732,16 @@ iolength_transfer (bt type, void *dest _
doesn't have to deal with units at all. */
static void
-iolength_transfer_init (void)
+iolength_transfer_init (st_parameter_dt *dtp)
{
- if (ioparm.iolength != NULL)
- *ioparm.iolength = 0;
+ if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
+ *dtp->iolength = 0;
- g.item_count = 0;
+ memset (&dtp->u.p, 0, sizeof (dtp->u.p));
/* Set up the subroutine that will handle the transfers. */
- transfer = iolength_transfer;
+ dtp->u.p.transfer = iolength_transfer;
}
@@ -1738,131 +1750,135 @@ iolength_transfer_init (void)
it must still be a runtime library call so that we can determine
the iolength for dynamic arrays and such. */
-extern void st_iolength (void);
+extern void st_iolength (st_parameter_dt *);
export_proto(st_iolength);
void
-st_iolength (void)
+st_iolength (st_parameter_dt *dtp)
{
- library_start ();
- iolength_transfer_init ();
+ library_start (&dtp->common);
+ iolength_transfer_init (dtp);
}
-extern void st_iolength_done (void);
+extern void st_iolength_done (st_parameter_dt *);
export_proto(st_iolength_done);
void
-st_iolength_done (void)
+st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
{
+ free_ionml (dtp);
library_end ();
}
/* The READ statement. */
-extern void st_read (void);
+extern void st_read (st_parameter_dt *);
export_proto(st_read);
void
-st_read (void)
+st_read (st_parameter_dt *dtp)
{
- library_start ();
+ library_start (&dtp->common);
- data_transfer_init (1);
+ data_transfer_init (dtp, 1);
/* Handle complications dealing with the endfile record. It is
significant that this is the only place where ERROR_END is
generated. Reading an end of file elsewhere is either end of
record or an I/O error. */
- if (current_unit->flags.access == ACCESS_SEQUENTIAL)
- switch (current_unit->endfile)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ switch (dtp->u.p.current_unit->endfile)
{
case NO_ENDFILE:
break;
case AT_ENDFILE:
- if (!is_internal_unit())
+ if (!is_internal_unit (dtp))
{
- generate_error (ERROR_END, NULL);
- current_unit->endfile = AFTER_ENDFILE;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
}
break;
case AFTER_ENDFILE:
- generate_error (ERROR_ENDFILE, NULL);
+ generate_error (&dtp->common, ERROR_ENDFILE, NULL);
break;
}
}
-extern void st_read_done (void);
+extern void st_read_done (st_parameter_dt *);
export_proto(st_read_done);
void
-st_read_done (void)
+st_read_done (st_parameter_dt *dtp)
{
- finalize_transfer ();
+ finalize_transfer (dtp);
+ free_ionml (dtp);
library_end ();
}
-extern void st_write (void);
+extern void st_write (st_parameter_dt *);
export_proto(st_write);
void
-st_write (void)
+st_write (st_parameter_dt *dtp)
{
- library_start ();
- data_transfer_init (0);
+ library_start (&dtp->common);
+ data_transfer_init (dtp, 0);
}
-extern void st_write_done (void);
+extern void st_write_done (st_parameter_dt *);
export_proto(st_write_done);
void
-st_write_done (void)
+st_write_done (st_parameter_dt *dtp)
{
- finalize_transfer ();
+ finalize_transfer (dtp);
/* Deal with endfile conditions associated with sequential files. */
- if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
- switch (current_unit->endfile)
+ if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
break;
case AFTER_ENDFILE:
- current_unit->endfile = AT_ENDFILE; /* Just at it now. */
+ dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
break;
case NO_ENDFILE:
- if (current_unit->current_record > current_unit->last_record)
+ if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record)
{
/* Get rid of whatever is after this record. */
- if (struncate (current_unit->s) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ if (struncate (dtp->u.p.current_unit->s) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
}
- current_unit->endfile = AT_ENDFILE;
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
+ free_ionml (dtp);
library_end ();
}
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
-extern void st_set_nml_var (void * ,char * ,
- GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
+extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
-st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
- gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
+st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+ GFC_INTEGER_4 len, gfc_charlen_type string_length,
+ GFC_INTEGER_4 dtype)
{
namelist_info *t1 = NULL;
namelist_info *nml;
@@ -1896,31 +1912,35 @@ st_set_nml_var (void * var_addr, char *
nml->next = NULL;
- if (ionml == NULL)
- ionml = nml;
+ if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
+ {
+ dtp->common.flags |= IOPARM_DT_IONML_SET;
+ dtp->u.p.ionml = nml;
+ }
else
{
- for (t1 = ionml; t1->next; t1 = t1->next);
+ for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
t1->next = nml;
}
- return;
}
/* Store the dimensional information for the namelist object. */
-extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
- GFC_INTEGER_4 ,GFC_INTEGER_4);
+extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
+ GFC_INTEGER_4, GFC_INTEGER_4,
+ GFC_INTEGER_4);
export_proto(st_set_nml_var_dim);
void
-st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
- GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
+st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
+ GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
+ GFC_INTEGER_4 ubound)
{
namelist_info * nml;
int n;
n = (int)n_dim;
- for (nml = ionml; nml->next; nml = nml->next);
+ for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
nml->dim[n].stride = (ssize_t)stride;
nml->dim[n].lbound = (ssize_t)lbound;
--- libgfortran/io/inquire.c.jj 2005-09-29 14:20:53.000000000 +0200
+++ libgfortran/io/inquire.c 2005-10-04 23:59:58.000000000 +0200
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -41,31 +41,28 @@ static const char undefined[] = "UNDEFIN
/* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
static void
-inquire_via_unit (gfc_unit * u)
+inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
{
const char *p;
+ GFC_INTEGER_4 cf = iqp->common.flags;
- if (ioparm.exist != NULL)
- {
- if (ioparm.unit >= 0)
- *ioparm.exist = 1;
- else
- *ioparm.exist = 0;
- }
-
- if (ioparm.opened != NULL)
- *ioparm.opened = (u != NULL);
-
- if (ioparm.number != NULL)
- *ioparm.number = (u != NULL) ? u->unit_number : -1;
+ if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+ *iqp->exist = iqp->common.unit >= 0;
- if (ioparm.named != NULL)
- *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
+ if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+ *iqp->opened = (u != NULL);
- if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
- fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
+ if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+ *iqp->number = (u != NULL) ? u->unit_number : -1;
- if (ioparm.access != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+ *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
+
+ if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
+ && u != NULL && u->flags.status != STATUS_SCRATCH)
+ fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
+
+ if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
{
if (u == NULL)
p = undefined;
@@ -79,13 +76,13 @@ inquire_via_unit (gfc_unit * u)
p = "DIRECT";
break;
default:
- internal_error ("inquire_via_unit(): Bad access");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad access");
}
- cf_strcpy (ioparm.access, ioparm.access_len, p);
+ cf_strcpy (iqp->access, iqp->access_len, p);
}
- if (ioparm.sequential != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
{
if (u == NULL)
p = inquire_sequential (NULL, 0);
@@ -98,18 +95,18 @@ inquire_via_unit (gfc_unit * u)
p = inquire_sequential (u->file, u->file_len);
}
- cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+ cf_strcpy (iqp->sequential, iqp->sequential_len, p);
}
- if (ioparm.direct != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
{
p = (u == NULL) ? inquire_direct (NULL, 0) :
inquire_direct (u->file, u->file_len);
- cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+ cf_strcpy (iqp->direct, iqp->direct_len, p);
}
- if (ioparm.form != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
{
if (u == NULL)
p = undefined;
@@ -123,35 +120,35 @@ inquire_via_unit (gfc_unit * u)
p = "UNFORMATTED";
break;
default:
- internal_error ("inquire_via_unit(): Bad form");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad form");
}
- cf_strcpy (ioparm.form, ioparm.form_len, p);
+ cf_strcpy (iqp->form, iqp->form_len, p);
}
- if (ioparm.formatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
{
p = (u == NULL) ? inquire_formatted (NULL, 0) :
inquire_formatted (u->file, u->file_len);
- cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+ cf_strcpy (iqp->formatted, iqp->formatted_len, p);
}
- if (ioparm.unformatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
{
p = (u == NULL) ? inquire_unformatted (NULL, 0) :
inquire_unformatted (u->file, u->file_len);
- cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+ cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
}
- if (ioparm.recl_out != NULL)
- *ioparm.recl_out = (u != NULL) ? u->recl : 0;
+ if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+ *iqp->recl_out = (u != NULL) ? u->recl : 0;
- if (ioparm.nextrec != NULL)
- *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
+ if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+ *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
- if (ioparm.blank != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
{
if (u == NULL)
p = undefined;
@@ -159,19 +156,19 @@ inquire_via_unit (gfc_unit * u)
switch (u->flags.blank)
{
case BLANK_NULL:
- p = "NULL";
+ p = "NULL";
break;
case BLANK_ZERO:
p = "ZERO";
break;
default:
- internal_error ("inquire_via_unit(): Bad blank");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
}
- cf_strcpy (ioparm.blank, ioparm.blank_len, p);
+ cf_strcpy (iqp->blank, iqp->blank_len, p);
}
- if (ioparm.position != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
{
if (u == NULL || u->flags.access == ACCESS_DIRECT)
p = undefined;
@@ -194,10 +191,10 @@ inquire_via_unit (gfc_unit * u)
p = "ASIS";
break;
}
- cf_strcpy (ioparm.position, ioparm.position_len, p);
+ cf_strcpy (iqp->position, iqp->position_len, p);
}
- if (ioparm.action != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
{
if (u == NULL)
p = undefined;
@@ -214,37 +211,37 @@ inquire_via_unit (gfc_unit * u)
p = "READWRITE";
break;
default:
- internal_error ("inquire_via_unit(): Bad action");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad action");
}
- cf_strcpy (ioparm.action, ioparm.action_len, p);
+ cf_strcpy (iqp->action, iqp->action_len, p);
}
- if (ioparm.read != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
{
p = (u == NULL) ? inquire_read (NULL, 0) :
inquire_read (u->file, u->file_len);
- cf_strcpy (ioparm.read, ioparm.read_len, p);
+ cf_strcpy (iqp->read, iqp->read_len, p);
}
- if (ioparm.write != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
{
p = (u == NULL) ? inquire_write (NULL, 0) :
inquire_write (u->file, u->file_len);
- cf_strcpy (ioparm.write, ioparm.write_len, p);
+ cf_strcpy (iqp->write, iqp->write_len, p);
}
- if (ioparm.readwrite != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
{
p = (u == NULL) ? inquire_readwrite (NULL, 0) :
inquire_readwrite (u->file, u->file_len);
- cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+ cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
}
- if (ioparm.delim != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
@@ -261,13 +258,13 @@ inquire_via_unit (gfc_unit * u)
p = "APOSTROPHE";
break;
default:
- internal_error ("inquire_via_unit(): Bad delim");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
}
- cf_strcpy (ioparm.delim, ioparm.delim_len, p);
+ cf_strcpy (iqp->delim, iqp->delim_len, p);
}
- if (ioparm.pad != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
@@ -281,10 +278,10 @@ inquire_via_unit (gfc_unit * u)
p = "YES";
break;
default:
- internal_error ("inquire_via_unit(): Bad pad");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
}
- cf_strcpy (ioparm.pad, ioparm.pad_len, p);
+ cf_strcpy (iqp->pad, iqp->pad_len, p);
}
}
@@ -293,119 +290,119 @@ inquire_via_unit (gfc_unit * u)
* only used if the filename is *not* connected to a unit number. */
static void
-inquire_via_filename (void)
+inquire_via_filename (st_parameter_inquire *iqp)
{
const char *p;
+ GFC_INTEGER_4 cf = iqp->common.flags;
- if (ioparm.exist != NULL)
- *ioparm.exist = file_exists ();
+ if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+ *iqp->exist = file_exists (iqp->file, iqp->file_len);
- if (ioparm.opened != NULL)
- *ioparm.opened = 0;
+ if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+ *iqp->opened = 0;
- if (ioparm.number != NULL)
- *ioparm.number = -1;
+ if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+ *iqp->number = -1;
- if (ioparm.named != NULL)
- *ioparm.named = 1;
+ if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+ *iqp->named = 1;
- if (ioparm.name != NULL)
- fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
+ if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
+ fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
- if (ioparm.access != NULL)
- cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+ cf_strcpy (iqp->access, iqp->access_len, undefined);
- if (ioparm.sequential != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
{
- p = inquire_sequential (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+ p = inquire_sequential (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->sequential, iqp->sequential_len, p);
}
- if (ioparm.direct != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
{
- p = inquire_direct (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+ p = inquire_direct (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->direct, iqp->direct_len, p);
}
- if (ioparm.form != NULL)
- cf_strcpy (ioparm.form, ioparm.form_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
+ cf_strcpy (iqp->form, iqp->form_len, undefined);
- if (ioparm.formatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
{
- p = inquire_formatted (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+ p = inquire_formatted (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->formatted, iqp->formatted_len, p);
}
- if (ioparm.unformatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
{
- p = inquire_unformatted (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+ p = inquire_unformatted (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
}
- if (ioparm.recl_out != NULL)
- *ioparm.recl_out = 0;
+ if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+ *iqp->recl_out = 0;
- if (ioparm.nextrec != NULL)
- *ioparm.nextrec = 0;
+ if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+ *iqp->nextrec = 0;
- if (ioparm.blank != NULL)
- cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
+ cf_strcpy (iqp->blank, iqp->blank_len, undefined);
- if (ioparm.position != NULL)
- cf_strcpy (ioparm.position, ioparm.position_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
+ cf_strcpy (iqp->position, iqp->position_len, undefined);
- if (ioparm.access != NULL)
- cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+ cf_strcpy (iqp->access, iqp->access_len, undefined);
- if (ioparm.read != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
{
- p = inquire_read (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.read, ioparm.read_len, p);
+ p = inquire_read (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->read, iqp->read_len, p);
}
- if (ioparm.write != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
{
- p = inquire_write (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.write, ioparm.write_len, p);
+ p = inquire_write (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->write, iqp->write_len, p);
}
- if (ioparm.readwrite != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
{
- p = inquire_read (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+ p = inquire_read (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
}
- if (ioparm.delim != NULL)
- cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
-
- if (ioparm.pad != NULL)
- cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+ cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+ cf_strcpy (iqp->pad, iqp->pad_len, undefined);
}
/* Library entry point for the INQUIRE statement (non-IOLENGTH
form). */
-extern void st_inquire (void);
+extern void st_inquire (st_parameter_inquire *);
export_proto(st_inquire);
void
-st_inquire (void)
+st_inquire (st_parameter_inquire *iqp)
{
gfc_unit *u;
- library_start ();
+ library_start (&iqp->common);
- if (ioparm.file == NULL)
- inquire_via_unit (find_unit (ioparm.unit));
+ if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
+ inquire_via_unit (iqp, find_unit (iqp->common.unit));
else
{
- u = find_file ();
+ u = find_file (iqp->file, iqp->file_len);
if (u == NULL)
- inquire_via_filename ();
+ inquire_via_filename (iqp);
else
- inquire_via_unit (u);
+ inquire_via_unit (iqp, u);
}
library_end ();
--- libgfortran/io/unit.c.jj 2005-10-01 10:58:48.000000000 +0200
+++ libgfortran/io/unit.c 2005-10-04 22:27:12.000000000 +0200
@@ -128,7 +128,7 @@ insert (gfc_unit * new, gfc_unit * t)
}
if (c == 0)
- internal_error ("insert(): Duplicate key found!");
+ internal_error (NULL, "insert(): Duplicate key found!");
return t;
}
@@ -248,7 +248,7 @@ find_unit (int n)
/* get_array_unit_len()-- return the number of records in the array. */
gfc_offset
-get_array_unit_len (gfc_array_char *desc)
+get_array_unit_len (st_parameter_dt *dtp, gfc_array_char *desc)
{
gfc_offset record_count;
int i, rank, stride;
@@ -260,7 +260,7 @@ get_array_unit_len (gfc_array_char *desc
if (desc->dim[i].stride != stride)
{
- generate_error (ERROR_ARRAY_STRIDE, NULL);
+ generate_error (&dtp->common, ERROR_ARRAY_STRIDE, NULL);
return 0;
}
stride *= desc->dim[i].ubound;
@@ -274,21 +274,22 @@ get_array_unit_len (gfc_array_char *desc
* unit or the internal file. */
gfc_unit *
-get_unit (int read_flag __attribute__ ((unused)))
+get_unit (st_parameter_dt *dtp)
{
- if (ioparm.internal_unit != NULL)
+ if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
{
- 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.recl = dtp->internal_unit_len;
+ if (is_array_io (dtp))
+ dtp->internal_unit_len *=
+ get_array_unit_len (dtp, dtp->internal_unit_desc);
internal_unit.s =
- open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
+ open_internal (dtp->internal_unit, dtp->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())
+ if (dtp->u.p.mode==WRITING && !is_array_io (dtp))
empty_internal_buffer (internal_unit.s);
/* Set flags for the internal unit */
@@ -303,25 +304,25 @@ get_unit (int read_flag __attribute__ ((
/* Has to be an external unit */
- return find_unit (ioparm.unit);
+ return find_unit (dtp->common.unit);
}
/* is_internal_unit()-- Determine if the current unit is internal or not */
int
-is_internal_unit (void)
+is_internal_unit (st_parameter_dt *dtp)
{
- return current_unit == &internal_unit;
+ return dtp->u.p.current_unit == &internal_unit;
}
/* is_array_io ()-- Determine if the I/O is to/from an array */
int
-is_array_io (void)
+is_array_io (st_parameter_dt *dtp)
{
- return (ioparm.internal_unit_desc != NULL);
+ return dtp->internal_unit_desc != NULL;
}
--- libgfortran/io/read.c.jj 2005-10-01 11:01:57.000000000 +0200
+++ libgfortran/io/read.c 2005-10-04 19:53:55.000000000 +0200
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -80,7 +80,7 @@ set_integer (void *dest, GFC_INTEGER_LAR
}
break;
default:
- internal_error ("Bad integer kind");
+ internal_error (NULL, "Bad integer kind");
}
}
@@ -119,7 +119,7 @@ max_value (int length, int signed_flag)
value = signed_flag ? 0x7f : 0xff;
break;
default:
- internal_error ("Bad integer kind");
+ internal_error (NULL, "Bad integer kind");
}
return value;
@@ -132,7 +132,7 @@ max_value (int length, int signed_flag)
* infinities. */
int
-convert_real (void *dest, const char *buffer, int length)
+convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
{
errno = 0;
@@ -172,12 +172,12 @@ convert_real (void *dest, const char *bu
break;
#endif
default:
- internal_error ("Unsupported real kind during IO");
+ internal_error (&dtp->common, "Unsupported real kind during IO");
}
if (errno != 0 && errno != EINVAL)
{
- generate_error (ERROR_READ_VALUE,
+ generate_error (&dtp->common, ERROR_READ_VALUE,
"Range error during floating point read");
return 1;
}
@@ -189,13 +189,13 @@ convert_real (void *dest, const char *bu
/* read_l()-- Read a logical value */
void
-read_l (fnode * f, char *dest, int length)
+read_l (st_parameter_dt *dtp, fnode * f, char *dest, int length)
{
char *p;
int w;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
@@ -225,7 +225,8 @@ read_l (fnode * f, char *dest, int lengt
break;
default:
bad:
- generate_error (ERROR_READ_VALUE, "Bad value on logical read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value on logical read");
break;
}
}
@@ -234,7 +235,7 @@ read_l (fnode * f, char *dest, int lengt
/* read_a()-- Read a character record. This one is pretty easy. */
void
-read_a (fnode * f, char *p, int length)
+read_a (st_parameter_dt *dtp, fnode * f, char *p, int length)
{
char *source;
int w, m, n;
@@ -243,7 +244,7 @@ read_a (fnode * f, char *p, int length)
if (w == -1) /* '(A)' edit descriptor */
w = length;
- source = read_block (&w);
+ source = read_block (dtp, &w);
if (source == NULL)
return;
if (w > length)
@@ -278,7 +279,7 @@ eat_leading_spaces (int *width, char *p)
static char
-next_char (char **p, int *w)
+next_char (st_parameter_dt *dtp, char **p, int *w)
{
char c, *q;
@@ -293,7 +294,7 @@ next_char (char **p, int *w)
if (c != ' ')
return c;
- if (g.blank_status != BLANK_UNSPECIFIED)
+ if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
return ' '; /* return a blank to signal a null */
/* At this point, the rest of the field has to be trailing blanks */
@@ -314,7 +315,7 @@ next_char (char **p, int *w)
* signed values. */
void
-read_decimal (fnode * f, char *dest, int length)
+read_decimal (st_parameter_dt *dtp, fnode * f, char *dest, int length)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
@@ -322,7 +323,7 @@ read_decimal (fnode * f, char *dest, int
char c, *p;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
@@ -360,14 +361,14 @@ read_decimal (fnode * f, char *dest, int
for (;;)
{
- c = next_char (&p, &w);
+ c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
- if (g.blank_status == BLANK_NULL) continue;
- if (g.blank_status == BLANK_ZERO) c = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
if (c < '0' || c > '9')
@@ -392,11 +393,12 @@ read_decimal (fnode * f, char *dest, int
return;
bad:
- generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during integer read");
return;
overflow:
- generate_error (ERROR_READ_OVERFLOW,
+ generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
@@ -408,7 +410,7 @@ read_decimal (fnode * f, char *dest, int
* the top bit is set, the value will be incorrect. */
void
-read_radix (fnode * f, char *dest, int length, int radix)
+read_radix (st_parameter_dt *dtp, fnode * f, char *dest, int length, int radix)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_r;
GFC_INTEGER_LARGEST v;
@@ -416,7 +418,7 @@ read_radix (fnode * f, char *dest, int l
char c, *p;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
@@ -454,13 +456,13 @@ read_radix (fnode * f, char *dest, int l
for (;;)
{
- c = next_char (&p, &w);
+ c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
- if (g.blank_status == BLANK_NULL) continue;
- if (g.blank_status == BLANK_ZERO) c = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
switch (radix)
@@ -534,11 +536,12 @@ read_radix (fnode * f, char *dest, int l
return;
bad:
- generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during integer read");
return;
overflow:
- generate_error (ERROR_READ_OVERFLOW,
+ generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
@@ -551,7 +554,7 @@ read_radix (fnode * f, char *dest, int l
the input. */
void
-read_f (fnode * f, char *dest, int length)
+read_f (st_parameter_dt *dtp, fnode * f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign, val_sign;
@@ -564,7 +567,7 @@ read_f (fnode * f, char *dest, int lengt
val_sign = 1;
seen_dp = 0;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
@@ -648,11 +651,12 @@ read_f (fnode * f, char *dest, int lengt
}
/* No exponent has been seen, so we use the current scale factor */
- exponent = -g.scale_factor;
+ exponent = -dtp->u.p.scale_factor;
goto done;
bad_float:
- generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during floating point read");
return;
/* The value read is zero */
@@ -680,7 +684,7 @@ read_f (fnode * f, char *dest, int lengt
#endif
default:
- internal_error ("Unsupported real kind during IO");
+ internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
@@ -718,7 +722,7 @@ read_f (fnode * f, char *dest, int lengt
p++;
w--;
- if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
+ if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
{
while (w > 0 && isdigit (*p))
{
@@ -743,8 +747,8 @@ read_f (fnode * f, char *dest, int lengt
{
if (*p == ' ')
{
- if (g.blank_status == BLANK_ZERO) *p = '0';
- if (g.blank_status == BLANK_NULL)
+ if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL)
{
p++;
w--;
@@ -803,8 +807,8 @@ read_f (fnode * f, char *dest, int lengt
{
if (*digits == ' ')
{
- if (g.blank_status == BLANK_ZERO) *digits = '0';
- if (g.blank_status == BLANK_NULL)
+ if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL)
{
digits++;
continue;
@@ -818,7 +822,7 @@ read_f (fnode * f, char *dest, int lengt
sprintf (p, "%d", exponent);
/* Do the actual conversion. */
- convert_real (dest, buffer, length);
+ convert_real (dtp, dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
@@ -831,12 +835,12 @@ read_f (fnode * f, char *dest, int lengt
* and never look at it. */
void
-read_x (int n)
+read_x (st_parameter_dt *dtp, int n)
{
- if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
- && current_unit->bytes_left < n)
- n = current_unit->bytes_left;
+ if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
+ && dtp->u.p.current_unit->bytes_left < n)
+ n = dtp->u.p.current_unit->bytes_left;
if (n > 0)
- read_block (&n);
+ read_block (dtp, &n);
}
--- libgfortran/io/list_read.c.jj 2005-09-27 22:09:50.000000000 +0200
+++ libgfortran/io/list_read.c 2005-10-04 19:53:55.000000000 +0200
@@ -138,7 +138,7 @@ free_saved (void)
static char
-next_char (void)
+next_char (st_parameter_dt *dtp)
{
int length;
char c, *p;
@@ -153,10 +153,10 @@ next_char (void)
length = 1;
- p = salloc_r (current_unit->s, &length);
+ p = salloc_r (dtp->u.p.current_unit->s, &length);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return '\0';
}
@@ -165,7 +165,7 @@ next_char (void)
/* For internal files return a newline instead of signalling EOF. */
/* ??? This isn't quite right, but we don't handle internal files
with multiple records. */
- if (is_internal_unit ())
+ if (is_internal_unit (dtp))
c = '\n';
else
longjmp (g.eof_jump, 1);
@@ -192,13 +192,13 @@ unget_char (char c)
terminated the eating and also places it back on the input. */
static char
-eat_spaces (void)
+eat_spaces (st_parameter_dt *dtp)
{
char c;
do
{
- c = next_char ();
+ c = next_char (dtp);
}
while (c == ' ' || c == '\t');
@@ -219,19 +219,19 @@ eat_spaces (void)
of the separator. */
static void
-eat_separator (void)
+eat_separator (st_parameter_dt *dtp)
{
char c;
- eat_spaces ();
+ eat_spaces (dtp);
comma_flag = 0;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case ',':
comma_flag = 1;
- eat_spaces ();
+ eat_spaces (dtp);
break;
case '/':
@@ -247,7 +247,7 @@ eat_separator (void)
if (namelist_mode)
{ /* Eat a namelist comment. */
do
- c = next_char ();
+ c = next_char (dtp);
while (c != '\n');
break;
@@ -267,14 +267,14 @@ eat_separator (void)
we started on the previous line. */
static void
-finish_separator (void)
+finish_separator (st_parameter_dt *dtp)
{
char c;
restart:
- eat_spaces ();
+ eat_spaces (dtp);
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case ',':
@@ -282,7 +282,7 @@ finish_separator (void)
unget_char (c);
else
{
- c = eat_spaces ();
+ c = eat_spaces (dtp);
if (c == '\n')
goto restart;
}
@@ -291,7 +291,7 @@ finish_separator (void)
case '/':
input_complete = 1;
- if (!namelist_mode) next_record (0);
+ if (!namelist_mode) next_record (dtp, 0);
break;
case '\n':
@@ -302,7 +302,7 @@ finish_separator (void)
if (namelist_mode)
{
do
- c = next_char ();
+ c = next_char (dtp);
while (c != '\n');
goto restart;
@@ -335,7 +335,7 @@ nml_bad_return (char c)
range problem. As a side effect, frees the saved_string. */
static int
-convert_integer (int length, int negative)
+convert_integer (st_parameter_dt *dtp, int length, int negative)
{
char c, *buffer, message[100];
int m;
@@ -378,9 +378,9 @@ convert_integer (int length, int negativ
if (repeat_count == 0)
{
st_sprintf (message, "Zero repeat count in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
m = 1;
}
}
@@ -391,13 +391,13 @@ convert_integer (int length, int negativ
overflow:
if (length == -1)
st_sprintf (message, "Repeat count overflow in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
else
st_sprintf (message, "Integer overflow while reading item %d",
- g.item_count);
+ dtp->u.p.item_count);
free_saved ();
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -408,12 +408,12 @@ convert_integer (int length, int negativ
should continue on. */
static int
-parse_repeat (void)
+parse_repeat (st_parameter_dt *dtp)
{
char c, message[100];
int repeat;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -422,7 +422,7 @@ parse_repeat (void)
CASE_SEPARATORS:
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
return 1;
default:
@@ -432,7 +432,7 @@ parse_repeat (void)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -442,9 +442,9 @@ parse_repeat (void)
{
st_sprintf (message,
"Repeat count overflow in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -455,9 +455,9 @@ parse_repeat (void)
{
st_sprintf (message,
"Zero repeat count in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -474,9 +474,9 @@ parse_repeat (void)
bad_repeat:
st_sprintf (message, "Bad repeat count in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -484,15 +484,15 @@ parse_repeat (void)
/* Read a logical character on the input. */
static void
-read_logical (int length)
+read_logical (st_parameter_dt *dtp, int length)
{
char c, message[100];
int v;
- if (parse_repeat ())
+ if (parse_repeat (dtp))
return;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case 't':
@@ -505,7 +505,7 @@ read_logical (int length)
break;
case '.':
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case 't':
@@ -524,7 +524,7 @@ read_logical (int length)
CASE_SEPARATORS:
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
return; /* Null value. */
default:
@@ -537,12 +537,12 @@ read_logical (int length)
/* Eat trailing garbage. */
do
{
- c = next_char ();
+ c = next_char (dtp);
}
while (!is_separator (c));
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
free_saved ();
set_integer ((int *) value, v, length);
@@ -554,9 +554,9 @@ read_logical (int length)
return;
st_sprintf (message, "Bad logical value while reading item %d",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
@@ -566,14 +566,14 @@ read_logical (int length)
used for repeat counts. */
static void
-read_integer (int length)
+read_integer (st_parameter_dt *dtp, int length)
{
char c, message[100];
int negative;
negative = 0;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '-':
@@ -581,12 +581,12 @@ read_integer (int length)
/* Fall through... */
case '+':
- c = next_char ();
+ c = next_char (dtp);
goto get_integer;
CASE_SEPARATORS: /* Single null. */
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
return;
CASE_DIGITS:
@@ -601,7 +601,7 @@ read_integer (int length)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -621,12 +621,12 @@ read_integer (int length)
}
repeat:
- if (convert_integer (-1, 0))
+ if (convert_integer (dtp, -1, 0))
return;
/* Get the real integer. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -634,7 +634,7 @@ read_integer (int length)
CASE_SEPARATORS:
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
return;
case '-':
@@ -642,7 +642,7 @@ read_integer (int length)
/* Fall through... */
case '+':
- c = next_char ();
+ c = next_char (dtp);
break;
}
@@ -653,7 +653,7 @@ read_integer (int length)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -675,17 +675,18 @@ read_integer (int length)
free_saved ();
- st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ st_sprintf (message, "Bad integer for item %d in list input",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return;
done:
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
push_char ('\0');
- if (convert_integer (length, negative))
+ if (convert_integer (dtp, length, negative))
{
free_saved ();
return;
@@ -699,13 +700,13 @@ read_integer (int length)
/* Read a character variable. */
static void
-read_character (int length __attribute__ ((unused)))
+read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
{
char c, quote, message[100];
quote = ' '; /* Space means no quote character. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -714,7 +715,7 @@ read_character (int length __attribute__
CASE_SEPARATORS:
unget_char (c); /* NULL value. */
- eat_separator ();
+ eat_separator (dtp);
return;
case '"':
@@ -731,7 +732,7 @@ read_character (int length __attribute__
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -753,17 +754,17 @@ read_character (int length __attribute__
}
got_repeat:
- if (convert_integer (-1, 0))
+ if (convert_integer (dtp, -1, 0))
return;
/* Now get the real string. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_SEPARATORS:
unget_char (c); /* Repeated NULL values. */
- eat_separator ();
+ eat_separator (dtp);
return;
case '"':
@@ -779,7 +780,7 @@ read_character (int length __attribute__
get_string:
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '"':
@@ -793,7 +794,7 @@ read_character (int length __attribute__
/* See if we have a doubled quote character or the end of
the string. */
- c = next_char ();
+ c = next_char (dtp);
if (c == quote)
{
push_char (quote);
@@ -823,18 +824,19 @@ read_character (int length __attribute__
/* At this point, we have to have a separator, or else the string is
invalid. */
done:
- c = next_char ();
+ c = next_char (dtp);
if (is_separator (c))
{
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
saved_type = BT_CHARACTER;
}
else
{
free_saved ();
- st_sprintf (message, "Invalid string input in item %d", g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ st_sprintf (message, "Invalid string input in item %d",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
}
@@ -843,16 +845,16 @@ read_character (int length __attribute__
are sure is already there. This is a straight real number parser. */
static int
-parse_real (void *buffer, int length)
+parse_real (st_parameter_dt *dtp, void *buffer, int length)
{
char c, message[100];
int m, seen_dp;
- c = next_char ();
+ c = next_char (dtp);
if (c == '-' || c == '+')
{
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
}
if (!isdigit (c) && c != '.')
@@ -864,7 +866,7 @@ parse_real (void *buffer, int length)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -890,7 +892,7 @@ parse_real (void *buffer, int length)
case '+':
push_char ('e');
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
goto exp2;
CASE_SEPARATORS:
@@ -903,13 +905,13 @@ parse_real (void *buffer, int length)
}
exp1:
- c = next_char ();
+ c = next_char (dtp);
if (c != '-' && c != '+')
push_char ('+');
else
{
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
}
exp2:
@@ -919,7 +921,7 @@ parse_real (void *buffer, int length)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -939,15 +941,16 @@ parse_real (void *buffer, int length)
unget_char (c);
push_char ('\0');
- m = convert_real (buffer, saved_string, length);
+ m = convert_real (dtp, buffer, saved_string, length);
free_saved ();
return m;
bad:
free_saved ();
- st_sprintf (message, "Bad floating point number for item %d", g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ st_sprintf (message, "Bad floating point number for item %d",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -957,15 +960,15 @@ parse_real (void *buffer, int length)
what it is right away. */
static void
-read_complex (int length)
+read_complex (st_parameter_dt *dtp, int length)
{
char message[100];
char c;
- if (parse_repeat ())
+ if (parse_repeat (dtp))
return;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '(':
@@ -973,49 +976,49 @@ read_complex (int length)
CASE_SEPARATORS:
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
return;
default:
goto bad_complex;
}
- eat_spaces ();
- if (parse_real (value, length))
+ eat_spaces (dtp);
+ if (parse_real (dtp, value, length))
return;
eol_1:
- eat_spaces ();
- c = next_char ();
+ eat_spaces (dtp);
+ c = next_char (dtp);
if (c == '\n' || c== '\r')
goto eol_1;
else
unget_char (c);
- if (next_char () != ',')
+ if (next_char (dtp) != ',')
goto bad_complex;
eol_2:
- eat_spaces ();
- c = next_char ();
+ eat_spaces (dtp);
+ c = next_char (dtp);
if (c == '\n' || c== '\r')
goto eol_2;
else
unget_char (c);
- if (parse_real (value + length, length))
+ if (parse_real (dtp, value + length, length))
return;
- eat_spaces ();
- if (next_char () != ')')
+ eat_spaces (dtp);
+ if (next_char (dtp) != ')')
goto bad_complex;
- c = next_char ();
+ c = next_char (dtp);
if (!is_separator (c))
goto bad_complex;
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
free_saved ();
saved_type = BT_COMPLEX;
@@ -1027,23 +1030,23 @@ eol_2:
return;
st_sprintf (message, "Bad complex value in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
/* Parse a real number with a possible repeat count. */
static void
-read_real (int length)
+read_real (st_parameter_dt *dtp, int length)
{
char c, message[100];
int seen_dp;
seen_dp = 0;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -1061,7 +1064,7 @@ read_real (int length)
CASE_SEPARATORS:
unget_char (c); /* Single null. */
- eat_separator ();
+ eat_separator (dtp);
return;
default:
@@ -1072,7 +1075,7 @@ read_real (int length)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -1097,7 +1100,7 @@ read_real (int length)
case '-':
push_char ('e');
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
goto exp2;
case '*':
@@ -1115,16 +1118,16 @@ read_real (int length)
}
got_repeat:
- if (convert_integer (-1, 0))
+ if (convert_integer (dtp, -1, 0))
return;
/* Now get the number itself. */
- c = next_char ();
+ c = next_char (dtp);
if (is_separator (c))
{ /* Repeated null value. */
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
return;
}
@@ -1134,7 +1137,7 @@ read_real (int length)
{
got_sign:
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
}
if (!isdigit (c) && c != '.')
@@ -1153,7 +1156,7 @@ read_real (int length)
real_loop:
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
@@ -1181,7 +1184,7 @@ read_real (int length)
case '-':
push_char ('e');
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
goto exp2;
default:
@@ -1192,13 +1195,13 @@ read_real (int length)
exp1:
push_char ('e');
- c = next_char ();
+ c = next_char (dtp);
if (c != '+' && c != '-')
push_char ('+');
else
{
push_char (c);
- c = next_char ();
+ c = next_char (dtp);
}
exp2:
@@ -1208,7 +1211,7 @@ read_real (int length)
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
@@ -1226,9 +1229,9 @@ read_real (int length)
done:
unget_char (c);
- eat_separator ();
+ eat_separator (dtp);
push_char ('\0');
- if (convert_real (value, saved_string, length))
+ if (convert_real (dtp, value, saved_string, length))
return;
free_saved ();
@@ -1241,9 +1244,9 @@ read_real (int length)
return;
st_sprintf (message, "Bad real number in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
@@ -1251,16 +1254,17 @@ read_real (int length)
compatible. Returns nonzero if incompatible. */
static int
-check_type (bt type, int len)
+check_type (st_parameter_dt *dtp, bt type, int len)
{
char message[100];
if (saved_type != BT_NULL && saved_type != type)
{
st_sprintf (message, "Read type %s where %s was expected for item %d",
- type_name (saved_type), type_name (type), g.item_count);
+ type_name (saved_type), type_name (type),
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -1271,8 +1275,9 @@ check_type (bt type, int len)
{
st_sprintf (message,
"Read kind %d %s where kind %d is required for item %d",
- saved_length, type_name (saved_type), len, g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ saved_length, type_name (saved_type), len,
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
@@ -1286,7 +1291,7 @@ check_type (bt type, int len)
greater than one, we copy the data item multiple times. */
static void
-list_formatted_read_scalar (bt type, void *p, int len)
+list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int len)
{
char c;
int m;
@@ -1295,24 +1300,24 @@ list_formatted_read_scalar (bt type, voi
if (setjmp (g.eof_jump))
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return;
}
- if (g.first_item)
+ if (dtp->u.p.first_item)
{
- g.first_item = 0;
+ dtp->u.p.first_item = 0;
input_complete = 0;
repeat_count = 1;
at_eol = 0;
- c = eat_spaces ();
+ c = eat_spaces (dtp);
if (is_separator (c))
{ /* Found a null value. */
- eat_separator ();
+ eat_separator (dtp);
repeat_count = 0;
if (at_eol)
- finish_separator ();
+ finish_separator (dtp);
else
return;
}
@@ -1325,19 +1330,19 @@ list_formatted_read_scalar (bt type, voi
if (repeat_count > 0)
{
- if (check_type (type, len))
+ if (check_type (dtp, type, len))
return;
goto set_value;
}
if (at_eol)
- finish_separator ();
+ finish_separator (dtp);
else
{
- eat_spaces ();
+ eat_spaces (dtp);
/* trailing spaces prior to end of line */
if (at_eol)
- finish_separator ();
+ finish_separator (dtp);
}
saved_type = BT_NULL;
@@ -1347,28 +1352,28 @@ list_formatted_read_scalar (bt type, voi
switch (type)
{
case BT_INTEGER:
- read_integer (len);
+ read_integer (dtp, len);
break;
case BT_LOGICAL:
- read_logical (len);
+ read_logical (dtp, len);
break;
case BT_CHARACTER:
- read_character (len);
+ read_character (dtp, len);
break;
case BT_REAL:
- read_real (len);
+ read_real (dtp, len);
break;
case BT_COMPLEX:
- read_complex (len);
+ read_complex (dtp, len);
break;
default:
- internal_error ("Bad type for list read");
+ internal_error (&dtp->common, "Bad type for list read");
}
if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
saved_length = len;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
set_value:
@@ -1408,7 +1413,8 @@ list_formatted_read_scalar (bt type, voi
void
-list_formatted_read (bt type, void *p, int len, size_t nelems)
+list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int len,
+ size_t nelems)
{
size_t elem;
int size;
@@ -1424,8 +1430,8 @@ list_formatted_read (bt type, void *p,
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
- g.item_count++;
- list_formatted_read_scalar (type, tmp + size*elem, len);
+ dtp->u.p.item_count++;
+ list_formatted_read_scalar (dtp, type, tmp + size*elem, len);
}
}
@@ -1439,7 +1445,7 @@ init_at_eol(void)
/* Finish a list read. */
void
-finish_list_read (void)
+finish_list_read (st_parameter_dt *dtp)
{
char c;
@@ -1453,21 +1459,22 @@ finish_list_read (void)
do
{
- c = next_char ();
+ c = next_char (dtp);
}
while (c != '\n');
}
/* NAMELIST INPUT
-void namelist_read (void)
+void namelist_read (st_parameter_dt *dtp)
calls:
static void nml_match_name (char *name, int len)
- static int nml_query (void)
- static int nml_get_obj_data (void)
+ static int nml_query (st_parameter_dt *dtp)
+ static int nml_get_obj_data (st_parameter_dt *dtp)
calls:
- static void nml_untouch_nodes (void)
- static namelist_info * find_nml_node (char * var_name)
+ static void nml_untouch_nodes (st_parameter_dt *dtp)
+ static namelist_info * find_nml_node (st_parameter_dt *dtp,
+ 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)
@@ -1499,7 +1506,7 @@ static index_type chigh;
singlets, doublets, triplets or ':' with the standard meanings. */
static try
-nml_parse_qualifier(descriptor_dimension * ad,
+nml_parse_qualifier(st_parameter_dt *dtp, descriptor_dimension * ad,
nml_loop_spec * ls, int rank)
{
int dim;
@@ -1510,7 +1517,7 @@ nml_parse_qualifier(descriptor_dimension
/* The next character in the stream should be the '('. */
- c = next_char ();
+ c = next_char (dtp);
/* Process the qualifier, by dimension and triplet. */
@@ -1519,12 +1526,12 @@ nml_parse_qualifier(descriptor_dimension
for (indx=0; indx<3; indx++)
{
free_saved ();
- eat_spaces ();
+ eat_spaces (dtp);
neg = 0;
/*process a potential sign. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '-':
@@ -1543,7 +1550,7 @@ nml_parse_qualifier(descriptor_dimension
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
@@ -1565,8 +1572,8 @@ nml_parse_qualifier(descriptor_dimension
continue;
case ' ': case '\t':
- eat_spaces ();
- c = next_char ();
+ eat_spaces (dtp);
+ c = next_char (dtp);
break;
default:
@@ -1598,7 +1605,7 @@ nml_parse_qualifier(descriptor_dimension
/* Now read the index. */
- if (convert_integer (sizeof(int),neg))
+ if (convert_integer (dtp, sizeof(int), neg))
{
st_sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
@@ -1653,7 +1660,7 @@ nml_parse_qualifier(descriptor_dimension
ls[dim].idx = ls[dim].start;
}
- eat_spaces ();
+ eat_spaces (dtp);
return SUCCESS;
err_ret:
@@ -1662,12 +1669,12 @@ err_ret:
}
static namelist_info *
-find_nml_node (char * var_name)
+find_nml_node (st_parameter_dt *dtp, char * var_name)
{
- namelist_info * t = ionml;
+ namelist_info * t = dtp->u.p.ionml;
while (t != NULL)
{
- if (strcmp (var_name,t->var_name) == 0)
+ if (strcmp (var_name, t->var_name) == 0)
{
t->touched = 1;
return t;
@@ -1714,10 +1721,10 @@ nml_touch_nodes (namelist_info * nl)
new object. */
static void
-nml_untouch_nodes (void)
+nml_untouch_nodes (st_parameter_dt *dtp)
{
namelist_info * t;
- for (t = ionml; t; t = t->next)
+ for (t = dtp->u.p.ionml; t; t = t->next)
t->touched = 0;
return;
}
@@ -1726,14 +1733,14 @@ nml_untouch_nodes (void)
on no match. */
static void
-nml_match_name (const char *name, index_type len)
+nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
{
index_type i;
char c;
nml_read_error = 0;
for (i = 0; i < len; i++)
{
- c = next_char ();
+ c = next_char (dtp);
if (tolower (c) != tolower (name[i]))
{
nml_read_error = 1;
@@ -1748,30 +1755,30 @@ nml_match_name (const char *name, index_
the names alone are printed. */
static void
-nml_query (char c)
+nml_query (st_parameter_dt *dtp, char c)
{
gfc_unit * temp_unit;
namelist_info * nl;
index_type len;
char * p;
- if (current_unit->unit_number != options.stdin_unit)
+ if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
return;
/* Store the current unit and transfer to stdout. */
- temp_unit = current_unit;
- current_unit = find_unit (options.stdout_unit);
+ temp_unit = dtp->u.p.current_unit;
+ dtp->u.p.current_unit = find_unit (options.stdout_unit);
- if (current_unit)
+ if (dtp->u.p.current_unit)
{
- g.mode =WRITING;
- next_record (0);
+ dtp->u.p.mode = WRITING;
+ next_record (dtp, 0);
/* Write the namelist in its entirety. */
if (c == '=')
- namelist_write ();
+ namelist_write (dtp);
/* Or write the list of names. */
@@ -1780,20 +1787,20 @@ nml_query (char c)
/* "&namelist_name\n" */
- len = ioparm.namelist_name_len;
- p = write_block (len + 2);
+ len = dtp->namelist_name_len;
+ p = write_block (dtp, len + 2);
if (!p)
goto query_return;
memcpy (p, "&", 1);
- memcpy ((char*)(p + 1), ioparm.namelist_name, len);
+ memcpy ((char*)(p + 1), dtp->namelist_name, len);
memcpy ((char*)(p + len + 1), "\n", 1);
- for (nl =ionml; nl; nl = nl->next)
+ for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
/* " var_name\n" */
len = strlen (nl->var_name);
- p = write_block (len + 2);
+ p = write_block (dtp, len + 2);
if (!p)
goto query_return;
memcpy (p, " ", 1);
@@ -1803,7 +1810,7 @@ nml_query (char c)
/* "&end\n" */
- p = write_block (5);
+ p = write_block (dtp, 5);
if (!p)
goto query_return;
memcpy (p, "&end\n", 5);
@@ -1811,15 +1818,15 @@ nml_query (char c)
/* Flush the stream to force immediate output. */
- flush (current_unit->s);
+ flush (dtp->u.p.current_unit->s);
}
query_return:
/* Restore the current unit. */
- current_unit = temp_unit;
- g.mode = READING;
+ dtp->u.p.current_unit = temp_unit;
+ dtp->u.p.mode = READING;
return;
}
@@ -1834,7 +1841,7 @@ query_return:
error. */
static try
-nml_read_obj (namelist_info * nl, index_type offset)
+nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset)
{
namelist_info * cmp;
@@ -1853,7 +1860,7 @@ nml_read_obj (namelist_info * nl, index_
return SUCCESS;
repeat_count = 0;
- eat_spaces();
+ eat_spaces (dtp);
len = nl->len;
switch (nl->type)
@@ -1897,7 +1904,7 @@ nml_read_obj (namelist_info * nl, index_
if (input_complete)
return SUCCESS;
if (at_eol)
- finish_separator ();
+ finish_separator (dtp);
if (input_complete)
return SUCCESS;
@@ -1910,23 +1917,23 @@ nml_read_obj (namelist_info * nl, index_
switch (nl->type)
{
case GFC_DTYPE_INTEGER:
- read_integer (len);
+ read_integer (dtp, len);
break;
case GFC_DTYPE_LOGICAL:
- read_logical (len);
+ read_logical (dtp, len);
break;
case GFC_DTYPE_CHARACTER:
- read_character (len);
+ read_character (dtp, len);
break;
case GFC_DTYPE_REAL:
- read_real (len);
+ read_real (dtp, len);
break;
case GFC_DTYPE_COMPLEX:
- read_complex (len);
+ read_complex (dtp, len);
break;
case GFC_DTYPE_DERIVED:
@@ -1947,7 +1954,8 @@ nml_read_obj (namelist_info * nl, index_
cmp = cmp->next)
{
- if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
+ if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos))
+ == FAILURE)
{
free_mem (obj_name);
return FAILURE;
@@ -1966,7 +1974,7 @@ nml_read_obj (namelist_info * nl, index_
default:
st_sprintf (nml_err_msg, "Bad type for namelist object %s",
nl->var_name );
- internal_error (nml_err_msg);
+ internal_error (&dtp->common, nml_err_msg);
goto nml_err_ret;
}
}
@@ -2054,7 +2062,7 @@ nml_err_ret:
the manner specified by the object name. */
static try
-nml_get_obj_data (void)
+nml_get_obj_data (st_parameter_dt *dtp)
{
char c;
char * ext_name;
@@ -2067,35 +2075,35 @@ nml_get_obj_data (void)
/* Look for end of input or object name. If '?' or '=?' are encountered
in stdin, print the node names or the namelist to stdout. */
- eat_separator ();
+ eat_separator (dtp);
if (input_complete)
return SUCCESS;
if ( at_eol )
- finish_separator ();
+ finish_separator (dtp);
if (input_complete)
return SUCCESS;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '=':
- c = next_char ();
+ c = next_char (dtp);
if (c != '?')
{
st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
goto nml_err_ret;
}
- nml_query ('=');
+ nml_query (dtp, '=');
return SUCCESS;
case '?':
- nml_query ('?');
+ nml_query (dtp, '?');
return SUCCESS;
case '$':
case '&':
- nml_match_name ("end", 3);
+ nml_match_name (dtp, "end", 3);
if (nml_read_error)
{
st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
@@ -2112,7 +2120,7 @@ nml_get_obj_data (void)
/* Untouch all nodes of the namelist and reset the flag that is set for
derived type components. */
- nml_untouch_nodes();
+ nml_untouch_nodes (dtp);
component_flag = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
@@ -2124,7 +2132,7 @@ get_name:
do
{
push_char(tolower(c));
- c = next_char ();
+ c = next_char (dtp);
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
unget_char (c);
@@ -2145,11 +2153,11 @@ get_name:
+ 1);
strcpy (ext_name, root_nl->var_name);
strcat (ext_name, saved_string);
- nl = find_nml_node (ext_name);
+ nl = find_nml_node (dtp, ext_name);
free_mem (ext_name);
}
else
- nl = find_nml_node (saved_string);
+ nl = find_nml_node (dtp, saved_string);
if (nl == NULL)
{
@@ -2179,13 +2187,13 @@ get_name:
if (c == '(' && nl->var_rank)
{
- if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
+ if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
- c = next_char ();
+ c = next_char (dtp);
unget_char (c);
}
@@ -2208,7 +2216,7 @@ get_name:
root_nl = nl;
component_flag = 1;
- c = next_char ();
+ c = next_char (dtp);
goto get_name;
}
@@ -2224,7 +2232,7 @@ get_name:
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)
+ if (nml_parse_qualifier (dtp, chd, ind, 1) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
@@ -2242,7 +2250,7 @@ get_name:
goto nml_err_ret;
}
- c = next_char ();
+ c = next_char (dtp);
unget_char (c);
}
@@ -2266,20 +2274,20 @@ get_name:
/* According to the standard, an equal sign MUST follow an object name. The
following is possibly lax - it allows comments, blank lines and so on to
- intervene. eat_spaces (); c = next_char (); would be compliant*/
+ intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
free_saved ();
- eat_separator ();
+ eat_separator (dtp);
if (input_complete)
return SUCCESS;
if (at_eol)
- finish_separator ();
+ finish_separator (dtp);
if (input_complete)
return SUCCESS;
- c = next_char ();
+ c = next_char (dtp);
if (c != '=')
{
@@ -2288,7 +2296,7 @@ get_name:
goto nml_err_ret;
}
- if (nml_read_obj (nl, 0) == FAILURE)
+ if (nml_read_obj (dtp, nl, 0) == FAILURE)
goto nml_err_ret;
return SUCCESS;
@@ -2303,7 +2311,7 @@ nml_err_ret:
completed or there is an error. */
void
-namelist_read (void)
+namelist_read (st_parameter_dt *dtp)
{
char c;
@@ -2312,7 +2320,7 @@ namelist_read (void)
if (setjmp (g.eof_jump))
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return;
}
@@ -2321,22 +2329,22 @@ namelist_read (void)
node names or namelist on stdout. */
find_nml_name:
- switch (c = next_char ())
+ switch (c = next_char (dtp))
{
case '$':
case '&':
break;
case '=':
- c = next_char ();
+ c = next_char (dtp);
if (c == '?')
- nml_query ('=');
+ nml_query (dtp, '=');
else
unget_char (c);
goto find_nml_name;
case '?':
- nml_query ('?');
+ nml_query (dtp, '?');
default:
goto find_nml_name;
@@ -2344,7 +2352,7 @@ find_nml_name:
/* Match the name of the namelist. */
- nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
+ nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
if (nml_read_error)
goto find_nml_name;
@@ -2354,9 +2362,9 @@ find_nml_name:
while (!input_complete)
{
- if (nml_get_obj_data () == FAILURE)
+ if (nml_get_obj_data (dtp) == FAILURE)
{
- if (current_unit->unit_number != options.stdin_unit)
+ if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
goto nml_err_ret;
st_printf ("%s\n", nml_err_msg);
@@ -2371,6 +2379,6 @@ find_nml_name:
nml_err_ret:
- generate_error (ERROR_READ_VALUE , nml_err_msg);
+ generate_error (&dtp->common, ERROR_READ_VALUE , nml_err_msg);
return;
}
--- libgfortran/io/unix.c.jj 2005-09-29 14:21:47.000000000 +0200
+++ libgfortran/io/unix.c 2005-10-04 19:53:55.000000000 +0200
@@ -436,7 +436,8 @@ fd_alloc_r_at (unix_stream * s, int *len
* we've already buffered the data or we need to load it. */
static char *
-fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
+fd_alloc_w_at (unix_stream * s, st_parameter_dt *dtp __attribute__ ((unused)),
+ int *len, gfc_offset where)
{
gfc_offset n;
@@ -615,7 +616,8 @@ mem_alloc_r_at (unix_stream * s, int *le
static char *
-mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
+mem_alloc_w_at (unix_stream * s, st_parameter_dt *dtp, int *len,
+ gfc_offset where)
{
gfc_offset m;
@@ -631,7 +633,7 @@ mem_alloc_w_at (unix_stream * s, int *le
if (m > s->file_length)
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
@@ -787,11 +789,11 @@ unpack_filename (char *cstring, const ch
* open it. mkstemp() opens the file for reading and writing, but the
* library mode prevents anything that is not allowed. The descriptor
* is returned, which is -1 on error. The template is pointed to by
- * ioparm.file, which is copied into the unit structure
+ * opp->file, which is copied into the unit structure
* and freed later. */
static int
-tempfile (void)
+tempfile (st_parameter_open *opp)
{
const char *tempdir;
char *template;
@@ -833,8 +835,8 @@ tempfile (void)
free_mem (template);
else
{
- ioparm.file = template;
- ioparm.file_len = strlen (template); /* Don't include trailing nul */
+ opp->file = template;
+ opp->file_len = strlen (template); /* Don't include trailing nul */
}
return fd;
@@ -847,7 +849,7 @@ tempfile (void)
* Returns the descriptor, which is less than zero on error. */
static int
-regular_file (unit_flags *flags)
+regular_file (st_parameter_open *opp, unit_flags *flags)
{
char path[PATH_MAX + 1];
int mode;
@@ -855,7 +857,7 @@ regular_file (unit_flags *flags)
int crflag;
int fd;
- if (unpack_filename (path, ioparm.file, ioparm.file_len))
+ if (unpack_filename (path, opp->file, opp->file_len))
{
errno = ENOENT; /* Fake an OS error */
return -1;
@@ -879,7 +881,7 @@ regular_file (unit_flags *flags)
break;
default:
- internal_error ("regular_file(): Bad action");
+ internal_error (&opp->common, "regular_file(): Bad action");
}
switch (flags->status)
@@ -902,7 +904,7 @@ regular_file (unit_flags *flags)
break;
default:
- internal_error ("regular_file(): Bad status");
+ internal_error (&opp->common, "regular_file(): Bad status");
}
/* rwflag |= O_LARGEFILE; */
@@ -953,26 +955,27 @@ regular_file (unit_flags *flags)
* Returns NULL on operating system error. */
stream *
-open_external (unit_flags *flags)
+open_external (st_parameter_open *opp, unit_flags *flags)
{
int fd, prot;
if (flags->status == STATUS_SCRATCH)
{
- fd = tempfile ();
+ fd = tempfile (opp);
if (flags->action == ACTION_UNSPECIFIED)
flags->action = ACTION_READWRITE;
#if HAVE_UNLINK_OPEN_FILE
/* We can unlink scratch files now and it will go away when closed. */
- unlink (ioparm.file);
+ if (fd >= 0)
+ unlink (opp->file);
#endif
}
else
{
/* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
* if it succeeds */
- fd = regular_file (flags);
+ fd = regular_file (opp, flags);
}
if (fd < 0)
@@ -994,7 +997,7 @@ open_external (unit_flags *flags)
break;
default:
- internal_error ("open_external(): Bad action");
+ internal_error (&opp->common, "open_external(): Bad action");
}
return fd_to_stream (fd, prot);
@@ -1110,12 +1113,12 @@ find_file0 (gfc_unit * u, struct stat *s
* that has the file already open. Returns a pointer to the unit if so. */
gfc_unit *
-find_file (void)
+find_file (const char *file, gfc_charlen_type file_len)
{
char path[PATH_MAX + 1];
struct stat statbuf;
- if (unpack_filename (path, ioparm.file, ioparm.file_len))
+ if (unpack_filename (path, file, file_len))
return NULL;
if (stat (path, &statbuf) < 0)
@@ -1181,12 +1184,12 @@ delete_file (gfc_unit * u)
* the system */
int
-file_exists (void)
+file_exists (const char *file, gfc_charlen_type file_len)
{
char path[PATH_MAX + 1];
struct stat statbuf;
- if (unpack_filename (path, ioparm.file, ioparm.file_len))
+ if (unpack_filename (path, file, file_len))
return 0;
if (stat (path, &statbuf) < 0)
--- libgfortran/io/close.c.jj 2005-09-29 14:07:03.000000000 +0200
+++ libgfortran/io/close.c 2005-10-04 21:53:10.000000000 +0200
@@ -43,11 +43,11 @@ static const st_option status_opt[] = {
};
-extern void st_close (void);
+extern void st_close (st_parameter_close *);
export_proto(st_close);
void
-st_close (void)
+st_close (st_parameter_close *clp)
{
close_status status;
gfc_unit *u;
@@ -57,25 +57,25 @@ st_close (void)
path = NULL;
#endif
- library_start ();
+ library_start (&clp->common);
- status = (ioparm.status == NULL) ? CLOSE_UNSPECIFIED :
- find_option (ioparm.status, ioparm.status_len, status_opt,
- "Bad STATUS parameter in CLOSE statement");
+ status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED :
+ find_option (&clp->common, clp->status, clp->status_len,
+ status_opt, "Bad STATUS parameter in CLOSE statement");
- if (ioparm.library_return != LIBRARY_OK)
+ if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
return;
}
- u = find_unit (ioparm.unit);
+ u = find_unit (clp->common.unit);
if (u != NULL)
{
if (u->flags.status == STATUS_SCRATCH)
{
if (status == CLOSE_KEEP)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&clp->common, ERROR_BAD_OPTION,
"Can't KEEP a scratch file on CLOSE");
#if !HAVE_UNLINK_OPEN_FILE
path = (char *) gfc_alloca (u->file_len + 1);
--- libgfortran/io/write.c.jj 2005-09-30 23:47:43.000000000 +0200
+++ libgfortran/io/write.c 2005-10-04 19:53:55.000000000 +0200
@@ -46,17 +46,15 @@ typedef enum
sign_t;
-static int no_leading_blank = 0 ;
-
void
-write_a (fnode * f, const char *source, int len)
+write_a (st_parameter_dt *dtp, fnode * f, const char *source, int len)
{
int wlen;
char *p;
wlen = f->u.string.length < 0 ? len : f->u.string.length;
- p = write_block (wlen);
+ p = write_block (dtp, wlen);
if (p == NULL)
return;
@@ -117,7 +115,7 @@ extract_int (const void *p, int len)
break;
#endif
default:
- internal_error ("bad integer kind");
+ internal_error (NULL, "bad integer kind");
}
return i;
@@ -171,7 +169,7 @@ extract_uint (const void *p, int len)
break;
#endif
default:
- internal_error ("bad integer kind");
+ internal_error (NULL, "bad integer kind");
}
return i;
@@ -216,7 +214,7 @@ extract_real (const void *p, int len)
break;
#endif
default:
- internal_error ("bad real kind");
+ internal_error (NULL, "bad real kind");
}
return i;
}
@@ -226,14 +224,14 @@ extract_real (const void *p, int len)
sign_t that gives the sign that we need to produce. */
static sign_t
-calculate_sign (int negative_flag)
+calculate_sign (st_parameter_dt *dtp, int negative_flag)
{
sign_t s = SIGN_NONE;
if (negative_flag)
s = SIGN_MINUS;
else
- switch (g.sign_status)
+ switch (dtp->u.p.sign_status)
{
case SIGN_SP:
s = SIGN_PLUS;
@@ -285,7 +283,8 @@ calculate_exp (int d)
for Gw.dEe, n' ' means e+2 blanks */
static fnode *
-calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
+calculate_G_format (st_parameter_dt *dtp, fnode *f, GFC_REAL_LARGEST value,
+ int *num_blank)
{
int e = f->u.real.e;
int d = f->u.real.d;
@@ -366,7 +365,7 @@ calculate_G_format (fnode *f, GFC_REAL_L
newf->u.real.d = - (mid - d - 1);
/* For F editing, the scale factor is ignored. */
- g.scale_factor = 0;
+ dtp->u.p.scale_factor = 0;
return newf;
}
@@ -374,7 +373,7 @@ calculate_G_format (fnode *f, GFC_REAL_L
/* Output a real number according to its format which is FMT_G free. */
static void
-output_float (fnode *f, GFC_REAL_LARGEST value)
+output_float (st_parameter_dt *dtp, fnode *f, GFC_REAL_LARGEST value)
{
/* This must be large enough to accurately hold any value. */
char buffer[32];
@@ -410,12 +409,12 @@ output_float (fnode *f, GFC_REAL_LARGEST
/* We should always know the field width and precision. */
if (d < 0)
- internal_error ("Unspecified precision");
+ internal_error (&dtp->common, "Unspecified precision");
/* Use sprintf to print the number in the format +D.DDDDe+ddd
For an N digit exponent, this gives us (32-6)-N digits after the
decimal point, plus another one before the decimal point. */
- sign = calculate_sign (value < 0.0);
+ sign = calculate_sign (dtp, value < 0.0);
if (value < 0)
value = -value;
@@ -436,7 +435,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
}
if (ft == FMT_F || ft == FMT_EN
- || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
+ || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
{
/* Always convert at full precision to avoid double rounding. */
ndigits = 27 - edigits;
@@ -474,7 +473,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
/* Check the resulting string has punctuation in the correct places. */
if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
- internal_error ("printf is broken");
+ internal_error (&dtp->common, "printf is broken");
/* Read the exponent back in. */
e = atoi (&buffer[ndigits + 3]) + 1;
@@ -491,7 +490,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
switch (ft)
{
case FMT_F:
- nbefore = e + g.scale_factor;
+ nbefore = e + dtp->u.p.scale_factor;
if (nbefore < 0)
{
nzero = -nbefore;
@@ -511,7 +510,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
case FMT_E:
case FMT_D:
- i = g.scale_factor;
+ i = dtp->u.p.scale_factor;
if (value != 0.0)
e -= i;
if (i < 0)
@@ -570,7 +569,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
default:
/* Should never happen. */
- internal_error ("Unexpected format token");
+ internal_error (&dtp->common, "Unexpected format token");
}
/* Round the value. */
@@ -671,7 +670,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
/* Create the ouput buffer. */
- out = write_block (w);
+ out = write_block (dtp, w);
if (out == NULL)
return;
@@ -683,7 +682,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
break;
}
if (i == ndigits)
- sign = calculate_sign (0);
+ sign = calculate_sign (dtp, 0);
/* Work out how much padding is needed. */
nblanks = w - (nbefore + nzero + nafter + edigits + 1);
@@ -709,7 +708,7 @@ output_float (fnode *f, GFC_REAL_LARGEST
/* Pad to full field width. */
- if ( ( nblanks > 0 ) && !no_leading_blank )
+ if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
{
memset (out, ' ', nblanks);
out += nblanks;
@@ -784,22 +783,22 @@ output_float (fnode *f, GFC_REAL_LARGEST
memcpy (out, buffer, edigits);
}
- if ( no_leading_blank )
+ if (dtp->u.p.no_leading_blank)
{
out += edigits;
memset( out , ' ' , nblanks );
- no_leading_blank = 0;
+ dtp->u.p.no_leading_blank = 0;
}
}
void
-write_l (fnode * f, char *source, int len)
+write_l (st_parameter_dt *dtp, fnode * f, char *source, int len)
{
char *p;
GFC_INTEGER_LARGEST n;
- p = write_block (f->u.w);
+ p = write_block (dtp, f->u.w);
if (p == NULL)
return;
@@ -811,7 +810,7 @@ write_l (fnode * f, char *source, int le
/* Output a real number according to its format. */
static void
-write_float (fnode *f, const char *source, int len)
+write_float (st_parameter_dt *dtp, fnode *f, const char *source, int len)
{
GFC_REAL_LARGEST n;
int nb =0, res, save_scale_factor;
@@ -831,7 +830,7 @@ write_float (fnode *f, const char *sourc
not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
if (nb == 0) nb = 4;
- p = write_block (nb);
+ p = write_block (dtp, nb);
if (nb < 3)
{
memset (p, '*',nb);
@@ -889,20 +888,20 @@ write_float (fnode *f, const char *sourc
if (f->format != FMT_G)
{
- output_float (f, n);
+ output_float (dtp, f, n);
}
else
{
- save_scale_factor = g.scale_factor;
- f2 = calculate_G_format(f, n, &nb);
- output_float (f2, n);
- g.scale_factor = save_scale_factor;
+ save_scale_factor = dtp->u.p.scale_factor;
+ f2 = calculate_G_format (dtp, f, n, &nb);
+ output_float (dtp, f2, n);
+ dtp->u.p.scale_factor = save_scale_factor;
if (f2 != NULL)
free_mem(f2);
if (nb > 0)
{
- p = write_block (nb);
+ p = write_block (dtp, nb);
memset (p, ' ', nb);
}
}
@@ -910,7 +909,7 @@ write_float (fnode *f, const char *sourc
static void
-write_int (fnode *f, const char *source, int len,
+write_int (st_parameter_dt *dtp, fnode *f, const char *source, int len,
const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
{
GFC_UINTEGER_LARGEST n = 0;
@@ -931,7 +930,7 @@ write_int (fnode *f, const char *source,
if (w == 0)
w = 1;
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
@@ -948,7 +947,7 @@ write_int (fnode *f, const char *source,
if (w == 0)
w = ((digits < m) ? m : digits);
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
@@ -967,13 +966,13 @@ write_int (fnode *f, const char *source,
}
- if (!no_leading_blank)
+ if (!dtp->u.p.no_leading_blank)
{
- memset (p, ' ', nblank);
- p += nblank;
- memset (p, '0', nzero);
- p += nzero;
- memcpy (p, q, digits);
+ memset (p, ' ', nblank);
+ p += nblank;
+ memset (p, '0', nzero);
+ p += nzero;
+ memcpy (p, q, digits);
}
else
{
@@ -982,7 +981,7 @@ write_int (fnode *f, const char *source,
memcpy (p, q, digits);
p += digits;
memset (p, ' ', nblank);
- no_leading_blank = 0;
+ dtp->u.p.no_leading_blank = 0;
}
done:
@@ -990,7 +989,7 @@ write_int (fnode *f, const char *source,
}
static void
-write_decimal (fnode *f, const char *source, int len,
+write_decimal (st_parameter_dt *dtp, fnode *f, const char *source, int len,
const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
{
GFC_INTEGER_LARGEST n = 0;
@@ -1012,7 +1011,7 @@ write_decimal (fnode *f, const char *sou
if (w == 0)
w = 1;
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
@@ -1020,7 +1019,7 @@ write_decimal (fnode *f, const char *sou
goto done;
}
- sign = calculate_sign (n < 0);
+ sign = calculate_sign (dtp, n < 0);
if (n < 0)
n = -n;
@@ -1035,7 +1034,7 @@ write_decimal (fnode *f, const char *sou
if (w == 0)
w = ((digits < m) ? m : digits) + nsign;
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
@@ -1129,75 +1128,75 @@ btoa (GFC_UINTEGER_LARGEST n, char *buff
void
-write_i (fnode * f, const char *p, int len)
+write_i (st_parameter_dt *dtp, fnode * f, const char *p, int len)
{
- write_decimal (f, p, len, (void *) gfc_itoa);
+ write_decimal (dtp, f, p, len, (void *) gfc_itoa);
}
void
-write_b (fnode * f, const char *p, int len)
+write_b (st_parameter_dt *dtp, fnode * f, const char *p, int len)
{
- write_int (f, p, len, btoa);
+ write_int (dtp, f, p, len, btoa);
}
void
-write_o (fnode * f, const char *p, int len)
+write_o (st_parameter_dt *dtp, fnode * f, const char *p, int len)
{
- write_int (f, p, len, otoa);
+ write_int (dtp, f, p, len, otoa);
}
void
-write_z (fnode * f, const char *p, int len)
+write_z (st_parameter_dt *dtp, fnode * f, const char *p, int len)
{
- write_int (f, p, len, xtoa);
+ write_int (dtp, f, p, len, xtoa);
}
void
-write_d (fnode *f, const char *p, int len)
+write_d (st_parameter_dt *dtp, fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_e (fnode *f, const char *p, int len)
+write_e (st_parameter_dt *dtp, fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_f (fnode *f, const char *p, int len)
+write_f (st_parameter_dt *dtp, fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_en (fnode *f, const char *p, int len)
+write_en (st_parameter_dt *dtp, fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_es (fnode *f, const char *p, int len)
+write_es (st_parameter_dt *dtp, fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
/* Take care of the X/TR descriptor. */
void
-write_x (int len, int nspaces)
+write_x (st_parameter_dt *dtp, int len, int nspaces)
{
char *p;
- p = write_block (len);
+ p = write_block (dtp, len);
if (p == NULL)
return;
@@ -1213,11 +1212,11 @@ write_x (int len, int nspaces)
something goes wrong. */
static int
-write_char (char c)
+write_char (st_parameter_dt *dtp, char c)
{
char *p;
- p = write_block (1);
+ p = write_block (dtp, 1);
if (p == NULL)
return 1;
@@ -1230,16 +1229,16 @@ write_char (char c)
/* Write a list-directed logical value. */
static void
-write_logical (const char *source, int length)
+write_logical (st_parameter_dt *dtp, const char *source, int length)
{
- write_char (extract_int (source, length) ? 'T' : 'F');
+ write_char (dtp, extract_int (source, length) ? 'T' : 'F');
}
/* Write a list-directed integer value. */
static void
-write_integer (const char *source, int length)
+write_integer (st_parameter_dt *dtp, const char *source, int length)
{
char *p;
const char *q;
@@ -1276,16 +1275,16 @@ write_integer (const char *source, int l
if(width < digits )
width = digits ;
- p = write_block (width) ;
- if (no_leading_blank)
+ p = write_block (dtp, width) ;
+ if (dtp->u.p.no_leading_blank)
{
memcpy (p, q, digits);
- memset(p + digits ,' ', width - digits) ;
+ memset (p + digits ,' ', width - digits);
}
else
{
- memset(p ,' ', width - digits) ;
- memcpy (p + width - digits, q, digits);
+ memset (p, ' ', width - digits);
+ memcpy (p + width - digits, q, digits);
}
}
@@ -1294,12 +1293,12 @@ write_integer (const char *source, int l
the strings if the file has been opened in that mode. */
static void
-write_character (const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int length)
{
int i, extra;
char *p, d;
- switch (current_unit->flags.delim)
+ switch (dtp->u.p.current_unit->flags.delim)
{
case DELIM_APOSTROPHE:
d = '\'';
@@ -1323,7 +1322,7 @@ write_character (const char *source, int
extra++;
}
- p = write_block (length + extra);
+ p = write_block (dtp, length + extra);
if (p == NULL)
return;
@@ -1350,12 +1349,12 @@ write_character (const char *source, int
1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
static void
-write_real (const char *source, int length)
+write_real (st_parameter_dt *dtp, const char *source, int length)
{
fnode f ;
- int org_scale = g.scale_factor;
+ int org_scale = dtp->u.p.scale_factor;
f.format = FMT_G;
- g.scale_factor = 1;
+ dtp->u.p.scale_factor = 1;
switch (length)
{
case 4:
@@ -1379,37 +1378,37 @@ write_real (const char *source, int leng
f.u.real.e = 4;
break;
default:
- internal_error ("bad real kind");
+ internal_error (&dtp->common, "bad real kind");
break;
}
- write_float (&f, source , length);
- g.scale_factor = org_scale;
+ write_float (dtp, &f, source , length);
+ dtp->u.p.scale_factor = org_scale;
}
static void
-write_complex (const char *source, int len)
+write_complex (st_parameter_dt *dtp, const char *source, int len)
{
- if (write_char ('('))
+ if (write_char (dtp, '('))
return;
- write_real (source, len);
+ write_real (dtp, source, len);
- if (write_char (','))
+ if (write_char (dtp, ','))
return;
- write_real (source + len, len);
+ write_real (dtp, source + len, len);
- write_char (')');
+ write_char (dtp, ')');
}
/* Write the separator between items. */
static void
-write_separator (void)
+write_separator (st_parameter_dt *dtp)
{
char *p;
- p = write_block (options.separator_len);
+ p = write_block (dtp, options.separator_len);
if (p == NULL)
return;
@@ -1422,53 +1421,51 @@ write_separator (void)
with strings. */
static void
-list_formatted_write_scalar (bt type, void *p, int len)
+list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int len)
{
- static int char_flag;
-
- if (current_unit == NULL)
+ if (dtp->u.p.current_unit == NULL)
return;
- if (g.first_item)
+ if (dtp->u.p.first_item)
{
- g.first_item = 0;
- char_flag = 0;
- write_char (' ');
+ dtp->u.p.first_item = 0;
+ write_char (dtp, ' ');
}
else
{
- if (type != BT_CHARACTER || !char_flag ||
- current_unit->flags.delim != DELIM_NONE)
- write_separator ();
+ if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+ dtp->u.p.current_unit->flags.delim != DELIM_NONE)
+ write_separator (dtp);
}
switch (type)
{
case BT_INTEGER:
- write_integer (p, len);
+ write_integer (dtp, p, len);
break;
case BT_LOGICAL:
- write_logical (p, len);
+ write_logical (dtp, p, len);
break;
case BT_CHARACTER:
- write_character (p, len);
+ write_character (dtp, p, len);
break;
case BT_REAL:
- write_real (p, len);
+ write_real (dtp, p, len);
break;
case BT_COMPLEX:
- write_complex (p, len);
+ write_complex (dtp, p, len);
break;
default:
- internal_error ("list_formatted_write(): Bad type");
+ internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
- char_flag = (type == BT_CHARACTER);
+ dtp->u.p.char_flag = (type == BT_CHARACTER);
}
void
-list_formatted_write (bt type, void *p, int len, size_t nelems)
+list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int len,
+ size_t nelems)
{
size_t elem;
int size;
@@ -1484,8 +1481,8 @@ list_formatted_write (bt type, void *p,
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
- g.item_count++;
- list_formatted_write_scalar (type, tmp + size*elem, len);
+ dtp->u.p.item_count++;
+ list_formatted_write_scalar (dtp, type, tmp + size*elem, len);
}
}
@@ -1512,12 +1509,8 @@ list_formatted_write (bt type, void *p,
#define NML_DIGITS 20
-/* Stores the delimiter to be used for character objects. */
-
-static const char * nml_delim;
-
static namelist_info *
-nml_write_obj (namelist_info * obj, index_type offset,
+nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
namelist_info * base, char * base_name)
{
int rep_ctr;
@@ -1543,7 +1536,7 @@ nml_write_obj (namelist_info * obj, inde
if (obj->type != GFC_DTYPE_DERIVED)
{
- write_character ("\n ", 2);
+ write_character (dtp, "\n ", 2);
len = 0;
if (base)
{
@@ -1551,15 +1544,15 @@ nml_write_obj (namelist_info * obj, inde
for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
{
cup = toupper (base_name[dim_i]);
- write_character (&cup, 1);
+ write_character (dtp, &cup, 1);
}
}
for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
- write_character (&cup, 1);
+ write_character (dtp, &cup, 1);
}
- write_character ("=", 1);
+ write_character (dtp, "=", 1);
}
/* Counts the number of data output on a line, including names. */
@@ -1614,8 +1607,8 @@ nml_write_obj (namelist_info * obj, inde
if (rep_ctr > 1)
{
st_sprintf(rep_buff, " %d*", rep_ctr);
- write_character (rep_buff, strlen (rep_buff));
- no_leading_blank = 1;
+ write_character (dtp, rep_buff, strlen (rep_buff));
+ dtp->u.p.no_leading_blank = 1;
}
num++;
@@ -1626,29 +1619,29 @@ nml_write_obj (namelist_info * obj, inde
{
case GFC_DTYPE_INTEGER:
- write_integer (p, len);
+ write_integer (dtp, p, len);
break;
case GFC_DTYPE_LOGICAL:
- write_logical (p, len);
+ write_logical (dtp, p, len);
break;
case GFC_DTYPE_CHARACTER:
- if (nml_delim)
- write_character (nml_delim, 1);
- write_character (p, obj->string_length);
- if (nml_delim)
- write_character (nml_delim, 1);
+ if (dtp->u.p.nml_delim)
+ write_character (dtp, &dtp->u.p.nml_delim, 1);
+ write_character (dtp, p, obj->string_length);
+ if (dtp->u.p.nml_delim)
+ write_character (dtp, &dtp->u.p.nml_delim, 1);
break;
case GFC_DTYPE_REAL:
- write_real (p, len);
+ write_real (dtp, p, len);
break;
case GFC_DTYPE_COMPLEX:
- no_leading_blank = 0;
+ dtp->u.p.no_leading_blank = 0;
num++;
- write_complex (p, len);
+ write_complex (dtp, p, len);
break;
case GFC_DTYPE_DERIVED:
@@ -1698,7 +1691,8 @@ nml_write_obj (namelist_info * obj, inde
cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
cmp = retval)
{
- retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
+ retval = nml_write_obj (dtp, cmp,
+ (index_type)(p - obj->mem_pos),
obj, ext_name);
}
@@ -1707,19 +1701,19 @@ nml_write_obj (namelist_info * obj, inde
goto obj_loop;
default:
- internal_error ("Bad type for namelist write");
+ internal_error (&dtp->common, "Bad type for namelist write");
}
/* Reset the leading blank suppression, write a comma and, if 5
values have been output, write a newline and advance to column
2. Reset the repeat counter. */
- no_leading_blank = 0;
- write_character (",", 1);
+ dtp->u.p.no_leading_blank = 0;
+ write_character (dtp, ",", 1);
if (num > 5)
{
num = 0;
- write_character ("\n ", 2);
+ write_character (dtp, "\n ", 2);
}
rep_ctr = 1;
}
@@ -1752,7 +1746,7 @@ obj_loop:
the treatment of derived types. */
void
-namelist_write (void)
+namelist_write (st_parameter_dt *dtp)
{
namelist_info * t1, *t2, *dummy = NULL;
index_type i;
@@ -1763,46 +1757,47 @@ namelist_write (void)
/* Set the delimiter for namelist output. */
- tmp_delim = current_unit->flags.delim;
- current_unit->flags.delim = DELIM_NONE;
+ tmp_delim = dtp->u.p.current_unit->flags.delim;
+ dtp->u.p.current_unit->flags.delim = DELIM_NONE;
switch (tmp_delim)
{
case (DELIM_QUOTE):
- nml_delim = "\"";
+ dtp->u.p.nml_delim = '"';
break;
case (DELIM_APOSTROPHE):
- nml_delim = "'";
+ dtp->u.p.nml_delim = '\'';
break;
default:
- nml_delim = NULL;
+ dtp->u.p.nml_delim = '\0';
+ break;
}
- write_character ("&",1);
+ write_character (dtp, "&", 1);
/* Write namelist name in upper case - f95 std. */
- for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
+ for (i = 0 ;i < dtp->namelist_name_len ;i++ )
{
- c = toupper (ioparm.namelist_name[i]);
- write_character (&c ,1);
- }
+ c = toupper (dtp->namelist_name[i]);
+ write_character (dtp, &c ,1);
+ }
- if (ionml != NULL)
+ if (dtp->u.p.ionml != NULL)
{
- t1 = ionml;
+ t1 = dtp->u.p.ionml;
while (t1 != NULL)
{
t2 = t1;
- t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
+ t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
}
}
- write_character (" /\n", 4);
+ write_character (dtp, " /\n", 4);
/* Recover the original delimiter. */
- current_unit->flags.delim = tmp_delim;
+ dtp->u.p.current_unit->flags.delim = tmp_delim;
}
#undef NML_DIGITS
--- libgfortran/io/lock.c.jj 2005-08-30 08:24:15.000000000 +0200
+++ libgfortran/io/lock.c 2005-10-04 19:53:55.000000000 +0200
@@ -33,31 +33,18 @@ Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
#include "io.h"
-st_parameter ioparm;
-iexport_data(ioparm);
-
-namelist_info *ionml;
global_t g;
/* library_start()-- Called with a library call is entered. */
void
-library_start (void)
+library_start (st_parameter_common *cmp)
{
- if (g.in_library)
- internal_error ("Recursive library calls not allowed");
-
- /* The in_library flag indicates whether we're currently processing a
- library call. Some calls leave immediately, but READ and WRITE
- processing return control to the caller but are still considered to
- stay within the library. */
- g.in_library = 1;
-
- if (ioparm.iostat != NULL)
- *ioparm.iostat = ERROR_OK;
+ if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
+ *cmp->iostat = ERROR_OK;
- ioparm.library_return = LIBRARY_OK;
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
}
@@ -65,21 +52,15 @@ library_start (void)
clean up for the next call. */
void
-library_end (void)
+free_ionml (st_parameter_dt *dtp)
{
- int t;
namelist_info * t1, *t2;
- g.in_library = 0;
- filename = NULL;
- line = 0;
- t = ioparm.library_return;
-
/* Delete the namelist, if it exists. */
- if (ionml != NULL)
+ if (dtp->u.p.ionml != NULL)
{
- t1 = ionml;
+ t1 = dtp->u.p.ionml;
while (t1 != NULL)
{
t2 = t1;
@@ -93,8 +74,5 @@ library_end (void)
free_mem (t2);
}
}
- ionml = NULL;
-
- memset (&ioparm, '\0', sizeof (ioparm));
- ioparm.library_return = t;
+ dtp->u.p.ionml = NULL;
}
--- libgfortran/io/format.c.jj 2005-09-29 14:19:47.000000000 +0200
+++ libgfortran/io/format.c 2005-10-04 19:53:55.000000000 +0200
@@ -444,7 +444,7 @@ format_lex (void)
* parenthesis node which contains the rest of the list. */
static fnode *
-parse_format_list (void)
+parse_format_list (st_parameter_dt *dtp)
{
fnode *head, *tail;
format_token t, u, t2;
@@ -467,7 +467,7 @@ parse_format_list (void)
case FMT_LPAREN:
get_fnode (&head, &tail, FMT_LPAREN);
tail->repeat = repeat;
- tail->u.child = parse_format_list ();
+ tail->u.child = parse_format_list (dtp);
if (error != NULL)
goto finished;
@@ -494,7 +494,7 @@ parse_format_list (void)
case FMT_LPAREN:
get_fnode (&head, &tail, FMT_LPAREN);
tail->repeat = 1;
- tail->u.child = parse_format_list ();
+ tail->u.child = parse_format_list (dtp);
if (error != NULL)
goto finished;
@@ -699,7 +699,7 @@ parse_format_list (void)
tail->repeat = repeat;
u = format_lex ();
- if (t == FMT_F || g.mode == WRITING)
+ if (t == FMT_F || dtp->u.p.mode == WRITING)
{
if (u != FMT_POSINT && u != FMT_ZERO)
{
@@ -784,7 +784,7 @@ parse_format_list (void)
t = format_lex ();
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
if (t != FMT_POSINT)
{
@@ -898,7 +898,7 @@ parse_format_list (void)
* column display. */
void
-format_error (fnode * f, const char *message)
+format_error (st_parameter_dt *dtp, fnode * f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
@@ -910,12 +910,12 @@ format_error (fnode * f, const char *mes
st_sprintf (buffer, "%s\n", message);
- j = format_string - ioparm.format;
+ j = format_string - dtp->format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
- width = ioparm.format_len - offset;
+ width = dtp->format_len - offset;
if (width > 80)
width = 80;
@@ -924,7 +924,7 @@ format_error (fnode * f, const char *mes
p = strchr (buffer, '\0');
- memcpy (p, ioparm.format + offset, width);
+ memcpy (p, dtp->format + offset, width);
p += width;
*p++ = '\n';
@@ -937,17 +937,17 @@ format_error (fnode * f, const char *mes
*p++ = '^';
*p = '\0';
- generate_error (ERROR_FORMAT, buffer);
+ generate_error (&dtp->common, ERROR_FORMAT, buffer);
}
/* parse_format()-- Parse a format string. */
void
-parse_format (void)
+parse_format (st_parameter_dt *dtp)
{
- format_string = ioparm.format;
- format_string_len = ioparm.format_len;
+ format_string = dtp->format;
+ format_string_len = dtp->format_len;
saved_token = FMT_NONE;
error = NULL;
@@ -955,7 +955,6 @@ parse_format (void)
/* Initialize variables used during traversal of the tree */
reversion_ok = 0;
- g.reversion_flag = 0;
saved_format = NULL;
/* Allocate the first format node as the root of the tree */
@@ -967,12 +966,12 @@ parse_format (void)
avail++;
if (format_lex () == FMT_LPAREN)
- array[0].u.child = parse_format_list ();
+ array[0].u.child = parse_format_list (dtp);
else
error = "Missing initial left parenthesis in format";
if (error)
- format_error (NULL, error);
+ format_error (dtp, NULL, error);
}
@@ -984,11 +983,11 @@ parse_format (void)
* level. */
static void
-revert (void)
+revert (st_parameter_dt *dtp)
{
fnode *f, *r;
- g.reversion_flag = 1;
+ dtp->u.p.reversion_flag = 1;
r = NULL;
@@ -1054,7 +1053,7 @@ next_format0 (fnode * f)
* condition). */
fnode *
-next_format (void)
+next_format (st_parameter_dt *dtp)
{
format_token t;
fnode *f;
@@ -1075,12 +1074,12 @@ next_format (void)
}
reversion_ok = 0;
- revert ();
+ revert (dtp);
f = next_format0 (&array[0]);
if (f == NULL)
{
- format_error (NULL, reversion_error);
+ format_error (dtp, NULL, reversion_error);
return NULL;
}
@@ -1272,14 +1271,14 @@ dump_format (void)
void
-next_test (void)
+next_test (st_parameter_dt *dtp)
{
fnode *f;
int i;
for (i = 0; i < 20; i++)
{
- f = next_format ();
+ f = next_format (dtp);
if (f == NULL)
{
st_printf ("No format!\n");
--- gcc/fortran/resolve.c.jj 2005-10-04 19:23:13.000000000 +0200
+++ gcc/fortran/resolve.c 2005-10-04 19:53:55.000000000 +0200
@@ -3823,6 +3823,9 @@ resolve_blocks (gfc_code * b, gfc_namesp
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_READ:
+ case EXEC_WRITE:
+ case EXEC_IOLENGTH:
break;
default:
--- gcc/fortran/dump-parse-tree.c.jj 2005-09-13 11:08:39.000000000 +0200
+++ gcc/fortran/dump-parse-tree.c 2005-10-04 19:53:55.000000000 +0200
@@ -1353,6 +1353,7 @@ gfc_show_code_node (int level, gfc_code
case EXEC_IOLENGTH:
gfc_status ("IOLENGTH ");
gfc_show_expr (c->expr);
+ goto show_dt_code;
break;
case EXEC_READ:
@@ -1407,7 +1408,11 @@ gfc_show_code_node (int level, gfc_code
gfc_show_expr (dt->advance);
}
- break;
+ show_dt_code:
+ gfc_status_char ('\n');
+ for (c = c->block->next; c; c = c->next)
+ gfc_show_code_node (level + (c->next != NULL), c);
+ return;
case EXEC_TRANSFER:
gfc_status ("TRANSFER ");
--- gcc/fortran/io.c.jj 2005-09-26 08:39:40.000000000 +0200
+++ gcc/fortran/io.c 2005-10-04 19:53:55.000000000 +0200
@@ -2140,7 +2140,7 @@ terminate_io (gfc_code * io_code)
gfc_code *c;
if (io_code == NULL)
- io_code = &new_st;
+ io_code = new_st.block;
c = gfc_get_code ();
c->op = EXEC_DT_END;
@@ -2346,7 +2346,9 @@ get_io_list:
new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
new_st.ext.dt = dt;
- new_st.next = io_code;
+ new_st.block = gfc_get_code ();
+ new_st.block->op = new_st.op;
+ new_st.block->next = io_code;
terminate_io (io_code);
@@ -2515,8 +2517,6 @@ gfc_match_inquire (void)
if (m == MATCH_NO)
goto syntax;
- terminate_io (code);
-
new_st.op = EXEC_IOLENGTH;
new_st.expr = inquire->iolength;
new_st.ext.inquire = inquire;
@@ -2528,7 +2528,10 @@ gfc_match_inquire (void)
return MATCH_ERROR;
}
- new_st.next = code;
+ new_st.block = gfc_get_code ();
+ new_st.block->op = EXEC_IOLENGTH;
+ terminate_io (code);
+ new_st.block->next = code;
return MATCH_YES;
}
--- gcc/fortran/ioparm.def.jj 2005-10-04 11:29:03.000000000 +0200
+++ gcc/fortran/ioparm.def 2005-10-04 22:14:54.000000000 +0200
@@ -0,0 +1,67 @@
+#ifndef IOPARM_common_libreturn_mask
+#define IOPARM_common_libreturn_mask 3
+#define IOPARM_common_libreturn_ok 0
+#define IOPARM_common_libreturn_error 1
+#define IOPARM_common_libreturn_end 2
+#define IOPARM_common_libreturn_eor 3
+#define IOPARM_common_err (1 << 2)
+#define IOPARM_common_end (1 << 3)
+#define IOPARM_common_eor (1 << 4)
+#endif
+IOPARM (common, flags, 0, int4)
+IOPARM (common, unit, 0, int4)
+IOPARM (common, filename, 0, pchar)
+IOPARM (common, line, 0, int4)
+IOPARM (common, iomsg, 1 << 6, char2)
+IOPARM (common, iostat, 1 << 5, pint4)
+IOPARM (open, common, 0, common)
+IOPARM (open, recl_in, 1 << 7, int4)
+IOPARM (open, file, 1 << 8, char2)
+IOPARM (open, status, 1 << 9, char1)
+IOPARM (open, access, 1 << 10, char2)
+IOPARM (open, form, 1 << 11, char1)
+IOPARM (open, blank, 1 << 12, char2)
+IOPARM (open, position, 1 << 13, char1)
+IOPARM (open, action, 1 << 14, char2)
+IOPARM (open, delim, 1 << 15, char1)
+IOPARM (open, pad, 1 << 16, char2)
+IOPARM (close, common, 0, common)
+IOPARM (close, status, 1 << 7, char1)
+IOPARM (filepos, common, 0, common)
+IOPARM (inquire, common, 0, common)
+IOPARM (inquire, exist, 1 << 7, pint4)
+IOPARM (inquire, opened, 1 << 8, pint4)
+IOPARM (inquire, number, 1 << 9, pint4)
+IOPARM (inquire, named, 1 << 10, pint4)
+IOPARM (inquire, nextrec, 1 << 11, pint4)
+IOPARM (inquire, recl_out, 1 << 12, pint4)
+IOPARM (inquire, file, 1 << 13, char1)
+IOPARM (inquire, access, 1 << 14, char2)
+IOPARM (inquire, form, 1 << 15, char1)
+IOPARM (inquire, blank, 1 << 16, char2)
+IOPARM (inquire, position, 1 << 17, char1)
+IOPARM (inquire, action, 1 << 18, char2)
+IOPARM (inquire, delim, 1 << 19, char1)
+IOPARM (inquire, pad, 1 << 20, char2)
+IOPARM (inquire, name, 1 << 21, char1)
+IOPARM (inquire, sequential, 1 << 22, char2)
+IOPARM (inquire, direct, 1 << 23, char1)
+IOPARM (inquire, formatted, 1 << 24, char2)
+IOPARM (inquire, unformatted, 1 << 25, char1)
+IOPARM (inquire, read, 1 << 26, char2)
+IOPARM (inquire, write, 1 << 27, char1)
+IOPARM (inquire, readwrite, 1 << 28, char2)
+#ifndef IOPARM_dt_list_format
+#define IOPARM_dt_list_format (1 << 7)
+#define IOPARM_dt_namelist_read_mode (1 << 8)
+#endif
+IOPARM (dt, common, 0, common)
+IOPARM (dt, rec, 1 << 9, int4)
+IOPARM (dt, size, 1 << 10, pint4)
+IOPARM (dt, iolength, 1 << 11, pint4)
+IOPARM (dt, internal_unit_desc, 0, parray)
+IOPARM (dt, format, 1 << 12, char1)
+IOPARM (dt, advance, 1 << 13, char2)
+IOPARM (dt, internal_unit, 1 << 14, char1)
+IOPARM (dt, namelist_name, 1 << 15, char2)
+IOPARM (dt, u, 0, pad)
--- gcc/fortran/Make-lang.in.jj 2005-09-19 22:45:53.000000000 +0200
+++ gcc/fortran/Make-lang.in 2005-10-04 19:53:55.000000000 +0200
@@ -292,7 +292,8 @@ fortran/trans-types.o: $(GFORTRAN_TRANS_
fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
-fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h
+fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \
+ fortran/ioparm.def
fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-trans-intrinsic.h
--- gcc/fortran/trans-io.c.jj 2005-09-27 10:14:38.000000000 +0200
+++ gcc/fortran/trans-io.c 2005-10-04 22:07:51.000000000 +0200
@@ -38,348 +38,382 @@ Software Foundation, 51 Franklin Street,
/* Members of the ioparm structure. */
-static GTY(()) tree ioparm_unit;
-static GTY(()) tree ioparm_err;
-static GTY(()) tree ioparm_end;
-static GTY(()) tree ioparm_eor;
-static GTY(()) tree ioparm_list_format;
-static GTY(()) tree ioparm_library_return;
-static GTY(()) tree ioparm_iostat;
-static GTY(()) tree ioparm_exist;
-static GTY(()) tree ioparm_opened;
-static GTY(()) tree ioparm_number;
-static GTY(()) tree ioparm_named;
-static GTY(()) tree ioparm_rec;
-static GTY(()) tree ioparm_nextrec;
-static GTY(()) tree ioparm_size;
-static GTY(()) tree ioparm_recl_in;
-static GTY(()) tree ioparm_recl_out;
-static GTY(()) tree ioparm_iolength;
-static GTY(()) tree ioparm_file;
-static GTY(()) tree ioparm_file_len;
-static GTY(()) tree ioparm_status;
-static GTY(()) tree ioparm_status_len;
-static GTY(()) tree ioparm_access;
-static GTY(()) tree ioparm_access_len;
-static GTY(()) tree ioparm_form;
-static GTY(()) tree ioparm_form_len;
-static GTY(()) tree ioparm_blank;
-static GTY(()) tree ioparm_blank_len;
-static GTY(()) tree ioparm_position;
-static GTY(()) tree ioparm_position_len;
-static GTY(()) tree ioparm_action;
-static GTY(()) tree ioparm_action_len;
-static GTY(()) tree ioparm_delim;
-static GTY(()) tree ioparm_delim_len;
-static GTY(()) tree ioparm_pad;
-static GTY(()) tree ioparm_pad_len;
-static GTY(()) tree ioparm_format;
-static GTY(()) tree ioparm_format_len;
-static GTY(()) tree ioparm_advance;
-static GTY(()) tree ioparm_advance_len;
-static GTY(()) tree ioparm_name;
-static GTY(()) tree ioparm_name_len;
-static GTY(()) tree ioparm_internal_unit;
-static GTY(()) tree ioparm_internal_unit_len;
-static GTY(()) tree ioparm_internal_unit_desc;
-static GTY(()) tree ioparm_sequential;
-static GTY(()) tree ioparm_sequential_len;
-static GTY(()) tree ioparm_direct;
-static GTY(()) tree ioparm_direct_len;
-static GTY(()) tree ioparm_formatted;
-static GTY(()) tree ioparm_formatted_len;
-static GTY(()) tree ioparm_unformatted;
-static GTY(()) tree ioparm_unformatted_len;
-static GTY(()) tree ioparm_read;
-static GTY(()) tree ioparm_read_len;
-static GTY(()) tree ioparm_write;
-static GTY(()) tree ioparm_write_len;
-static GTY(()) tree ioparm_readwrite;
-static GTY(()) tree ioparm_readwrite_len;
-static GTY(()) tree ioparm_namelist_name;
-static GTY(()) tree ioparm_namelist_name_len;
-static GTY(()) tree ioparm_namelist_read_mode;
-static GTY(()) tree ioparm_iomsg;
-static GTY(()) tree ioparm_iomsg_len;
-
-/* The global I/O variables */
-
-static GTY(()) tree ioparm_var;
-static GTY(()) tree locus_file;
-static GTY(()) tree locus_line;
+enum ioparam_type
+{
+ IOPARM_ptype_common,
+ IOPARM_ptype_open,
+ IOPARM_ptype_close,
+ IOPARM_ptype_filepos,
+ IOPARM_ptype_inquire,
+ IOPARM_ptype_dt,
+ IOPARM_ptype_num
+};
+
+enum iofield_type
+{
+ IOPARM_type_int4,
+ IOPARM_type_pint4,
+ IOPARM_type_pchar,
+ IOPARM_type_parray,
+ IOPARM_type_pad,
+ IOPARM_type_char1,
+ IOPARM_type_char2,
+ IOPARM_type_common,
+ IOPARM_type_num
+};
+
+typedef struct gfc_st_parameter_field GTY(())
+{
+ const char *name;
+ unsigned int mask;
+ enum ioparam_type param_type;
+ enum iofield_type type;
+ tree field;
+ tree field_len;
+}
+gfc_st_parameter_field;
+
+typedef struct gfc_st_parameter GTY(())
+{
+ const char *name;
+ tree type;
+}
+gfc_st_parameter;
+enum iofield
+{
+#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
+#include "ioparm.def"
+#undef IOPARM
+ IOPARM_field_num
+};
+
+static GTY(()) gfc_st_parameter st_parameter[] =
+{
+ { "common", NULL },
+ { "open", NULL },
+ { "close", NULL },
+ { "filepos", NULL },
+ { "inquire", NULL },
+ { "dt", NULL }
+};
+
+static GTY(()) gfc_st_parameter_field st_parameter_field[] =
+{
+#define IOPARM(param_type, name, mask, type) \
+ { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
+#include "ioparm.def"
+#undef IOPARM
+ { NULL, 0, 0, 0, NULL, NULL }
+};
/* Library I/O subroutines */
-static GTY(()) tree iocall_read;
-static GTY(()) tree iocall_read_done;
-static GTY(()) tree iocall_write;
-static GTY(()) tree iocall_write_done;
-static GTY(()) tree iocall_x_integer;
-static GTY(()) tree iocall_x_logical;
-static GTY(()) tree iocall_x_character;
-static GTY(()) tree iocall_x_real;
-static GTY(()) tree iocall_x_complex;
-static GTY(()) tree iocall_x_array;
-static GTY(()) tree iocall_open;
-static GTY(()) tree iocall_close;
-static GTY(()) tree iocall_inquire;
-static GTY(()) tree iocall_iolength;
-static GTY(()) tree iocall_iolength_done;
-static GTY(()) tree iocall_rewind;
-static GTY(()) tree iocall_backspace;
-static GTY(()) tree iocall_endfile;
-static GTY(()) tree iocall_flush;
-static GTY(()) tree iocall_set_nml_val;
-static GTY(()) tree iocall_set_nml_val_dim;
+enum iocall
+{
+ IOCALL_READ,
+ IOCALL_READ_DONE,
+ IOCALL_WRITE,
+ IOCALL_WRITE_DONE,
+ IOCALL_X_INTEGER,
+ IOCALL_X_LOGICAL,
+ IOCALL_X_CHARACTER,
+ IOCALL_X_REAL,
+ IOCALL_X_COMPLEX,
+ IOCALL_X_ARRAY,
+ IOCALL_OPEN,
+ IOCALL_CLOSE,
+ IOCALL_INQUIRE,
+ IOCALL_IOLENGTH,
+ IOCALL_IOLENGTH_DONE,
+ IOCALL_REWIND,
+ IOCALL_BACKSPACE,
+ IOCALL_ENDFILE,
+ IOCALL_FLUSH,
+ IOCALL_SET_NML_VAL,
+ IOCALL_SET_NML_VAL_DIM,
+ IOCALL_NUM
+};
+
+static GTY(()) tree iocall[IOCALL_NUM];
/* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data
transfer is complete. */
static enum { READ, WRITE, IOLENGTH } last_dt;
-#define ADD_FIELD(name, type) \
- ioparm_ ## name = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name)), type)
-
-#define ADD_STRING(name) \
- ioparm_ ## name = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name)), pchar_type_node); \
- ioparm_ ## name ## _len = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
+/* The data transfer parameter block that should be shared by all
+ data transfer calls belonging to the same read/write/iolength. */
+static GTY(()) tree dt_parm;
+static void
+gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
+{
+ enum iofield type;
+ gfc_st_parameter_field *p;
+ char name[64];
+ size_t len;
+ tree t = make_node (RECORD_TYPE);
+
+ len = strlen (st_parameter[ptype].name);
+ gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
+ memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
+ memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
+ len);
+ TYPE_NAME (t) = get_identifier (name);
+
+ for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
+ if (p->param_type == ptype)
+ switch (p->type)
+ {
+ case IOPARM_type_int4:
+ case IOPARM_type_pint4:
+ case IOPARM_type_parray:
+ case IOPARM_type_pchar:
+ case IOPARM_type_pad:
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ types[p->type]);
+ break;
+ case IOPARM_type_char1:
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ pchar_type_node);
+ /* FALLTHROUGH */
+ case IOPARM_type_char2:
+ len = strlen (p->name);
+ gcc_assert (len <= sizeof (name) - sizeof ("_len"));
+ memcpy (name, p->name, len);
+ memcpy (name + len, "_len", sizeof ("_len"));
+ p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (name),
+ gfc_charlen_type_node);
+ if (p->type == IOPARM_type_char2)
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ pchar_type_node);
+ break;
+ case IOPARM_type_common:
+ p->field
+ = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ st_parameter[IOPARM_ptype_common].type);
+ break;
+ case IOPARM_type_num:
+ gcc_unreachable ();
+ }
+
+ gfc_finish_type (t);
+ st_parameter[ptype].type = t;
+}
/* Create function decls for IO library functions. */
void
gfc_build_io_library_fndecls (void)
{
- tree gfc_int4_type_node;
- tree gfc_pint4_type_node;
- tree ioparm_type;
-
- gfc_int4_type_node = gfc_get_int_type (4);
- gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
-
- /* Build the st_parameter structure. Information associated with I/O
- calls are transferred here. This must match the one defined in the
- library exactly. */
-
- ioparm_type = make_node (RECORD_TYPE);
- TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
-
- ADD_FIELD (unit, gfc_int4_type_node);
- ADD_FIELD (err, gfc_int4_type_node);
- ADD_FIELD (end, gfc_int4_type_node);
- ADD_FIELD (eor, gfc_int4_type_node);
- ADD_FIELD (list_format, gfc_int4_type_node);
- ADD_FIELD (library_return, gfc_int4_type_node);
-
- ADD_FIELD (iostat, gfc_pint4_type_node);
- ADD_FIELD (exist, gfc_pint4_type_node);
- ADD_FIELD (opened, gfc_pint4_type_node);
- ADD_FIELD (number, gfc_pint4_type_node);
- ADD_FIELD (named, gfc_pint4_type_node);
- ADD_FIELD (rec, gfc_int4_type_node);
- ADD_FIELD (nextrec, gfc_pint4_type_node);
- ADD_FIELD (size, gfc_pint4_type_node);
-
- ADD_FIELD (recl_in, gfc_int4_type_node);
- ADD_FIELD (recl_out, gfc_pint4_type_node);
-
- ADD_FIELD (iolength, gfc_pint4_type_node);
-
- ADD_STRING (file);
- ADD_STRING (status);
-
- ADD_STRING (access);
- ADD_STRING (form);
- ADD_STRING (blank);
- ADD_STRING (position);
- ADD_STRING (action);
- ADD_STRING (delim);
- ADD_STRING (pad);
- ADD_STRING (format);
- ADD_STRING (advance);
- ADD_STRING (name);
- ADD_STRING (internal_unit);
- ADD_FIELD (internal_unit_desc, pchar_type_node);
- ADD_STRING (sequential);
-
- ADD_STRING (direct);
- ADD_STRING (formatted);
- ADD_STRING (unformatted);
- ADD_STRING (read);
- ADD_STRING (write);
- ADD_STRING (readwrite);
-
- ADD_STRING (namelist_name);
- ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
- ADD_STRING (iomsg);
-
- gfc_finish_type (ioparm_type);
-
- ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
- ioparm_type);
- DECL_EXTERNAL (ioparm_var) = 1;
- TREE_PUBLIC (ioparm_var) = 1;
-
- locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
- gfc_int4_type_node);
- DECL_EXTERNAL (locus_line) = 1;
- TREE_PUBLIC (locus_line) = 1;
-
- locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
- pchar_type_node);
- DECL_EXTERNAL (locus_file) = 1;
- TREE_PUBLIC (locus_file) = 1;
+ tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
+ tree parm_type, dt_parm_type;
+ HOST_WIDE_INT pad_size;
+ enum ioparam_type ptype;
+
+ types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
+ types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
+ types[IOPARM_type_parray] = pchar_type_node;
+ types[IOPARM_type_pchar] = pchar_type_node;
+ pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+ pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
+ pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
+ types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
+
+ for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
+ gfc_build_st_parameter (ptype, types);
/* Define the transfer functions. */
- iocall_x_integer =
+ dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
+
+ iocall[IOCALL_X_INTEGER] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_integer")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_logical =
+ iocall[IOCALL_X_LOGICAL] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_logical")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_character =
+ iocall[IOCALL_X_CHARACTER] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_character")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_real =
+ iocall[IOCALL_X_REAL] =
gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
- void_type_node, 2,
+ void_type_node, 3, dt_parm_type,
pvoid_type_node, gfc_int4_type_node);
- iocall_x_complex =
+ iocall[IOCALL_X_COMPLEX] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_complex")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_array =
+ iocall[IOCALL_X_ARRAY] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_array")),
- void_type_node, 2, pvoid_type_node,
- gfc_charlen_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_charlen_type_node);
/* Library entry points */
- iocall_read =
+ iocall[IOCALL_READ] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
- void_type_node, 0);
+ void_type_node, 1, dt_parm_type);
- iocall_write =
+ iocall[IOCALL_WRITE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
- void_type_node, 0);
- iocall_open =
+ void_type_node, 1, dt_parm_type);
+
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
+ iocall[IOCALL_OPEN] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
- void_type_node, 0);
+ void_type_node, 1, parm_type);
+
- iocall_close =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
+ iocall[IOCALL_CLOSE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
- void_type_node, 0);
+ void_type_node, 1, parm_type);
- iocall_inquire =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
+ iocall[IOCALL_INQUIRE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_iolength =
+ iocall[IOCALL_IOLENGTH] =
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
- void_type_node, 0);
+ void_type_node, 1, dt_parm_type);
- iocall_rewind =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
+ iocall[IOCALL_REWIND] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_backspace =
+ iocall[IOCALL_BACKSPACE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_endfile =
+ iocall[IOCALL_ENDFILE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_flush =
+ iocall[IOCALL_FLUSH] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
/* Library helpers */
- iocall_read_done =
+ iocall[IOCALL_READ_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_write_done =
+ iocall[IOCALL_WRITE_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_iolength_done =
+ iocall[IOCALL_IOLENGTH_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_set_nml_val =
+ iocall[IOCALL_SET_NML_VAL] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
- void_type_node, 5,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node, gfc_charlen_type_node,
+ void_type_node, 6, dt_parm_type,
+ pvoid_type_node, pvoid_type_node,
+ gfc_int4_type_node, gfc_charlen_type_node,
gfc_int4_type_node);
- iocall_set_nml_val_dim =
+ iocall[IOCALL_SET_NML_VAL_DIM] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
- void_type_node, 4,
+ void_type_node, 5, dt_parm_type,
gfc_int4_type_node, gfc_int4_type_node,
gfc_int4_type_node, gfc_int4_type_node);
}
+/* Generate code to store an integer constant into the
+ st_parameter_XXX structure. */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+ unsigned int val)
+{
+ tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+ return p->mask;
+}
+
+
/* Generate code to store a non-string I/O parameter into the
- ioparm structure. This is a pass by value. */
+ st_parameter_XXX structure. This is a pass by value. */
-static void
-set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
+ gfc_expr *e)
{
gfc_se se;
tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, e, TREE_TYPE (var));
+ gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
gfc_add_block_to_block (block, &se.pre);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
gfc_add_modify_expr (block, tmp, se.expr);
+ return p->mask;
}
/* Generate code to store a non-string I/O parameter into the
- ioparm structure. This is pass by reference. */
+ st_parameter_XXX structure. This is pass by reference. */
-static void
-set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_ref (stmtblock_t * block, tree var, enum iofield type,
+ gfc_expr * e)
{
gfc_se se;
tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
se.want_pointer = 1;
- gfc_conv_expr_type (&se, e, TREE_TYPE (var));
+ gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
gfc_add_block_to_block (block, &se.pre);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
gfc_add_modify_expr (block, tmp, se.expr);
+ return p->mask;
}
/* Given an array expr, find its address and length to get a string. If the
@@ -447,22 +481,27 @@ gfc_convert_array_to_string (gfc_se * se
/* Generate code to store a string and its length into the
- ioparm structure. */
+ st_parameter_XXX structure. */
-static void
+static unsigned int
set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
- tree var_len, gfc_expr * e)
+ enum iofield type, gfc_expr * e)
{
gfc_se se;
tree tmp;
tree msg;
tree io;
tree len;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
- io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
- len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
NULL_TREE);
/* Integer variable assigned a format label. */
@@ -497,28 +536,34 @@ set_string (stmtblock_t * block, stmtblo
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
+ return p->mask;
}
/* Generate code to store the character (array) and the character length
for an internal unit. */
-static void
-set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len,
- tree iunit_desc, gfc_expr * e)
+static unsigned int
+set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
{
gfc_se se;
tree io;
tree len;
tree desc;
tree tmp;
+ gfc_st_parameter_field *p;
+ unsigned int mask;
gfc_init_se (&se, NULL);
- io = build3 (COMPONENT_REF, TREE_TYPE (iunit), ioparm_var, iunit, NULL_TREE);
- len = build3 (COMPONENT_REF, TREE_TYPE (iunit_len), ioparm_var, iunit_len,
+ p = &st_parameter_field[IOPARM_dt_internal_unit];
+ mask = p->mask;
+ io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
NULL_TREE);
- desc = build3 (COMPONENT_REF, TREE_TYPE (iunit_desc), ioparm_var, iunit_desc,
+ p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
+ desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
NULL_TREE);
gcc_assert (e->ts.type == BT_CHARACTER);
@@ -552,19 +597,9 @@ set_internal_unit (stmtblock_t * block,
gfc_add_modify_expr (&se.pre, desc, se.expr);
gfc_add_block_to_block (block, &se.pre);
+ return mask;
}
-/* Set a member of the ioparm structure to one. */
-static void
-set_flag (stmtblock_t *block, tree var)
-{
- tree tmp, type = TREE_TYPE (var);
-
- tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
- gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
-}
-
-
/* Add a case to a IO-result switch. */
static void
@@ -597,11 +632,12 @@ add_case (int label_value, gfc_st_label
be created anyway. */
static void
-io_result (stmtblock_t * block, gfc_st_label * err_label,
+io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
gfc_st_label * end_label, gfc_st_label * eor_label)
{
stmtblock_t body;
tree tmp, rc;
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
/* If no labels are specified, ignore the result instead
of building an empty switch. */
@@ -621,8 +657,12 @@ io_result (stmtblock_t * block, gfc_st_l
tmp = gfc_finish_block (&body);
- rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
- ioparm_library_return, NULL_TREE);
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
+ build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
@@ -634,24 +674,29 @@ io_result (stmtblock_t * block, gfc_st_l
library call goes awry, we can tell the user where the problem is. */
static void
-set_error_locus (stmtblock_t * block, locus * where)
+set_error_locus (stmtblock_t * block, tree var, locus * where)
{
gfc_file *f;
- tree tmp;
+ tree str, locus_file;
int line;
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
+ locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
+ p->field, NULL_TREE);
f = where->lb->file;
- tmp = gfc_build_cstring_const (f->filename);
+ str = gfc_build_cstring_const (f->filename);
- tmp = gfc_build_addr_expr (pchar_type_node, tmp);
- gfc_add_modify_expr (block, locus_file, tmp);
+ str = gfc_build_addr_expr (pchar_type_node, str);
+ gfc_add_modify_expr (block, locus_file, str);
#ifdef USE_MAPPED_LOCATION
line = LOCATION_LINE (where->lb->location);
#else
line = where->lb->linenum;
#endif
- gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
+ set_parameter_const (block, var, IOPARM_common_line, line);
}
@@ -662,69 +707,78 @@ gfc_trans_open (gfc_code * code)
{
stmtblock_t block, post_block;
gfc_open *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.open;
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->file)
- set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
if (p->status)
- set_string (&block, &post_block, ioparm_status,
- ioparm_status_len, p->status);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_status,
+ p->status);
if (p->access)
- set_string (&block, &post_block, ioparm_access,
- ioparm_access_len, p->access);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_access,
+ p->access);
if (p->form)
- set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
if (p->recl)
- set_parameter_value (&block, ioparm_recl_in, p->recl);
+ mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
if (p->blank)
- set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
- p->blank);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
+ p->blank);
if (p->position)
- set_string (&block, &post_block, ioparm_position,
- ioparm_position_len, p->position);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_position,
+ p->position);
if (p->action)
- set_string (&block, &post_block, ioparm_action,
- ioparm_action_len, p->action);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_action,
+ p->action);
if (p->delim)
- set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
- p->delim);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
+ p->delim);
if (p->pad)
- set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_function_call (iocall_open, NULL_TREE);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (iocall[IOCALL_OPEN], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
@@ -737,37 +791,46 @@ gfc_trans_close (gfc_code * code)
{
stmtblock_t block, post_block;
gfc_close *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.close;
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->status)
- set_string (&block, &post_block, ioparm_status,
- ioparm_status_len, p->status);
+ mask |= set_string (&block, &post_block, var, IOPARM_close_status,
+ p->status);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
- tmp = gfc_build_function_call (iocall_close, NULL_TREE);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (iocall[IOCALL_CLOSE], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
@@ -780,34 +843,44 @@ build_filepos (tree function, gfc_code *
{
stmtblock_t block, post_block;
gfc_filepos *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
p = code->ext.filepos;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
+ "filepos_parm");
+
+ set_error_locus (&block, var, &code->loc);
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
- tmp = gfc_build_function_call (function, NULL);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
@@ -818,8 +891,7 @@ build_filepos (tree function, gfc_code *
tree
gfc_trans_backspace (gfc_code * code)
{
-
- return build_filepos (iocall_backspace, code);
+ return build_filepos (iocall[IOCALL_BACKSPACE], code);
}
@@ -828,8 +900,7 @@ gfc_trans_backspace (gfc_code * code)
tree
gfc_trans_endfile (gfc_code * code)
{
-
- return build_filepos (iocall_endfile, code);
+ return build_filepos (iocall[IOCALL_ENDFILE], code);
}
@@ -838,8 +909,7 @@ gfc_trans_endfile (gfc_code * code)
tree
gfc_trans_rewind (gfc_code * code)
{
-
- return build_filepos (iocall_rewind, code);
+ return build_filepos (iocall[IOCALL_REWIND], code);
}
@@ -848,8 +918,7 @@ gfc_trans_rewind (gfc_code * code)
tree
gfc_trans_flush (gfc_code * code)
{
-
- return build_filepos (iocall_flush, code);
+ return build_filepos (iocall[IOCALL_FLUSH], code);
}
@@ -860,12 +929,16 @@ gfc_trans_inquire (gfc_code * code)
{
stmtblock_t block, post_block;
gfc_inquire *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
+ "inquire_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.inquire;
/* Sanity check. */
@@ -873,102 +946,113 @@ gfc_trans_inquire (gfc_code * code)
gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc);
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->file)
- set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
+ p->file);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
if (p->exist)
- set_parameter_ref (&block, ioparm_exist, p->exist);
+ mask |= set_parameter_ref (&block, var, IOPARM_inquire_exist, p->exist);
if (p->opened)
- set_parameter_ref (&block, ioparm_opened, p->opened);
+ mask |= set_parameter_ref (&block, var, IOPARM_inquire_opened, p->opened);
if (p->number)
- set_parameter_ref (&block, ioparm_number, p->number);
+ mask |= set_parameter_ref (&block, var, IOPARM_inquire_number, p->number);
if (p->named)
- set_parameter_ref (&block, ioparm_named, p->named);
+ mask |= set_parameter_ref (&block, var, IOPARM_inquire_named, p->named);
if (p->name)
- set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
+ p->name);
if (p->access)
- set_string (&block, &post_block, ioparm_access,
- ioparm_access_len, p->access);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
+ p->access);
if (p->sequential)
- set_string (&block, &post_block, ioparm_sequential,
- ioparm_sequential_len, p->sequential);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
+ p->sequential);
if (p->direct)
- set_string (&block, &post_block, ioparm_direct,
- ioparm_direct_len, p->direct);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
+ p->direct);
if (p->form)
- set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
+ p->form);
if (p->formatted)
- set_string (&block, &post_block, ioparm_formatted,
- ioparm_formatted_len, p->formatted);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
+ p->formatted);
if (p->unformatted)
- set_string (&block, &post_block, ioparm_unformatted,
- ioparm_unformatted_len, p->unformatted);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
+ p->unformatted);
if (p->recl)
- set_parameter_ref (&block, ioparm_recl_out, p->recl);
+ mask |= set_parameter_ref (&block, var, IOPARM_inquire_recl_out, p->recl);
if (p->nextrec)
- set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
+ mask |= set_parameter_ref (&block, var, IOPARM_inquire_nextrec,
+ p->nextrec);
if (p->blank)
- set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
- p->blank);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
+ p->blank);
if (p->position)
- set_string (&block, &post_block, ioparm_position,
- ioparm_position_len, p->position);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
+ p->position);
if (p->action)
- set_string (&block, &post_block, ioparm_action,
- ioparm_action_len, p->action);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
+ p->action);
if (p->read)
- set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
+ p->read);
if (p->write)
- set_string (&block, &post_block, ioparm_write,
- ioparm_write_len, p->write);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
+ p->write);
if (p->readwrite)
- set_string (&block, &post_block, ioparm_readwrite,
- ioparm_readwrite_len, p->readwrite);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
+ p->readwrite);
if (p->delim)
- set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
- p->delim);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+ p->delim);
if (p->pad)
- set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
- p->pad);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
+ p->pad);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
- tmp = gfc_build_function_call (iocall_inquire, NULL);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (iocall[IOCALL_INQUIRE], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
@@ -1082,8 +1166,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc
}
/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
- call to iocall_set_nml_val. For derived type variable, recursively
- generate calls to iocall_set_nml_val for each component. */
+ call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
+ generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
#define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
#define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
@@ -1102,6 +1186,7 @@ transfer_namelist_element (stmtblock_t *
tree tmp;
tree args;
tree dtype;
+ tree dt_parm_addr;
int n_dim;
int itype;
int rank = 0;
@@ -1164,7 +1249,9 @@ transfer_namelist_element (stmtblock_t *
The call for the scalar part transfers:
(address, name, type, kind or string_length, dtype) */
- NML_FIRST_ARG (addr_expr);
+ dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ NML_FIRST_ARG (dt_parm_addr);
+ NML_ADD_ARG (addr_expr);
NML_ADD_ARG (string);
NML_ADD_ARG (IARG (ts->kind));
@@ -1174,7 +1261,7 @@ transfer_namelist_element (stmtblock_t *
NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
NML_ADD_ARG (dtype);
- tmp = gfc_build_function_call (iocall_set_nml_val, args);
+ tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL], args);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
@@ -1182,11 +1269,12 @@ transfer_namelist_element (stmtblock_t *
for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
{
- NML_FIRST_ARG (IARG (n_dim));
+ NML_FIRST_ARG (dt_parm_addr);
+ NML_ADD_ARG (IARG (n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
- tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
+ tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL_DIM], args);
gfc_add_expr_to_block (block, tmp);
}
@@ -1218,98 +1306,138 @@ transfer_namelist_element (stmtblock_t *
out by now. */
static tree
-build_dt (tree * function, gfc_code * code)
+build_dt (tree function, gfc_code * code)
{
stmtblock_t block, post_block;
gfc_dt *dt;
- tree tmp;
+ tree tmp, var;
gfc_expr *nmlname;
gfc_namelist *nml;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
- dt = code->ext.dt;
+ var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
- gcc_assert (dt != NULL);
+ set_error_locus (&block, var, &code->loc);
+
+ if (last_dt == IOLENGTH)
+ {
+ gfc_inquire *inq;
+
+ inq = code->ext.inquire;
+
+ /* First check that preconditions are met. */
+ gcc_assert (inq != NULL);
+ gcc_assert (inq->iolength != NULL);
+
+ /* Connect to the iolength variable. */
+ mask |= set_parameter_ref (&block, var, IOPARM_dt_iolength,
+ inq->iolength);
+ dt = NULL;
+ }
+ else
+ {
+ dt = code->ext.dt;
+ gcc_assert (dt != NULL);
+ }
- if (dt->io_unit)
+ if (dt && dt->io_unit)
{
if (dt->io_unit->ts.type == BT_CHARACTER)
{
- set_internal_unit (&block,
- ioparm_internal_unit,
- ioparm_internal_unit_len,
- ioparm_internal_unit_desc,
- dt->io_unit);
+ mask |= set_internal_unit (&block, var, dt->io_unit);
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
}
else
- set_parameter_value (&block, ioparm_unit, dt->io_unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
}
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
- if (dt->rec)
- set_parameter_value (&block, ioparm_rec, dt->rec);
+ if (dt)
+ {
+ if (dt->rec)
+ mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
- if (dt->advance)
- set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
- dt->advance);
+ if (dt->advance)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
+ dt->advance);
- if (dt->format_expr)
- set_string (&block, &post_block, ioparm_format, ioparm_format_len,
- dt->format_expr);
+ if (dt->format_expr)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+ dt->format_expr);
- if (dt->format_label)
- {
- if (dt->format_label == &format_asterisk)
- set_flag (&block, ioparm_list_format);
- else
- set_string (&block, &post_block, ioparm_format,
- ioparm_format_len, dt->format_label->format);
- }
+ if (dt->format_label)
+ {
+ if (dt->format_label == &format_asterisk)
+ mask |= IOPARM_dt_list_format;
+ else
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+ dt->format_label->format);
+ }
- if (dt->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- dt->iomsg);
+ if (dt->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ dt->iomsg);
- if (dt->iostat)
- set_parameter_ref (&block, ioparm_iostat, dt->iostat);
+ if (dt->iostat)
+ mask |= set_parameter_ref (&block, var, IOPARM_common_iostat,
+ dt->iostat);
- if (dt->size)
- set_parameter_ref (&block, ioparm_size, dt->size);
+ if (dt->size)
+ mask |= set_parameter_ref (&block, var, IOPARM_dt_size, dt->size);
- if (dt->err)
- set_flag (&block, ioparm_err);
+ if (dt->err)
+ mask |= IOPARM_common_err;
- if (dt->eor)
- set_flag(&block, ioparm_eor);
+ if (dt->eor)
+ mask |= IOPARM_common_eor;
- if (dt->end)
- set_flag(&block, ioparm_end);
+ if (dt->end)
+ mask |= IOPARM_common_end;
- if (dt->namelist)
- {
- if (dt->format_expr || dt->format_label)
- gfc_internal_error ("build_dt: format with namelist");
+ if (dt->namelist)
+ {
+ if (dt->format_expr || dt->format_label)
+ gfc_internal_error ("build_dt: format with namelist");
+
+ nmlname = gfc_new_nml_name_expr (dt->namelist->name);
- nmlname = gfc_new_nml_name_expr(dt->namelist->name);
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
+ nmlname);
- set_string (&block, &post_block, ioparm_namelist_name,
- ioparm_namelist_name_len, nmlname);
+ if (last_dt == READ)
+ mask |= IOPARM_dt_namelist_read_mode;
- if (last_dt == READ)
- set_flag (&block, ioparm_namelist_read_mode);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- for (nml = dt->namelist->namelist; nml; nml = nml->next)
- transfer_namelist_element (&block, nml->sym->name, nml->sym,
- NULL, NULL);
+ dt_parm = var;
+
+ for (nml = dt->namelist->namelist; nml; nml = nml->next)
+ transfer_namelist_element (&block, nml->sym->name, nml->sym,
+ NULL, NULL);
+ }
+ else
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
}
+ else
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_function_call (*function, NULL_TREE);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
+ dt_parm = var;
+
+ gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
+
+ dt_parm = NULL;
+
return gfc_finish_block (&block);
}
@@ -1321,31 +1449,8 @@ build_dt (tree * function, gfc_code * co
tree
gfc_trans_iolength (gfc_code * code)
{
- stmtblock_t block;
- gfc_inquire *inq;
- tree dt;
-
- gfc_init_block (&block);
-
- set_error_locus (&block, &code->loc);
-
- inq = code->ext.inquire;
-
- /* First check that preconditions are met. */
- gcc_assert (inq != NULL);
- gcc_assert (inq->iolength != NULL);
-
- /* Connect to the iolength variable. */
- if (inq->iolength)
- set_parameter_ref (&block, ioparm_iolength, inq->iolength);
-
- /* Actual logic. */
last_dt = IOLENGTH;
- dt = build_dt(&iocall_iolength, code);
-
- gfc_add_expr_to_block (&block, dt);
-
- return gfc_finish_block (&block);
+ return build_dt (iocall[IOCALL_IOLENGTH], code);
}
@@ -1354,9 +1459,8 @@ gfc_trans_iolength (gfc_code * code)
tree
gfc_trans_read (gfc_code * code)
{
-
last_dt = READ;
- return build_dt (&iocall_read, code);
+ return build_dt (iocall[IOCALL_READ], code);
}
@@ -1365,9 +1469,8 @@ gfc_trans_read (gfc_code * code)
tree
gfc_trans_write (gfc_code * code)
{
-
last_dt = WRITE;
- return build_dt (&iocall_write, code);
+ return build_dt (iocall[IOCALL_WRITE], code);
}
@@ -1384,28 +1487,30 @@ gfc_trans_dt_end (gfc_code * code)
switch (last_dt)
{
case READ:
- function = iocall_read_done;
+ function = iocall[IOCALL_READ_DONE];
break;
case WRITE:
- function = iocall_write_done;
+ function = iocall[IOCALL_WRITE_DONE];
break;
case IOLENGTH:
- function = iocall_iolength_done;
+ function = iocall[IOCALL_IOLENGTH_DONE];
break;
default:
gcc_unreachable ();
}
- tmp = gfc_build_function_call (function, NULL);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
if (last_dt != IOLENGTH)
{
gcc_assert (code->ext.dt != NULL);
- io_result (&block, code->ext.dt->err,
+ io_result (&block, dt_parm, code->ext.dt->err,
code->ext.dt->end, code->ext.dt->eor);
}
@@ -1520,22 +1625,22 @@ transfer_expr (gfc_se * se, gfc_typespec
{
case BT_INTEGER:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_integer;
+ function = iocall[IOCALL_X_INTEGER];
break;
case BT_REAL:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_real;
+ function = iocall[IOCALL_X_REAL];
break;
case BT_COMPLEX:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_complex;
+ function = iocall[IOCALL_X_COMPLEX];
break;
case BT_LOGICAL:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_logical;
+ function = iocall[IOCALL_X_LOGICAL];
break;
case BT_CHARACTER:
@@ -1547,7 +1652,7 @@ transfer_expr (gfc_se * se, gfc_typespec
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
- function = iocall_x_character;
+ function = iocall[IOCALL_X_CHARACTER];
break;
case BT_DERIVED:
@@ -1581,7 +1686,9 @@ transfer_expr (gfc_se * se, gfc_typespec
internal_error ("Bad IO basetype (%d)", ts->type);
}
- args = gfc_chainon_list (NULL_TREE, addr_expr);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ args = gfc_chainon_list (args, addr_expr);
args = gfc_chainon_list (args, arg2);
tmp = gfc_build_function_call (function, args);
@@ -1604,9 +1711,11 @@ transfer_array_desc (gfc_se * se, gfc_ty
else
charlen_arg = build_int_cstu (NULL_TREE, 0);
- args = gfc_chainon_list (NULL_TREE, addr_expr);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ args = gfc_chainon_list (args, addr_expr);
args = gfc_chainon_list (args, charlen_arg);
- tmp = gfc_build_function_call (iocall_x_array, args);
+ tmp = gfc_build_function_call (iocall[IOCALL_X_ARRAY], args);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
}
Jakub
More information about the Fortran
mailing list