OSDN Git Service

2010-09-03 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-io.c
1 /* IO Code translation/library interface
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3    Free Software Foundation, Inc.
4    Contributed by Paul Brook
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22
23 #include "config.h"
24 #include "system.h"
25 #include "coretypes.h"
26 #include "tree.h"
27 #include "ggc.h"
28 #include "diagnostic-core.h"    /* For internal_error.  */
29 #include "gfortran.h"
30 #include "trans.h"
31 #include "trans-stmt.h"
32 #include "trans-array.h"
33 #include "trans-types.h"
34 #include "trans-const.h"
35
36 /* Members of the ioparm structure.  */
37
38 enum ioparam_type
39 {
40   IOPARM_ptype_common,
41   IOPARM_ptype_open,
42   IOPARM_ptype_close,
43   IOPARM_ptype_filepos,
44   IOPARM_ptype_inquire,
45   IOPARM_ptype_dt,
46   IOPARM_ptype_wait,
47   IOPARM_ptype_num
48 };
49
50 enum iofield_type
51 {
52   IOPARM_type_int4,
53   IOPARM_type_intio,
54   IOPARM_type_pint4,
55   IOPARM_type_pintio,
56   IOPARM_type_pchar,
57   IOPARM_type_parray,
58   IOPARM_type_pad,
59   IOPARM_type_char1,
60   IOPARM_type_char2,
61   IOPARM_type_common,
62   IOPARM_type_num
63 };
64
65 typedef struct GTY(()) gfc_st_parameter_field {
66   const char *name;
67   unsigned int mask;
68   enum ioparam_type param_type;
69   enum iofield_type type;
70   tree field;
71   tree field_len;
72 }
73 gfc_st_parameter_field;
74
75 typedef struct GTY(()) gfc_st_parameter {
76   const char *name;
77   tree type;
78 }
79 gfc_st_parameter;
80
81 enum iofield
82 {
83 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
84 #include "ioparm.def"
85 #undef IOPARM
86   IOPARM_field_num
87 };
88
89 static GTY(()) gfc_st_parameter st_parameter[] =
90 {
91   { "common", NULL },
92   { "open", NULL },
93   { "close", NULL },
94   { "filepos", NULL },
95   { "inquire", NULL },
96   { "dt", NULL },
97   { "wait", NULL }
98 };
99
100 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
101 {
102 #define IOPARM(param_type, name, mask, type) \
103   { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
104 #include "ioparm.def"
105 #undef IOPARM
106   { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
107 };
108
109 /* Library I/O subroutines */
110
111 enum iocall
112 {
113   IOCALL_READ,
114   IOCALL_READ_DONE,
115   IOCALL_WRITE,
116   IOCALL_WRITE_DONE,
117   IOCALL_X_INTEGER,
118   IOCALL_X_LOGICAL,
119   IOCALL_X_CHARACTER,
120   IOCALL_X_CHARACTER_WIDE,
121   IOCALL_X_REAL,
122   IOCALL_X_COMPLEX,
123   IOCALL_X_ARRAY,
124   IOCALL_OPEN,
125   IOCALL_CLOSE,
126   IOCALL_INQUIRE,
127   IOCALL_IOLENGTH,
128   IOCALL_IOLENGTH_DONE,
129   IOCALL_REWIND,
130   IOCALL_BACKSPACE,
131   IOCALL_ENDFILE,
132   IOCALL_FLUSH,
133   IOCALL_SET_NML_VAL,
134   IOCALL_SET_NML_VAL_DIM,
135   IOCALL_WAIT,
136   IOCALL_NUM
137 };
138
139 static GTY(()) tree iocall[IOCALL_NUM];
140
141 /* Variable for keeping track of what the last data transfer statement
142    was.  Used for deciding which subroutine to call when the data
143    transfer is complete.  */
144 static enum { READ, WRITE, IOLENGTH } last_dt;
145
146 /* The data transfer parameter block that should be shared by all
147    data transfer calls belonging to the same read/write/iolength.  */
148 static GTY(()) tree dt_parm;
149 static stmtblock_t *dt_post_end_block;
150
151 static void
152 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
153 {
154   unsigned int type;
155   gfc_st_parameter_field *p;
156   char name[64];
157   size_t len;
158   tree t = make_node (RECORD_TYPE);
159   tree *chain = NULL;
160
161   len = strlen (st_parameter[ptype].name);
162   gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
163   memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
164   memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
165           len + 1);
166   TYPE_NAME (t) = get_identifier (name);
167
168   for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
169     if (p->param_type == ptype)
170       switch (p->type)
171         {
172         case IOPARM_type_int4:
173         case IOPARM_type_intio:
174         case IOPARM_type_pint4:
175         case IOPARM_type_pintio:
176         case IOPARM_type_parray:
177         case IOPARM_type_pchar:
178         case IOPARM_type_pad:
179           p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
180                                               types[p->type], &chain);
181           break;
182         case IOPARM_type_char1:
183           p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
184                                               pchar_type_node, &chain);
185           /* FALLTHROUGH */
186         case IOPARM_type_char2:
187           len = strlen (p->name);
188           gcc_assert (len <= sizeof (name) - sizeof ("_len"));
189           memcpy (name, p->name, len);
190           memcpy (name + len, "_len", sizeof ("_len"));
191           p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
192                                                   gfc_charlen_type_node,
193                                                   &chain);
194           if (p->type == IOPARM_type_char2)
195             p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
196                                                 pchar_type_node, &chain);
197           break;
198         case IOPARM_type_common:
199           p->field
200             = gfc_add_field_to_struct (t,
201                                        get_identifier (p->name),
202                                        st_parameter[IOPARM_ptype_common].type,
203                                        &chain);
204           break;
205         case IOPARM_type_num:
206           gcc_unreachable ();
207         }
208
209   gfc_finish_type (t);
210   st_parameter[ptype].type = t;
211 }
212
213
214 /* Build code to test an error condition and call generate_error if needed.
215    Note: This builds calls to generate_error in the runtime library function.
216    The function generate_error is dependent on certain parameters in the
217    st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
218    Therefore, the code to set these flags must be generated before
219    this function is used.  */
220
221 void
222 gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
223                          const char * msgid, stmtblock_t * pblock)
224 {
225   stmtblock_t block;
226   tree body;
227   tree tmp;
228   tree arg1, arg2, arg3;
229   char *message;
230
231   if (integer_zerop (cond))
232     return;
233
234   /* The code to generate the error.  */
235   gfc_start_block (&block);
236   
237   arg1 = gfc_build_addr_expr (NULL_TREE, var);
238   
239   arg2 = build_int_cst (integer_type_node, error_code),
240   
241   asprintf (&message, "%s", _(msgid));
242   arg3 = gfc_build_addr_expr (pchar_type_node,
243                               gfc_build_localized_cstring_const (message));
244   gfc_free(message);
245   
246   tmp = build_call_expr_loc (input_location,
247                          gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
248
249   gfc_add_expr_to_block (&block, tmp);
250
251   body = gfc_finish_block (&block);
252
253   if (integer_onep (cond))
254     {
255       gfc_add_expr_to_block (pblock, body);
256     }
257   else
258     {
259       /* Tell the compiler that this isn't likely.  */
260       cond = fold_convert (long_integer_type_node, cond);
261       tmp = build_int_cst (long_integer_type_node, 0);
262       cond = build_call_expr_loc (input_location,
263                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
264       cond = fold_convert (boolean_type_node, cond);
265
266       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
267       gfc_add_expr_to_block (pblock, tmp);
268     }
269 }
270
271
272 /* Create function decls for IO library functions.  */
273
274 void
275 gfc_build_io_library_fndecls (void)
276 {
277   tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
278   tree gfc_intio_type_node;
279   tree parm_type, dt_parm_type;
280   HOST_WIDE_INT pad_size;
281   unsigned int ptype;
282
283   types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
284   types[IOPARM_type_intio] = gfc_intio_type_node
285                             = gfc_get_int_type (gfc_intio_kind);
286   types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
287   types[IOPARM_type_pintio]
288                             = build_pointer_type (gfc_intio_type_node);
289   types[IOPARM_type_parray] = pchar_type_node;
290   types[IOPARM_type_pchar] = pchar_type_node;
291   pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
292   pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
293   pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1));
294   types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
295
296   /* pad actually contains pointers and integers so it needs to have an
297      alignment that is at least as large as the needed alignment for those
298      types.  See the st_parameter_dt structure in libgfortran/io/io.h for
299      what really goes into this space.  */
300   TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
301                      TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
302
303   for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
304     gfc_build_st_parameter ((enum ioparam_type) ptype, types);
305
306   /* Define the transfer functions.
307      TODO: Split them between READ and WRITE to allow further
308      optimizations, e.g. by using aliases?  */
309
310   dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
311
312   iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
313         get_identifier (PREFIX("transfer_integer")), ".wW",
314         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
315
316   iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
317         get_identifier (PREFIX("transfer_logical")), ".wW",
318         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
319
320   iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
321         get_identifier (PREFIX("transfer_character")), ".wW",
322         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
323
324   iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
325         get_identifier (PREFIX("transfer_character_wide")), ".wW",
326         void_type_node, 4, dt_parm_type, pvoid_type_node,
327         gfc_charlen_type_node, gfc_int4_type_node);
328
329   iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
330         get_identifier (PREFIX("transfer_real")), ".wW",
331         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
332
333   iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
334         get_identifier (PREFIX("transfer_complex")), ".wW",
335         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
336
337   iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
338         get_identifier (PREFIX("transfer_array")), ".wW",
339         void_type_node, 4, dt_parm_type, pvoid_type_node,
340         integer_type_node, gfc_charlen_type_node);
341
342   /* Library entry points */
343
344   iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
345         get_identifier (PREFIX("st_read")), ".w",
346         void_type_node, 1, dt_parm_type);
347
348   iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
349         get_identifier (PREFIX("st_write")), ".w",
350         void_type_node, 1, dt_parm_type);
351
352   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
353   iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
354         get_identifier (PREFIX("st_open")), ".w",
355         void_type_node, 1, parm_type);
356
357   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
358   iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
359         get_identifier (PREFIX("st_close")), ".w",
360         void_type_node, 1, parm_type);
361
362   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
363   iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
364         get_identifier (PREFIX("st_inquire")), ".w",
365         void_type_node, 1, parm_type);
366
367   iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
368         get_identifier (PREFIX("st_iolength")), ".w",
369         void_type_node, 1, dt_parm_type);
370
371   /* TODO: Change when asynchronous I/O is implemented.  */
372   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
373   iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
374         get_identifier (PREFIX("st_wait")), ".X",
375         void_type_node, 1, parm_type);
376
377   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
378   iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
379         get_identifier (PREFIX("st_rewind")), ".w",
380         void_type_node, 1, parm_type);
381
382   iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
383         get_identifier (PREFIX("st_backspace")), ".w",
384         void_type_node, 1, parm_type);
385
386   iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
387         get_identifier (PREFIX("st_endfile")), ".w",
388         void_type_node, 1, parm_type);
389
390   iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
391         get_identifier (PREFIX("st_flush")), ".w",
392         void_type_node, 1, parm_type);
393
394   /* Library helpers */
395
396   iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
397         get_identifier (PREFIX("st_read_done")), ".w",
398         void_type_node, 1, dt_parm_type);
399
400   iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
401         get_identifier (PREFIX("st_write_done")), ".w",
402         void_type_node, 1, dt_parm_type);
403
404   iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
405         get_identifier (PREFIX("st_iolength_done")), ".w",
406         void_type_node, 1, dt_parm_type);
407
408   iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
409         get_identifier (PREFIX("st_set_nml_var")), ".w.R",
410         void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
411         void_type_node, gfc_charlen_type_node, gfc_int4_type_node);
412
413   iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
414         get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
415         void_type_node, 5, dt_parm_type, gfc_int4_type_node,
416         gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
417 }
418
419
420 /* Generate code to store an integer constant into the
421    st_parameter_XXX structure.  */
422
423 static unsigned int
424 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
425                      unsigned int val)
426 {
427   tree tmp;
428   gfc_st_parameter_field *p = &st_parameter_field[type];
429
430   if (p->param_type == IOPARM_ptype_common)
431     var = fold_build3_loc (input_location, COMPONENT_REF,
432                            st_parameter[IOPARM_ptype_common].type,
433                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
434   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
435                          var, p->field, NULL_TREE);
436   gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
437   return p->mask;
438 }
439
440
441 /* Generate code to store a non-string I/O parameter into the
442    st_parameter_XXX structure.  This is a pass by value.  */
443
444 static unsigned int
445 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
446                      gfc_expr *e)
447 {
448   gfc_se se;
449   tree tmp;
450   gfc_st_parameter_field *p = &st_parameter_field[type];
451   tree dest_type = TREE_TYPE (p->field);
452
453   gfc_init_se (&se, NULL);
454   gfc_conv_expr_val (&se, e);
455
456   /* If we're storing a UNIT number, we need to check it first.  */
457   if (type == IOPARM_common_unit && e->ts.kind > 4)
458     {
459       tree cond, val;
460       int i;
461
462       /* Don't evaluate the UNIT number multiple times.  */
463       se.expr = gfc_evaluate_now (se.expr, &se.pre);
464
465       /* UNIT numbers should be greater than the min.  */
466       i = gfc_validate_kind (BT_INTEGER, 4, false);
467       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
468       cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
469                               se.expr,
470                               fold_convert (TREE_TYPE (se.expr), val));
471       gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
472                                "Unit number in I/O statement too small",
473                                &se.pre);
474     
475       /* UNIT numbers should be less than the max.  */
476       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
477       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
478                               se.expr,
479                               fold_convert (TREE_TYPE (se.expr), val));
480       gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
481                                "Unit number in I/O statement too large",
482                                &se.pre);
483
484     }
485
486   se.expr = convert (dest_type, se.expr);
487   gfc_add_block_to_block (block, &se.pre);
488
489   if (p->param_type == IOPARM_ptype_common)
490     var = fold_build3_loc (input_location, COMPONENT_REF,
491                            st_parameter[IOPARM_ptype_common].type,
492                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
493
494   tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
495                          p->field, NULL_TREE);
496   gfc_add_modify (block, tmp, se.expr);
497   return p->mask;
498 }
499
500
501 /* Generate code to store a non-string I/O parameter into the
502    st_parameter_XXX structure.  This is pass by reference.  */
503
504 static unsigned int
505 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
506                    tree var, enum iofield type, gfc_expr *e)
507 {
508   gfc_se se;
509   tree tmp, addr;
510   gfc_st_parameter_field *p = &st_parameter_field[type];
511
512   gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
513   gfc_init_se (&se, NULL);
514   gfc_conv_expr_lhs (&se, e);
515
516   gfc_add_block_to_block (block, &se.pre);
517
518   if (TYPE_MODE (TREE_TYPE (se.expr))
519       == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
520     {
521       addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
522
523       /* If this is for the iostat variable initialize the
524          user variable to LIBERROR_OK which is zero.  */
525       if (type == IOPARM_common_iostat)
526         gfc_add_modify (block, se.expr,
527                              build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
528     }
529   else
530     {
531       /* The type used by the library has different size
532         from the type of the variable supplied by the user.
533         Need to use a temporary.  */
534       tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
535                                     st_parameter_field[type].name);
536
537       /* If this is for the iostat variable, initialize the
538          user variable to LIBERROR_OK which is zero.  */
539       if (type == IOPARM_common_iostat)
540         gfc_add_modify (block, tmpvar,
541                              build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
542
543       addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
544         /* After the I/O operation, we set the variable from the temporary.  */
545       tmp = convert (TREE_TYPE (se.expr), tmpvar);
546       gfc_add_modify (postblock, se.expr, tmp);
547      }
548
549   if (p->param_type == IOPARM_ptype_common)
550     var = fold_build3_loc (input_location, COMPONENT_REF,
551                            st_parameter[IOPARM_ptype_common].type,
552                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
553   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
554                          var, p->field, NULL_TREE);
555   gfc_add_modify (block, tmp, addr);
556   return p->mask;
557 }
558
559 /* Given an array expr, find its address and length to get a string. If the
560    array is full, the string's address is the address of array's first element
561    and the length is the size of the whole array.  If it is an element, the
562    string's address is the element's address and the length is the rest size of
563    the array.  */
564
565 static void
566 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
567 {
568   tree size;
569
570   if (e->rank == 0)
571     {
572       tree type, array, tmp;
573       gfc_symbol *sym;
574       int rank;
575
576       /* If it is an element, we need its address and size of the rest.  */
577       gcc_assert (e->expr_type == EXPR_VARIABLE);
578       gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
579       sym = e->symtree->n.sym;
580       rank = sym->as->rank - 1;
581       gfc_conv_expr (se, e);
582
583       array = sym->backend_decl;
584       type = TREE_TYPE (array);
585
586       if (GFC_ARRAY_TYPE_P (type))
587         size = GFC_TYPE_ARRAY_SIZE (type);
588       else
589         {
590           gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
591           size = gfc_conv_array_stride (array, rank);
592           tmp = fold_build2_loc (input_location, MINUS_EXPR,
593                                  gfc_array_index_type,
594                                  gfc_conv_array_ubound (array, rank),
595                                  gfc_conv_array_lbound (array, rank));
596           tmp = fold_build2_loc (input_location, PLUS_EXPR,
597                                  gfc_array_index_type, tmp,
598                                  gfc_index_one_node);
599           size = fold_build2_loc (input_location, MULT_EXPR,
600                                   gfc_array_index_type, tmp, size);
601         }
602       gcc_assert (size);
603
604       size = fold_build2_loc (input_location, MINUS_EXPR,
605                               gfc_array_index_type, size,
606                               TREE_OPERAND (se->expr, 1));
607       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
608       tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
609       size = fold_build2_loc (input_location, MULT_EXPR,
610                               gfc_array_index_type, size,
611                               fold_convert (gfc_array_index_type, tmp));
612       se->string_length = fold_convert (gfc_charlen_type_node, size);
613       return;
614     }
615
616   gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
617   se->string_length = fold_convert (gfc_charlen_type_node, size);
618 }
619
620
621 /* Generate code to store a string and its length into the
622    st_parameter_XXX structure.  */
623
624 static unsigned int
625 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
626             enum iofield type, gfc_expr * e)
627 {
628   gfc_se se;
629   tree tmp;
630   tree io;
631   tree len;
632   gfc_st_parameter_field *p = &st_parameter_field[type];
633
634   gfc_init_se (&se, NULL);
635
636   if (p->param_type == IOPARM_ptype_common)
637     var = fold_build3_loc (input_location, COMPONENT_REF,
638                            st_parameter[IOPARM_ptype_common].type,
639                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
640   io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
641                     var, p->field, NULL_TREE);
642   len = fold_build3_loc (input_location, COMPONENT_REF,
643                          TREE_TYPE (p->field_len),
644                          var, p->field_len, NULL_TREE);
645
646   /* Integer variable assigned a format label.  */
647   if (e->ts.type == BT_INTEGER
648       && e->rank == 0
649       && e->symtree->n.sym->attr.assign == 1)
650     {
651       char * msg;
652       tree cond;
653
654       gfc_conv_label_variable (&se, e);
655       tmp = GFC_DECL_STRING_LEN (se.expr);
656       cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
657                               tmp, build_int_cst (TREE_TYPE (tmp), 0));
658
659       asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
660                "label", e->symtree->name);
661       gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
662                                fold_convert (long_integer_type_node, tmp));
663       gfc_free (msg);
664
665       gfc_add_modify (&se.pre, io,
666                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
667       gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
668     }
669   else
670     {
671       /* General character.  */
672       if (e->ts.type == BT_CHARACTER && e->rank == 0)
673         gfc_conv_expr (&se, e);
674       /* Array assigned Hollerith constant or character array.  */
675       else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
676         gfc_convert_array_to_string (&se, e);
677       else
678         gcc_unreachable ();
679
680       gfc_conv_string_parameter (&se);
681       gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
682       gfc_add_modify (&se.pre, len, se.string_length);
683     }
684
685   gfc_add_block_to_block (block, &se.pre);
686   gfc_add_block_to_block (postblock, &se.post);
687   return p->mask;
688 }
689
690
691 /* Generate code to store the character (array) and the character length
692    for an internal unit.  */
693
694 static unsigned int
695 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
696                    tree var, gfc_expr * e)
697 {
698   gfc_se se;
699   tree io;
700   tree len;
701   tree desc;
702   tree tmp;
703   gfc_st_parameter_field *p;
704   unsigned int mask;
705
706   gfc_init_se (&se, NULL);
707
708   p = &st_parameter_field[IOPARM_dt_internal_unit];
709   mask = p->mask;
710   io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
711                         var, p->field, NULL_TREE);
712   len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
713                          var, p->field_len,     NULL_TREE);
714   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
715   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
716                           var, p->field, NULL_TREE);
717
718   gcc_assert (e->ts.type == BT_CHARACTER);
719
720   /* Character scalars.  */
721   if (e->rank == 0)
722     {
723       gfc_conv_expr (&se, e);
724       gfc_conv_string_parameter (&se);
725       tmp = se.expr;
726       se.expr = build_int_cst (pchar_type_node, 0);
727     }
728
729   /* Character array.  */
730   else if (e->rank > 0)
731     {
732       se.ss = gfc_walk_expr (e);
733
734       if (is_subref_array (e))
735         {
736           /* Use a temporary for components of arrays of derived types
737              or substring array references.  */
738           gfc_conv_subref_array_arg (&se, e, 0,
739                 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
740           tmp = build_fold_indirect_ref_loc (input_location,
741                                          se.expr);
742           se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
743           tmp = gfc_conv_descriptor_data_get (tmp);
744         }
745       else
746         {
747           /* Return the data pointer and rank from the descriptor.  */
748           gfc_conv_expr_descriptor (&se, e, se.ss);
749           tmp = gfc_conv_descriptor_data_get (se.expr);
750           se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
751         }
752     }
753   else
754     gcc_unreachable ();
755
756   /* The cast is needed for character substrings and the descriptor
757      data.  */
758   gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
759   gfc_add_modify (&se.pre, len,
760                        fold_convert (TREE_TYPE (len), se.string_length));
761   gfc_add_modify (&se.pre, desc, se.expr);
762
763   gfc_add_block_to_block (block, &se.pre);
764   gfc_add_block_to_block (post_block, &se.post);
765   return mask;
766 }
767
768 /* Add a case to a IO-result switch.  */
769
770 static void
771 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
772 {
773   tree tmp, value;
774
775   if (label == NULL)
776     return;                     /* No label, no case */
777
778   value = build_int_cst (NULL_TREE, label_value);
779
780   /* Make a backend label for this case.  */
781   tmp = gfc_build_label_decl (NULL_TREE);
782
783   /* And the case itself.  */
784   tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
785   gfc_add_expr_to_block (body, tmp);
786
787   /* Jump to the label.  */
788   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
789   gfc_add_expr_to_block (body, tmp);
790 }
791
792
793 /* Generate a switch statement that branches to the correct I/O
794    result label.  The last statement of an I/O call stores the
795    result into a variable because there is often cleanup that
796    must be done before the switch, so a temporary would have to
797    be created anyway.  */
798
799 static void
800 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
801            gfc_st_label * end_label, gfc_st_label * eor_label)
802 {
803   stmtblock_t body;
804   tree tmp, rc;
805   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
806
807   /* If no labels are specified, ignore the result instead
808      of building an empty switch.  */
809   if (err_label == NULL
810       && end_label == NULL
811       && eor_label == NULL)
812     return;
813
814   /* Build a switch statement.  */
815   gfc_start_block (&body);
816
817   /* The label values here must be the same as the values
818      in the library_return enum in the runtime library */
819   add_case (1, err_label, &body);
820   add_case (2, end_label, &body);
821   add_case (3, eor_label, &body);
822
823   tmp = gfc_finish_block (&body);
824
825   var = fold_build3_loc (input_location, COMPONENT_REF,
826                          st_parameter[IOPARM_ptype_common].type,
827                          var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
828   rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
829                         var, p->field, NULL_TREE);
830   rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
831                         rc, build_int_cst (TREE_TYPE (rc),
832                                            IOPARM_common_libreturn_mask));
833
834   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
835
836   gfc_add_expr_to_block (block, tmp);
837 }
838
839
840 /* Store the current file and line number to variables so that if a
841    library call goes awry, we can tell the user where the problem is.  */
842
843 static void
844 set_error_locus (stmtblock_t * block, tree var, locus * where)
845 {
846   gfc_file *f;
847   tree str, locus_file;
848   int line;
849   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
850
851   locus_file = fold_build3_loc (input_location, COMPONENT_REF,
852                                 st_parameter[IOPARM_ptype_common].type,
853                                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
854   locus_file = fold_build3_loc (input_location, COMPONENT_REF,
855                                 TREE_TYPE (p->field), locus_file,
856                                 p->field, NULL_TREE);
857   f = where->lb->file;
858   str = gfc_build_cstring_const (f->filename);
859
860   str = gfc_build_addr_expr (pchar_type_node, str);
861   gfc_add_modify (block, locus_file, str);
862
863   line = LOCATION_LINE (where->lb->location);
864   set_parameter_const (block, var, IOPARM_common_line, line);
865 }
866
867
868 /* Translate an OPEN statement.  */
869
870 tree
871 gfc_trans_open (gfc_code * code)
872 {
873   stmtblock_t block, post_block;
874   gfc_open *p;
875   tree tmp, var;
876   unsigned int mask = 0;
877
878   gfc_start_block (&block);
879   gfc_init_block (&post_block);
880
881   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
882
883   set_error_locus (&block, var, &code->loc);
884   p = code->ext.open;
885
886   if (p->iomsg)
887     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
888                         p->iomsg);
889
890   if (p->iostat)
891     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
892                                p->iostat);
893
894   if (p->err)
895     mask |= IOPARM_common_err;
896
897   if (p->file)
898     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
899
900   if (p->status)
901     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
902                         p->status);
903
904   if (p->access)
905     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
906                         p->access);
907
908   if (p->form)
909     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
910
911   if (p->recl)
912     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
913
914   if (p->blank)
915     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
916                         p->blank);
917
918   if (p->position)
919     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
920                         p->position);
921
922   if (p->action)
923     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
924                         p->action);
925
926   if (p->delim)
927     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
928                         p->delim);
929
930   if (p->pad)
931     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
932
933   if (p->decimal)
934     mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
935                         p->decimal);
936
937   if (p->encoding)
938     mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
939                         p->encoding);
940
941   if (p->round)
942     mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
943
944   if (p->sign)
945     mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
946
947   if (p->asynchronous)
948     mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
949                         p->asynchronous);
950
951   if (p->convert)
952     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
953                         p->convert);
954                         
955   if (p->newunit)
956     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
957                                p->newunit);
958
959   set_parameter_const (&block, var, IOPARM_common_flags, mask);
960
961   if (p->unit)
962     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
963   else
964     set_parameter_const (&block, var, IOPARM_common_unit, 0);
965
966   tmp = gfc_build_addr_expr (NULL_TREE, var);
967   tmp = build_call_expr_loc (input_location,
968                          iocall[IOCALL_OPEN], 1, tmp);
969   gfc_add_expr_to_block (&block, tmp);
970
971   gfc_add_block_to_block (&block, &post_block);
972
973   io_result (&block, var, p->err, NULL, NULL);
974
975   return gfc_finish_block (&block);
976 }
977
978
979 /* Translate a CLOSE statement.  */
980
981 tree
982 gfc_trans_close (gfc_code * code)
983 {
984   stmtblock_t block, post_block;
985   gfc_close *p;
986   tree tmp, var;
987   unsigned int mask = 0;
988
989   gfc_start_block (&block);
990   gfc_init_block (&post_block);
991
992   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
993
994   set_error_locus (&block, var, &code->loc);
995   p = code->ext.close;
996
997   if (p->iomsg)
998     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
999                         p->iomsg);
1000
1001   if (p->iostat)
1002     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1003                                p->iostat);
1004
1005   if (p->err)
1006     mask |= IOPARM_common_err;
1007
1008   if (p->status)
1009     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1010                         p->status);
1011
1012   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1013
1014   if (p->unit)
1015     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1016   else
1017     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1018
1019   tmp = gfc_build_addr_expr (NULL_TREE, var);
1020   tmp = build_call_expr_loc (input_location,
1021                          iocall[IOCALL_CLOSE], 1, tmp);
1022   gfc_add_expr_to_block (&block, tmp);
1023
1024   gfc_add_block_to_block (&block, &post_block);
1025
1026   io_result (&block, var, p->err, NULL, NULL);
1027
1028   return gfc_finish_block (&block);
1029 }
1030
1031
1032 /* Common subroutine for building a file positioning statement.  */
1033
1034 static tree
1035 build_filepos (tree function, gfc_code * code)
1036 {
1037   stmtblock_t block, post_block;
1038   gfc_filepos *p;
1039   tree tmp, var;
1040   unsigned int mask = 0;
1041
1042   p = code->ext.filepos;
1043
1044   gfc_start_block (&block);
1045   gfc_init_block (&post_block);
1046
1047   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1048                         "filepos_parm");
1049
1050   set_error_locus (&block, var, &code->loc);
1051
1052   if (p->iomsg)
1053     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1054                         p->iomsg);
1055
1056   if (p->iostat)
1057     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1058                                p->iostat);
1059
1060   if (p->err)
1061     mask |= IOPARM_common_err;
1062
1063   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1064
1065   if (p->unit)
1066     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1067   else
1068     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1069
1070   tmp = gfc_build_addr_expr (NULL_TREE, var);
1071   tmp = build_call_expr_loc (input_location,
1072                          function, 1, tmp);
1073   gfc_add_expr_to_block (&block, tmp);
1074
1075   gfc_add_block_to_block (&block, &post_block);
1076
1077   io_result (&block, var, p->err, NULL, NULL);
1078
1079   return gfc_finish_block (&block);
1080 }
1081
1082
1083 /* Translate a BACKSPACE statement.  */
1084
1085 tree
1086 gfc_trans_backspace (gfc_code * code)
1087 {
1088   return build_filepos (iocall[IOCALL_BACKSPACE], code);
1089 }
1090
1091
1092 /* Translate an ENDFILE statement.  */
1093
1094 tree
1095 gfc_trans_endfile (gfc_code * code)
1096 {
1097   return build_filepos (iocall[IOCALL_ENDFILE], code);
1098 }
1099
1100
1101 /* Translate a REWIND statement.  */
1102
1103 tree
1104 gfc_trans_rewind (gfc_code * code)
1105 {
1106   return build_filepos (iocall[IOCALL_REWIND], code);
1107 }
1108
1109
1110 /* Translate a FLUSH statement.  */
1111
1112 tree
1113 gfc_trans_flush (gfc_code * code)
1114 {
1115   return build_filepos (iocall[IOCALL_FLUSH], code);
1116 }
1117
1118
1119 /* Create a dummy iostat variable to catch any error due to bad unit.  */
1120
1121 static gfc_expr *
1122 create_dummy_iostat (void)
1123 {
1124   gfc_symtree *st;
1125   gfc_expr *e;
1126
1127   gfc_get_ha_sym_tree ("@iostat", &st);
1128   st->n.sym->ts.type = BT_INTEGER;
1129   st->n.sym->ts.kind = gfc_default_integer_kind;
1130   gfc_set_sym_referenced (st->n.sym);
1131   gfc_commit_symbol (st->n.sym);
1132   st->n.sym->backend_decl
1133         = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1134                           st->n.sym->name);
1135
1136   e = gfc_get_expr ();
1137   e->expr_type = EXPR_VARIABLE;
1138   e->symtree = st;
1139   e->ts.type = BT_INTEGER;
1140   e->ts.kind = st->n.sym->ts.kind;
1141
1142   return e;
1143 }
1144
1145
1146 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
1147
1148 tree
1149 gfc_trans_inquire (gfc_code * code)
1150 {
1151   stmtblock_t block, post_block;
1152   gfc_inquire *p;
1153   tree tmp, var;
1154   unsigned int mask = 0, mask2 = 0;
1155
1156   gfc_start_block (&block);
1157   gfc_init_block (&post_block);
1158
1159   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1160                         "inquire_parm");
1161
1162   set_error_locus (&block, var, &code->loc);
1163   p = code->ext.inquire;
1164
1165   if (p->iomsg)
1166     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1167                         p->iomsg);
1168
1169   if (p->iostat)
1170     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1171                                p->iostat);
1172
1173   if (p->err)
1174     mask |= IOPARM_common_err;
1175
1176   /* Sanity check.  */
1177   if (p->unit && p->file)
1178     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1179
1180   if (p->file)
1181     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1182                         p->file);
1183
1184   if (p->exist)
1185     {
1186       mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1187                                  p->exist);
1188     
1189       if (p->unit && !p->iostat)
1190         {
1191           p->iostat = create_dummy_iostat ();
1192           mask |= set_parameter_ref (&block, &post_block, var,
1193                                      IOPARM_common_iostat, p->iostat);
1194         }
1195     }
1196
1197   if (p->opened)
1198     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1199                                p->opened);
1200
1201   if (p->number)
1202     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1203                                p->number);
1204
1205   if (p->named)
1206     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1207                                p->named);
1208
1209   if (p->name)
1210     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1211                         p->name);
1212
1213   if (p->access)
1214     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1215                         p->access);
1216
1217   if (p->sequential)
1218     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1219                         p->sequential);
1220
1221   if (p->direct)
1222     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1223                         p->direct);
1224
1225   if (p->form)
1226     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1227                         p->form);
1228
1229   if (p->formatted)
1230     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1231                         p->formatted);
1232
1233   if (p->unformatted)
1234     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1235                         p->unformatted);
1236
1237   if (p->recl)
1238     mask |= set_parameter_ref (&block, &post_block, var,
1239                                IOPARM_inquire_recl_out, p->recl);
1240
1241   if (p->nextrec)
1242     mask |= set_parameter_ref (&block, &post_block, var,
1243                                IOPARM_inquire_nextrec, p->nextrec);
1244
1245   if (p->blank)
1246     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1247                         p->blank);
1248
1249   if (p->delim)
1250     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1251                         p->delim);
1252
1253   if (p->position)
1254     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1255                         p->position);
1256
1257   if (p->action)
1258     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1259                         p->action);
1260
1261   if (p->read)
1262     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1263                         p->read);
1264
1265   if (p->write)
1266     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1267                         p->write);
1268
1269   if (p->readwrite)
1270     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1271                         p->readwrite);
1272
1273   if (p->pad)
1274     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1275                         p->pad);
1276   
1277   if (p->convert)
1278     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1279                         p->convert);
1280
1281   if (p->strm_pos)
1282     mask |= set_parameter_ref (&block, &post_block, var,
1283                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1284
1285   /* The second series of flags.  */
1286   if (p->asynchronous)
1287     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1288                          p->asynchronous);
1289
1290   if (p->decimal)
1291     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1292                          p->decimal);
1293
1294   if (p->encoding)
1295     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1296                          p->encoding);
1297
1298   if (p->round)
1299     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1300                          p->round);
1301
1302   if (p->sign)
1303     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1304                          p->sign);
1305
1306   if (p->pending)
1307     mask2 |= set_parameter_ref (&block, &post_block, var,
1308                                 IOPARM_inquire_pending, p->pending);
1309
1310   if (p->size)
1311     mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1312                                 p->size);
1313
1314   if (p->id)
1315     mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1316                                 p->id);
1317
1318   if (mask2)
1319     mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1320
1321   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1322
1323   if (p->unit)
1324     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1325   else
1326     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1327
1328   tmp = gfc_build_addr_expr (NULL_TREE, var);
1329   tmp = build_call_expr_loc (input_location,
1330                          iocall[IOCALL_INQUIRE], 1, tmp);
1331   gfc_add_expr_to_block (&block, tmp);
1332
1333   gfc_add_block_to_block (&block, &post_block);
1334
1335   io_result (&block, var, p->err, NULL, NULL);
1336
1337   return gfc_finish_block (&block);
1338 }
1339
1340
1341 tree
1342 gfc_trans_wait (gfc_code * code)
1343 {
1344   stmtblock_t block, post_block;
1345   gfc_wait *p;
1346   tree tmp, var;
1347   unsigned int mask = 0;
1348
1349   gfc_start_block (&block);
1350   gfc_init_block (&post_block);
1351
1352   var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1353                         "wait_parm");
1354
1355   set_error_locus (&block, var, &code->loc);
1356   p = code->ext.wait;
1357
1358   /* Set parameters here.  */
1359   if (p->iomsg)
1360     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1361                         p->iomsg);
1362
1363   if (p->iostat)
1364     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1365                                p->iostat);
1366
1367   if (p->err)
1368     mask |= IOPARM_common_err;
1369
1370   if (p->id)
1371     mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1372
1373   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1374
1375   if (p->unit)
1376     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1377
1378   tmp = gfc_build_addr_expr (NULL_TREE, var);
1379   tmp = build_call_expr_loc (input_location,
1380                          iocall[IOCALL_WAIT], 1, tmp);
1381   gfc_add_expr_to_block (&block, tmp);
1382
1383   gfc_add_block_to_block (&block, &post_block);
1384
1385   io_result (&block, var, p->err, NULL, NULL);
1386
1387   return gfc_finish_block (&block);
1388
1389 }
1390
1391
1392 /* nml_full_name builds up the fully qualified name of a
1393    derived type component.  */
1394
1395 static char*
1396 nml_full_name (const char* var_name, const char* cmp_name)
1397 {
1398   int full_name_length;
1399   char * full_name;
1400
1401   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1402   full_name = (char*)gfc_getmem (full_name_length + 1);
1403   strcpy (full_name, var_name);
1404   full_name = strcat (full_name, "%");
1405   full_name = strcat (full_name, cmp_name);
1406   return full_name;
1407 }
1408
1409 /* nml_get_addr_expr builds an address expression from the
1410    gfc_symbol or gfc_component backend_decl's. An offset is
1411    provided so that the address of an element of an array of
1412    derived types is returned. This is used in the runtime to
1413    determine that span of the derived type.  */
1414
1415 static tree
1416 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1417                    tree base_addr)
1418 {
1419   tree decl = NULL_TREE;
1420   tree tmp;
1421   tree itmp;
1422   int array_flagged;
1423   int dummy_arg_flagged;
1424
1425   if (sym)
1426     {
1427       sym->attr.referenced = 1;
1428       decl = gfc_get_symbol_decl (sym);
1429
1430       /* If this is the enclosing function declaration, use
1431          the fake result instead.  */
1432       if (decl == current_function_decl)
1433         decl = gfc_get_fake_result_decl (sym, 0);
1434       else if (decl == DECL_CONTEXT (current_function_decl))
1435         decl =  gfc_get_fake_result_decl (sym, 1);
1436     }
1437   else
1438     decl = c->backend_decl;
1439
1440   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1441                      || TREE_CODE (decl) == VAR_DECL
1442                      || TREE_CODE (decl) == PARM_DECL)
1443                      || TREE_CODE (decl) == COMPONENT_REF));
1444
1445   tmp = decl;
1446
1447   /* Build indirect reference, if dummy argument.  */
1448
1449   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1450
1451   itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
1452                                                         tmp) : tmp;
1453
1454   /* If an array, set flag and use indirect ref. if built.  */
1455
1456   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1457                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1458
1459   if (array_flagged)
1460     tmp = itmp;
1461
1462   /* Treat the component of a derived type, using base_addr for
1463      the derived type.  */
1464
1465   if (TREE_CODE (decl) == FIELD_DECL)
1466     tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1467                            base_addr, tmp, NULL_TREE);
1468
1469   /* If we have a derived type component, a reference to the first
1470      element of the array is built.  This is done so that base_addr,
1471      used in the build of the component reference, always points to
1472      a RECORD_TYPE.  */
1473
1474   if (array_flagged)
1475     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1476
1477   /* Now build the address expression.  */
1478
1479   tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1480
1481   /* If scalar dummy, resolve indirect reference now.  */
1482
1483   if (dummy_arg_flagged && !array_flagged)
1484     tmp = build_fold_indirect_ref_loc (input_location,
1485                                    tmp);
1486
1487   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1488
1489   return tmp;
1490 }
1491
1492 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1493    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1494    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1495
1496 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1497
1498 static void
1499 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1500                            gfc_symbol * sym, gfc_component * c,
1501                            tree base_addr)
1502 {
1503   gfc_typespec * ts = NULL;
1504   gfc_array_spec * as = NULL;
1505   tree addr_expr = NULL;
1506   tree dt = NULL;
1507   tree string;
1508   tree tmp;
1509   tree dtype;
1510   tree dt_parm_addr;
1511   int n_dim; 
1512   int itype;
1513   int rank = 0;
1514
1515   gcc_assert (sym || c);
1516
1517   /* Build the namelist object name.  */
1518
1519   string = gfc_build_cstring_const (var_name);
1520   string = gfc_build_addr_expr (pchar_type_node, string);
1521
1522   /* Build ts, as and data address using symbol or component.  */
1523
1524   ts = (sym) ? &sym->ts : &c->ts;
1525   as = (sym) ? sym->as : c->as;
1526
1527   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1528
1529   if (as)
1530     rank = as->rank;
1531
1532   if (rank)
1533     {
1534       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1535       dtype = gfc_get_dtype (dt);
1536     }
1537   else
1538     {
1539       itype = GFC_DTYPE_UNKNOWN;
1540
1541       switch (ts->type)
1542
1543         {
1544         case BT_INTEGER:
1545           itype = GFC_DTYPE_INTEGER;
1546           break;
1547         case BT_LOGICAL:
1548           itype = GFC_DTYPE_LOGICAL;
1549           break;
1550         case BT_REAL:
1551           itype = GFC_DTYPE_REAL;
1552           break;
1553         case BT_COMPLEX:
1554           itype = GFC_DTYPE_COMPLEX;
1555         break;
1556         case BT_DERIVED:
1557           itype = GFC_DTYPE_DERIVED;
1558           break;
1559         case BT_CHARACTER:
1560           itype = GFC_DTYPE_CHARACTER;
1561           break;
1562         default:
1563           gcc_unreachable ();
1564         }
1565
1566       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1567     }
1568
1569   /* Build up the arguments for the transfer call.
1570      The call for the scalar part transfers:
1571      (address, name, type, kind or string_length, dtype)  */
1572
1573   dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1574
1575   if (ts->type == BT_CHARACTER)
1576     tmp = ts->u.cl->backend_decl;
1577   else
1578     tmp = build_int_cst (gfc_charlen_type_node, 0);
1579   tmp = build_call_expr_loc (input_location,
1580                          iocall[IOCALL_SET_NML_VAL], 6,
1581                          dt_parm_addr, addr_expr, string,
1582                          IARG (ts->kind), tmp, dtype);
1583   gfc_add_expr_to_block (block, tmp);
1584
1585   /* If the object is an array, transfer rank times:
1586      (null pointer, name, stride, lbound, ubound)  */
1587
1588   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1589     {
1590       tmp = build_call_expr_loc (input_location,
1591                              iocall[IOCALL_SET_NML_VAL_DIM], 5,
1592                              dt_parm_addr,
1593                              IARG (n_dim),
1594                              GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1595                              GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1596                              GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1597       gfc_add_expr_to_block (block, tmp);
1598     }
1599
1600   if (ts->type == BT_DERIVED)
1601     {
1602       gfc_component *cmp;
1603
1604       /* Provide the RECORD_TYPE to build component references.  */
1605
1606       tree expr = build_fold_indirect_ref_loc (input_location,
1607                                            addr_expr);
1608
1609       for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1610         {
1611           char *full_name = nml_full_name (var_name, cmp->name);
1612           transfer_namelist_element (block,
1613                                      full_name,
1614                                      NULL, cmp, expr);
1615           gfc_free (full_name);
1616         }
1617     }
1618 }
1619
1620 #undef IARG
1621
1622 /* Create a data transfer statement.  Not all of the fields are valid
1623    for both reading and writing, but improper use has been filtered
1624    out by now.  */
1625
1626 static tree
1627 build_dt (tree function, gfc_code * code)
1628 {
1629   stmtblock_t block, post_block, post_end_block, post_iu_block;
1630   gfc_dt *dt;
1631   tree tmp, var;
1632   gfc_expr *nmlname;
1633   gfc_namelist *nml;
1634   unsigned int mask = 0;
1635
1636   gfc_start_block (&block);
1637   gfc_init_block (&post_block);
1638   gfc_init_block (&post_end_block);
1639   gfc_init_block (&post_iu_block);
1640
1641   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1642
1643   set_error_locus (&block, var, &code->loc);
1644
1645   if (last_dt == IOLENGTH)
1646     {
1647       gfc_inquire *inq;
1648
1649       inq = code->ext.inquire;
1650
1651       /* First check that preconditions are met.  */
1652       gcc_assert (inq != NULL);
1653       gcc_assert (inq->iolength != NULL);
1654
1655       /* Connect to the iolength variable.  */
1656       mask |= set_parameter_ref (&block, &post_end_block, var,
1657                                  IOPARM_dt_iolength, inq->iolength);
1658       dt = NULL;
1659     }
1660   else
1661     {
1662       dt = code->ext.dt;
1663       gcc_assert (dt != NULL);
1664     }
1665
1666   if (dt && dt->io_unit)
1667     {
1668       if (dt->io_unit->ts.type == BT_CHARACTER)
1669         {
1670           mask |= set_internal_unit (&block, &post_iu_block,
1671                                      var, dt->io_unit);
1672           set_parameter_const (&block, var, IOPARM_common_unit,
1673                                dt->io_unit->ts.kind == 1 ? 0 : -1);
1674         }
1675     }
1676   else
1677     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1678
1679   if (dt)
1680     {
1681       if (dt->iomsg)
1682         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1683                             dt->iomsg);
1684
1685       if (dt->iostat)
1686         mask |= set_parameter_ref (&block, &post_end_block, var,
1687                                    IOPARM_common_iostat, dt->iostat);
1688
1689       if (dt->err)
1690         mask |= IOPARM_common_err;
1691
1692       if (dt->eor)
1693         mask |= IOPARM_common_eor;
1694
1695       if (dt->end)
1696         mask |= IOPARM_common_end;
1697
1698       if (dt->id)
1699         mask |= set_parameter_ref (&block, &post_end_block, var,
1700                                    IOPARM_dt_id, dt->id);
1701
1702       if (dt->pos)
1703         mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1704
1705       if (dt->asynchronous)
1706         mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1707                             dt->asynchronous);
1708
1709       if (dt->blank)
1710         mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1711                             dt->blank);
1712
1713       if (dt->decimal)
1714         mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1715                             dt->decimal);
1716
1717       if (dt->delim)
1718         mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1719                             dt->delim);
1720
1721       if (dt->pad)
1722         mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1723                             dt->pad);
1724
1725       if (dt->round)
1726         mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1727                             dt->round);
1728
1729       if (dt->sign)
1730         mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1731                             dt->sign);
1732
1733       if (dt->rec)
1734         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1735
1736       if (dt->advance)
1737         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1738                             dt->advance);
1739
1740       if (dt->format_expr)
1741         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1742                             dt->format_expr);
1743
1744       if (dt->format_label)
1745         {
1746           if (dt->format_label == &format_asterisk)
1747             mask |= IOPARM_dt_list_format;
1748           else
1749             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1750                                 dt->format_label->format);
1751         }
1752
1753       if (dt->size)
1754         mask |= set_parameter_ref (&block, &post_end_block, var,
1755                                    IOPARM_dt_size, dt->size);
1756
1757       if (dt->namelist)
1758         {
1759           if (dt->format_expr || dt->format_label)
1760             gfc_internal_error ("build_dt: format with namelist");
1761
1762           nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1763                                             dt->namelist->name,
1764                                             strlen (dt->namelist->name));
1765
1766           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1767                               nmlname);
1768
1769           if (last_dt == READ)
1770             mask |= IOPARM_dt_namelist_read_mode;
1771
1772           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1773
1774           dt_parm = var;
1775
1776           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1777             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1778                                        NULL, NULL_TREE);
1779         }
1780       else
1781         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1782
1783       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1784         set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1785     }
1786   else
1787     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1788
1789   tmp = gfc_build_addr_expr (NULL_TREE, var);
1790   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1791                          function, 1, tmp);
1792   gfc_add_expr_to_block (&block, tmp);
1793
1794   gfc_add_block_to_block (&block, &post_block);
1795
1796   dt_parm = var;
1797   dt_post_end_block = &post_end_block;
1798
1799   /* Set implied do loop exit condition.  */
1800   if (last_dt == READ || last_dt == WRITE)
1801     {
1802       gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1803
1804       tmp = fold_build3_loc (input_location, COMPONENT_REF,
1805                              st_parameter[IOPARM_ptype_common].type,
1806                              dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1807                              NULL_TREE);
1808       tmp = fold_build3_loc (input_location, COMPONENT_REF,
1809                              TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1810       tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1811                              tmp, build_int_cst (TREE_TYPE (tmp),
1812                              IOPARM_common_libreturn_mask));
1813     }
1814   else /* IOLENGTH */
1815     tmp = NULL_TREE;
1816
1817   gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1818
1819   gfc_add_block_to_block (&block, &post_iu_block);
1820
1821   dt_parm = NULL;
1822   dt_post_end_block = NULL;
1823
1824   return gfc_finish_block (&block);
1825 }
1826
1827
1828 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1829    this as a third sort of data transfer statement, except that
1830    lengths are summed instead of actually transferring any data.  */
1831
1832 tree
1833 gfc_trans_iolength (gfc_code * code)
1834 {
1835   last_dt = IOLENGTH;
1836   return build_dt (iocall[IOCALL_IOLENGTH], code);
1837 }
1838
1839
1840 /* Translate a READ statement.  */
1841
1842 tree
1843 gfc_trans_read (gfc_code * code)
1844 {
1845   last_dt = READ;
1846   return build_dt (iocall[IOCALL_READ], code);
1847 }
1848
1849
1850 /* Translate a WRITE statement */
1851
1852 tree
1853 gfc_trans_write (gfc_code * code)
1854 {
1855   last_dt = WRITE;
1856   return build_dt (iocall[IOCALL_WRITE], code);
1857 }
1858
1859
1860 /* Finish a data transfer statement.  */
1861
1862 tree
1863 gfc_trans_dt_end (gfc_code * code)
1864 {
1865   tree function, tmp;
1866   stmtblock_t block;
1867
1868   gfc_init_block (&block);
1869
1870   switch (last_dt)
1871     {
1872     case READ:
1873       function = iocall[IOCALL_READ_DONE];
1874       break;
1875
1876     case WRITE:
1877       function = iocall[IOCALL_WRITE_DONE];
1878       break;
1879
1880     case IOLENGTH:
1881       function = iocall[IOCALL_IOLENGTH_DONE];
1882       break;
1883
1884     default:
1885       gcc_unreachable ();
1886     }
1887
1888   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1889   tmp = build_call_expr_loc (input_location,
1890                          function, 1, tmp);
1891   gfc_add_expr_to_block (&block, tmp);
1892   gfc_add_block_to_block (&block, dt_post_end_block);
1893   gfc_init_block (dt_post_end_block);
1894
1895   if (last_dt != IOLENGTH)
1896     {
1897       gcc_assert (code->ext.dt != NULL);
1898       io_result (&block, dt_parm, code->ext.dt->err,
1899                  code->ext.dt->end, code->ext.dt->eor);
1900     }
1901
1902   return gfc_finish_block (&block);
1903 }
1904
1905 static void
1906 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1907
1908 /* Given an array field in a derived type variable, generate the code
1909    for the loop that iterates over array elements, and the code that
1910    accesses those array elements.  Use transfer_expr to generate code
1911    for transferring that element.  Because elements may also be
1912    derived types, transfer_expr and transfer_array_component are mutually
1913    recursive.  */
1914
1915 static tree
1916 transfer_array_component (tree expr, gfc_component * cm, locus * where)
1917 {
1918   tree tmp;
1919   stmtblock_t body;
1920   stmtblock_t block;
1921   gfc_loopinfo loop;
1922   int n;
1923   gfc_ss *ss;
1924   gfc_se se;
1925
1926   gfc_start_block (&block);
1927   gfc_init_se (&se, NULL);
1928
1929   /* Create and initialize Scalarization Status.  Unlike in
1930      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1931      care of this task, because we don't have a gfc_expr at hand.
1932      Build one manually, as in gfc_trans_subarray_assign.  */
1933
1934   ss = gfc_get_ss ();
1935   ss->type = GFC_SS_COMPONENT;
1936   ss->expr = NULL;
1937   ss->shape = gfc_get_shape (cm->as->rank);
1938   ss->next = gfc_ss_terminator;
1939   ss->data.info.dimen = cm->as->rank;
1940   ss->data.info.descriptor = expr;
1941   ss->data.info.data = gfc_conv_array_data (expr);
1942   ss->data.info.offset = gfc_conv_array_offset (expr);
1943   for (n = 0; n < cm->as->rank; n++)
1944     {
1945       ss->data.info.dim[n] = n;
1946       ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1947       ss->data.info.stride[n] = gfc_index_one_node;
1948
1949       mpz_init (ss->shape[n]);
1950       mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1951                cm->as->lower[n]->value.integer);
1952       mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1953     }
1954
1955   /* Once we got ss, we use scalarizer to create the loop.  */
1956
1957   gfc_init_loopinfo (&loop);
1958   gfc_add_ss_to_loop (&loop, ss);
1959   gfc_conv_ss_startstride (&loop);
1960   gfc_conv_loop_setup (&loop, where);
1961   gfc_mark_ss_chain_used (ss, 1);
1962   gfc_start_scalarized_body (&loop, &body);
1963
1964   gfc_copy_loopinfo_to_se (&se, &loop);
1965   se.ss = ss;
1966
1967   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
1968   se.expr = expr;
1969   gfc_conv_tmp_array_ref (&se);
1970
1971   /* Now se.expr contains an element of the array.  Take the address and pass
1972      it to the IO routines.  */
1973   tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
1974   transfer_expr (&se, &cm->ts, tmp, NULL);
1975
1976   /* We are done now with the loop body.  Wrap up the scalarizer and
1977      return.  */
1978
1979   gfc_add_block_to_block (&body, &se.pre);
1980   gfc_add_block_to_block (&body, &se.post);
1981
1982   gfc_trans_scalarizing_loops (&loop, &body);
1983
1984   gfc_add_block_to_block (&block, &loop.pre);
1985   gfc_add_block_to_block (&block, &loop.post);
1986
1987   for (n = 0; n < cm->as->rank; n++)
1988     mpz_clear (ss->shape[n]);
1989   gfc_free (ss->shape);
1990
1991   gfc_cleanup_loop (&loop);
1992
1993   return gfc_finish_block (&block);
1994 }
1995
1996 /* Generate the call for a scalar transfer node.  */
1997
1998 static void
1999 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
2000 {
2001   tree tmp, function, arg2, arg3, field, expr;
2002   gfc_component *c;
2003   int kind;
2004
2005   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2006      the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2007      We need to translate the expression to a constant if it's either
2008      C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
2009      type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2010      BT_DERIVED (could have been changed by gfc_conv_expr).  */
2011   if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2012       && ts->u.derived != NULL
2013       && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2014     {
2015       /* C_PTR and C_FUNPTR have private components which means they can not
2016          be printed.  However, if -std=gnu and not -pedantic, allow
2017          the component to be printed to help debugging.  */
2018       if (gfc_notification_std (GFC_STD_GNU) != SILENT)
2019         {
2020           gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2021                          ts->u.derived->name, code != NULL ? &(code->loc) : 
2022                          &gfc_current_locus);
2023           return;
2024         }
2025
2026       ts->type = ts->u.derived->ts.type;
2027       ts->kind = ts->u.derived->ts.kind;
2028       ts->f90_type = ts->u.derived->ts.f90_type;
2029     }
2030   
2031   kind = ts->kind;
2032   function = NULL;
2033   arg2 = NULL;
2034   arg3 = NULL;
2035
2036   switch (ts->type)
2037     {
2038     case BT_INTEGER:
2039       arg2 = build_int_cst (NULL_TREE, kind);
2040       function = iocall[IOCALL_X_INTEGER];
2041       break;
2042
2043     case BT_REAL:
2044       arg2 = build_int_cst (NULL_TREE, kind);
2045       function = iocall[IOCALL_X_REAL];
2046       break;
2047
2048     case BT_COMPLEX:
2049       arg2 = build_int_cst (NULL_TREE, kind);
2050       function = iocall[IOCALL_X_COMPLEX];
2051       break;
2052
2053     case BT_LOGICAL:
2054       arg2 = build_int_cst (NULL_TREE, kind);
2055       function = iocall[IOCALL_X_LOGICAL];
2056       break;
2057
2058     case BT_CHARACTER:
2059       if (kind == 4)
2060         {
2061           if (se->string_length)
2062             arg2 = se->string_length;
2063           else
2064             {
2065               tmp = build_fold_indirect_ref_loc (input_location,
2066                                              addr_expr);
2067               gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2068               arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2069               arg2 = fold_convert (gfc_charlen_type_node, arg2);
2070             }
2071           arg3 = build_int_cst (NULL_TREE, kind);
2072           function = iocall[IOCALL_X_CHARACTER_WIDE];
2073           tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2074           tmp = build_call_expr_loc (input_location,
2075                                  function, 4, tmp, addr_expr, arg2, arg3);
2076           gfc_add_expr_to_block (&se->pre, tmp);
2077           gfc_add_block_to_block (&se->pre, &se->post);
2078           return;
2079         }
2080       /* Fall through. */
2081     case BT_HOLLERITH:
2082       if (se->string_length)
2083         arg2 = se->string_length;
2084       else
2085         {
2086           tmp = build_fold_indirect_ref_loc (input_location,
2087                                          addr_expr);
2088           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2089           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2090         }
2091       function = iocall[IOCALL_X_CHARACTER];
2092       break;
2093
2094     case BT_DERIVED:
2095       /* Recurse into the elements of the derived type.  */
2096       expr = gfc_evaluate_now (addr_expr, &se->pre);
2097       expr = build_fold_indirect_ref_loc (input_location,
2098                                       expr);
2099
2100       for (c = ts->u.derived->components; c; c = c->next)
2101         {
2102           field = c->backend_decl;
2103           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2104
2105           tmp = fold_build3_loc (UNKNOWN_LOCATION,
2106                              COMPONENT_REF, TREE_TYPE (field),
2107                              expr, field, NULL_TREE);
2108
2109           if (c->attr.dimension)
2110             {
2111               tmp = transfer_array_component (tmp, c, & code->loc);
2112               gfc_add_expr_to_block (&se->pre, tmp);
2113             }
2114           else
2115             {
2116               if (!c->attr.pointer)
2117                 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2118               transfer_expr (se, &c->ts, tmp, code);
2119             }
2120         }
2121       return;
2122
2123     default:
2124       internal_error ("Bad IO basetype (%d)", ts->type);
2125     }
2126
2127   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2128   tmp = build_call_expr_loc (input_location,
2129                          function, 3, tmp, addr_expr, arg2);
2130   gfc_add_expr_to_block (&se->pre, tmp);
2131   gfc_add_block_to_block (&se->pre, &se->post);
2132
2133 }
2134
2135
2136 /* Generate a call to pass an array descriptor to the IO library. The
2137    array should be of one of the intrinsic types.  */
2138
2139 static void
2140 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2141 {
2142   tree tmp, charlen_arg, kind_arg;
2143
2144   if (ts->type == BT_CHARACTER)
2145     charlen_arg = se->string_length;
2146   else
2147     charlen_arg = build_int_cst (NULL_TREE, 0);
2148
2149   kind_arg = build_int_cst (NULL_TREE, ts->kind);
2150
2151   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2152   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2153                          iocall[IOCALL_X_ARRAY], 4,
2154                          tmp, addr_expr, kind_arg, charlen_arg);
2155   gfc_add_expr_to_block (&se->pre, tmp);
2156   gfc_add_block_to_block (&se->pre, &se->post);
2157 }
2158
2159
2160 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2161
2162 tree
2163 gfc_trans_transfer (gfc_code * code)
2164 {
2165   stmtblock_t block, body;
2166   gfc_loopinfo loop;
2167   gfc_expr *expr;
2168   gfc_ref *ref;
2169   gfc_ss *ss;
2170   gfc_se se;
2171   tree tmp;
2172   int n;
2173
2174   gfc_start_block (&block);
2175   gfc_init_block (&body);
2176
2177   expr = code->expr1;
2178   ss = gfc_walk_expr (expr);
2179
2180   ref = NULL;
2181   gfc_init_se (&se, NULL);
2182
2183   if (ss == gfc_ss_terminator)
2184     {
2185       /* Transfer a scalar value.  */
2186       gfc_conv_expr_reference (&se, expr);
2187       transfer_expr (&se, &expr->ts, se.expr, code);
2188     }
2189   else
2190     {
2191       /* Transfer an array. If it is an array of an intrinsic
2192          type, pass the descriptor to the library.  Otherwise
2193          scalarize the transfer.  */
2194       if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
2195         {
2196           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2197                  ref = ref->next);
2198           gcc_assert (ref->type == REF_ARRAY);
2199         }
2200
2201       if (expr->ts.type != BT_DERIVED
2202             && ref && ref->next == NULL
2203             && !is_subref_array (expr))
2204         {
2205           bool seen_vector = false;
2206
2207           if (ref && ref->u.ar.type == AR_SECTION)
2208             {
2209               for (n = 0; n < ref->u.ar.dimen; n++)
2210                 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2211                   seen_vector = true;
2212             }
2213
2214           if (seen_vector && last_dt == READ)
2215             {
2216               /* Create a temp, read to that and copy it back.  */
2217               gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2218               tmp =  se.expr;
2219             }
2220           else
2221             {
2222               /* Get the descriptor.  */
2223               gfc_conv_expr_descriptor (&se, expr, ss);
2224               tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2225             }
2226
2227           transfer_array_desc (&se, &expr->ts, tmp);
2228           goto finish_block_label;
2229         }
2230       
2231       /* Initialize the scalarizer.  */
2232       gfc_init_loopinfo (&loop);
2233       gfc_add_ss_to_loop (&loop, ss);
2234
2235       /* Initialize the loop.  */
2236       gfc_conv_ss_startstride (&loop);
2237       gfc_conv_loop_setup (&loop, &code->expr1->where);
2238
2239       /* The main loop body.  */
2240       gfc_mark_ss_chain_used (ss, 1);
2241       gfc_start_scalarized_body (&loop, &body);
2242
2243       gfc_copy_loopinfo_to_se (&se, &loop);
2244       se.ss = ss;
2245
2246       gfc_conv_expr_reference (&se, expr);
2247       transfer_expr (&se, &expr->ts, se.expr, code);
2248     }
2249
2250  finish_block_label:
2251
2252   gfc_add_block_to_block (&body, &se.pre);
2253   gfc_add_block_to_block (&body, &se.post);
2254
2255   if (se.ss == NULL)
2256     tmp = gfc_finish_block (&body);
2257   else
2258     {
2259       gcc_assert (se.ss == gfc_ss_terminator);
2260       gfc_trans_scalarizing_loops (&loop, &body);
2261
2262       gfc_add_block_to_block (&loop.pre, &loop.post);
2263       tmp = gfc_finish_block (&loop.pre);
2264       gfc_cleanup_loop (&loop);
2265     }
2266
2267   gfc_add_expr_to_block (&block, tmp);
2268
2269   return gfc_finish_block (&block);
2270 }
2271
2272 #include "gt-fortran-trans-io.h"