OSDN Git Service

b7464d0519c380430936cd14bf9eda31c6fcb199
[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 "gimple.h"
28 #include "ggc.h"
29 #include "toplev.h"
30 #include "real.h"
31 #include "gfortran.h"
32 #include "trans.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
37
38 /* Members of the ioparm structure.  */
39
40 enum ioparam_type
41 {
42   IOPARM_ptype_common,
43   IOPARM_ptype_open,
44   IOPARM_ptype_close,
45   IOPARM_ptype_filepos,
46   IOPARM_ptype_inquire,
47   IOPARM_ptype_dt,
48   IOPARM_ptype_wait,
49   IOPARM_ptype_num
50 };
51
52 enum iofield_type
53 {
54   IOPARM_type_int4,
55   IOPARM_type_intio,
56   IOPARM_type_pint4,
57   IOPARM_type_pintio,
58   IOPARM_type_pchar,
59   IOPARM_type_parray,
60   IOPARM_type_pad,
61   IOPARM_type_char1,
62   IOPARM_type_char2,
63   IOPARM_type_common,
64   IOPARM_type_num
65 };
66
67 typedef struct GTY(()) gfc_st_parameter_field {
68   const char *name;
69   unsigned int mask;
70   enum ioparam_type param_type;
71   enum iofield_type type;
72   tree field;
73   tree field_len;
74 }
75 gfc_st_parameter_field;
76
77 typedef struct GTY(()) gfc_st_parameter {
78   const char *name;
79   tree type;
80 }
81 gfc_st_parameter;
82
83 enum iofield
84 {
85 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
86 #include "ioparm.def"
87 #undef IOPARM
88   IOPARM_field_num
89 };
90
91 static GTY(()) gfc_st_parameter st_parameter[] =
92 {
93   { "common", NULL },
94   { "open", NULL },
95   { "close", NULL },
96   { "filepos", NULL },
97   { "inquire", NULL },
98   { "dt", NULL },
99   { "wait", NULL }
100 };
101
102 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
103 {
104 #define IOPARM(param_type, name, mask, type) \
105   { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
106 #include "ioparm.def"
107 #undef IOPARM
108   { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
109 };
110
111 /* Library I/O subroutines */
112
113 enum iocall
114 {
115   IOCALL_READ,
116   IOCALL_READ_DONE,
117   IOCALL_WRITE,
118   IOCALL_WRITE_DONE,
119   IOCALL_X_INTEGER,
120   IOCALL_X_LOGICAL,
121   IOCALL_X_CHARACTER,
122   IOCALL_X_CHARACTER_WIDE,
123   IOCALL_X_REAL,
124   IOCALL_X_COMPLEX,
125   IOCALL_X_ARRAY,
126   IOCALL_OPEN,
127   IOCALL_CLOSE,
128   IOCALL_INQUIRE,
129   IOCALL_IOLENGTH,
130   IOCALL_IOLENGTH_DONE,
131   IOCALL_REWIND,
132   IOCALL_BACKSPACE,
133   IOCALL_ENDFILE,
134   IOCALL_FLUSH,
135   IOCALL_SET_NML_VAL,
136   IOCALL_SET_NML_VAL_DIM,
137   IOCALL_WAIT,
138   IOCALL_NUM
139 };
140
141 static GTY(()) tree iocall[IOCALL_NUM];
142
143 /* Variable for keeping track of what the last data transfer statement
144    was.  Used for deciding which subroutine to call when the data
145    transfer is complete.  */
146 static enum { READ, WRITE, IOLENGTH } last_dt;
147
148 /* The data transfer parameter block that should be shared by all
149    data transfer calls belonging to the same read/write/iolength.  */
150 static GTY(()) tree dt_parm;
151 static stmtblock_t *dt_post_end_block;
152
153 static void
154 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
155 {
156   unsigned int type;
157   gfc_st_parameter_field *p;
158   char name[64];
159   size_t len;
160   tree t = make_node (RECORD_TYPE);
161
162   len = strlen (st_parameter[ptype].name);
163   gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
164   memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
165   memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
166           len + 1);
167   TYPE_NAME (t) = get_identifier (name);
168
169   for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
170     if (p->param_type == ptype)
171       switch (p->type)
172         {
173         case IOPARM_type_int4:
174         case IOPARM_type_intio:
175         case IOPARM_type_pint4:
176         case IOPARM_type_pintio:
177         case IOPARM_type_parray:
178         case IOPARM_type_pchar:
179         case IOPARM_type_pad:
180           p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
181                                               get_identifier (p->name),
182                                               types[p->type]);
183           break;
184         case IOPARM_type_char1:
185           p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
186                                               get_identifier (p->name),
187                                               pchar_type_node);
188           /* FALLTHROUGH */
189         case IOPARM_type_char2:
190           len = strlen (p->name);
191           gcc_assert (len <= sizeof (name) - sizeof ("_len"));
192           memcpy (name, p->name, len);
193           memcpy (name + len, "_len", sizeof ("_len"));
194           p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
195                                                   get_identifier (name),
196                                                   gfc_charlen_type_node);
197           if (p->type == IOPARM_type_char2)
198             p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
199                                                 get_identifier (p->name),
200                                                 pchar_type_node);
201           break;
202         case IOPARM_type_common:
203           p->field
204             = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
205                                        get_identifier (p->name),
206                                        st_parameter[IOPARM_ptype_common].type);
207           break;
208         case IOPARM_type_num:
209           gcc_unreachable ();
210         }
211
212   gfc_finish_type (t);
213   st_parameter[ptype].type = t;
214 }
215
216
217 /* Build code to test an error condition and call generate_error if needed.
218    Note: This builds calls to generate_error in the runtime library function.
219    The function generate_error is dependent on certain parameters in the
220    st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
221    Therefore, the code to set these flags must be generated before
222    this function is used.  */
223
224 void
225 gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
226                          const char * msgid, stmtblock_t * pblock)
227 {
228   stmtblock_t block;
229   tree body;
230   tree tmp;
231   tree arg1, arg2, arg3;
232   char *message;
233
234   if (integer_zerop (cond))
235     return;
236
237   /* The code to generate the error.  */
238   gfc_start_block (&block);
239   
240   arg1 = gfc_build_addr_expr (NULL_TREE, var);
241   
242   arg2 = build_int_cst (integer_type_node, error_code),
243   
244   asprintf (&message, "%s", _(msgid));
245   arg3 = gfc_build_addr_expr (pchar_type_node,
246                               gfc_build_localized_cstring_const (message));
247   gfc_free(message);
248   
249   tmp = build_call_expr_loc (input_location,
250                          gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
251
252   gfc_add_expr_to_block (&block, tmp);
253
254   body = gfc_finish_block (&block);
255
256   if (integer_onep (cond))
257     {
258       gfc_add_expr_to_block (pblock, body);
259     }
260   else
261     {
262       /* Tell the compiler that this isn't likely.  */
263       cond = fold_convert (long_integer_type_node, cond);
264       tmp = build_int_cst (long_integer_type_node, 0);
265       cond = build_call_expr_loc (input_location,
266                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
267       cond = fold_convert (boolean_type_node, cond);
268
269       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
270       gfc_add_expr_to_block (pblock, tmp);
271     }
272 }
273
274
275 /* Create function decls for IO library functions.  */
276
277 void
278 gfc_build_io_library_fndecls (void)
279 {
280   tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
281   tree gfc_intio_type_node;
282   tree parm_type, dt_parm_type;
283   HOST_WIDE_INT pad_size;
284   unsigned int ptype;
285
286   types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
287   types[IOPARM_type_intio] = gfc_intio_type_node
288                             = gfc_get_int_type (gfc_intio_kind);
289   types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
290   types[IOPARM_type_pintio]
291                             = build_pointer_type (gfc_intio_type_node);
292   types[IOPARM_type_parray] = pchar_type_node;
293   types[IOPARM_type_pchar] = pchar_type_node;
294   pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
295   pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
296   pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1));
297   types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
298
299   /* pad actually contains pointers and integers so it needs to have an
300      alignment that is at least as large as the needed alignment for those
301      types.  See the st_parameter_dt structure in libgfortran/io/io.h for
302      what really goes into this space.  */
303   TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
304                      TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
305
306   for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
307     gfc_build_st_parameter ((enum ioparam_type) ptype, types);
308
309   /* Define the transfer functions.  */
310
311   dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
312
313   iocall[IOCALL_X_INTEGER] =
314     gfc_build_library_function_decl (get_identifier
315                                      (PREFIX("transfer_integer")),
316                                      void_type_node, 3, dt_parm_type,
317                                      pvoid_type_node, gfc_int4_type_node);
318
319   iocall[IOCALL_X_LOGICAL] =
320     gfc_build_library_function_decl (get_identifier
321                                      (PREFIX("transfer_logical")),
322                                      void_type_node, 3, dt_parm_type,
323                                      pvoid_type_node, gfc_int4_type_node);
324
325   iocall[IOCALL_X_CHARACTER] =
326     gfc_build_library_function_decl (get_identifier
327                                      (PREFIX("transfer_character")),
328                                      void_type_node, 3, dt_parm_type,
329                                      pvoid_type_node, gfc_int4_type_node);
330
331   iocall[IOCALL_X_CHARACTER_WIDE] =
332     gfc_build_library_function_decl (get_identifier
333                                      (PREFIX("transfer_character_wide")),
334                                      void_type_node, 4, dt_parm_type,
335                                      pvoid_type_node, gfc_charlen_type_node,
336                                      gfc_int4_type_node);
337
338   iocall[IOCALL_X_REAL] =
339     gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
340                                      void_type_node, 3, dt_parm_type,
341                                      pvoid_type_node, gfc_int4_type_node);
342
343   iocall[IOCALL_X_COMPLEX] =
344     gfc_build_library_function_decl (get_identifier
345                                      (PREFIX("transfer_complex")),
346                                      void_type_node, 3, dt_parm_type,
347                                      pvoid_type_node, gfc_int4_type_node);
348
349   iocall[IOCALL_X_ARRAY] =
350     gfc_build_library_function_decl (get_identifier
351                                      (PREFIX("transfer_array")),
352                                      void_type_node, 4, dt_parm_type,
353                                      pvoid_type_node, integer_type_node,
354                                      gfc_charlen_type_node);
355
356   /* Library entry points */
357
358   iocall[IOCALL_READ] =
359     gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
360                                      void_type_node, 1, dt_parm_type);
361
362   iocall[IOCALL_WRITE] =
363     gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
364                                      void_type_node, 1, dt_parm_type);
365
366   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
367   iocall[IOCALL_OPEN] =
368     gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
369                                      void_type_node, 1, parm_type);
370
371
372   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
373   iocall[IOCALL_CLOSE] =
374     gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
375                                      void_type_node, 1, parm_type);
376
377   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
378   iocall[IOCALL_INQUIRE] =
379     gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
380                                      gfc_int4_type_node, 1, parm_type);
381
382   iocall[IOCALL_IOLENGTH] =
383     gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
384                                     void_type_node, 1, dt_parm_type);
385
386   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
387   iocall[IOCALL_WAIT] =
388     gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
389                                      gfc_int4_type_node, 1, parm_type);
390
391   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
392   iocall[IOCALL_REWIND] =
393     gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
394                                      gfc_int4_type_node, 1, parm_type);
395
396   iocall[IOCALL_BACKSPACE] =
397     gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
398                                      gfc_int4_type_node, 1, parm_type);
399
400   iocall[IOCALL_ENDFILE] =
401     gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
402                                      gfc_int4_type_node, 1, parm_type);
403
404   iocall[IOCALL_FLUSH] =
405     gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
406                                      gfc_int4_type_node, 1, parm_type);
407
408   /* Library helpers */
409
410   iocall[IOCALL_READ_DONE] =
411     gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
412                                      gfc_int4_type_node, 1, dt_parm_type);
413
414   iocall[IOCALL_WRITE_DONE] =
415     gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
416                                      gfc_int4_type_node, 1, dt_parm_type);
417
418   iocall[IOCALL_IOLENGTH_DONE] =
419     gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
420                                      gfc_int4_type_node, 1, dt_parm_type);
421
422
423   iocall[IOCALL_SET_NML_VAL] =
424     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
425                                      void_type_node, 6, dt_parm_type,
426                                      pvoid_type_node, pvoid_type_node,
427                                      gfc_int4_type_node, gfc_charlen_type_node,
428                                      gfc_int4_type_node);
429
430   iocall[IOCALL_SET_NML_VAL_DIM] =
431     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
432                                      void_type_node, 5, dt_parm_type,
433                                      gfc_int4_type_node, gfc_array_index_type,
434                                      gfc_array_index_type, gfc_array_index_type);
435 }
436
437
438 /* Generate code to store an integer constant into the
439    st_parameter_XXX structure.  */
440
441 static unsigned int
442 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
443                      unsigned int val)
444 {
445   tree tmp;
446   gfc_st_parameter_field *p = &st_parameter_field[type];
447
448   if (p->param_type == IOPARM_ptype_common)
449     var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
450                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
451   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
452                      NULL_TREE);
453   gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
454   return p->mask;
455 }
456
457
458 /* Generate code to store a non-string I/O parameter into the
459    st_parameter_XXX structure.  This is a pass by value.  */
460
461 static unsigned int
462 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
463                      gfc_expr *e)
464 {
465   gfc_se se;
466   tree tmp;
467   gfc_st_parameter_field *p = &st_parameter_field[type];
468   tree dest_type = TREE_TYPE (p->field);
469
470   gfc_init_se (&se, NULL);
471   gfc_conv_expr_val (&se, e);
472
473   /* If we're storing a UNIT number, we need to check it first.  */
474   if (type == IOPARM_common_unit && e->ts.kind > 4)
475     {
476       tree cond, val;
477       int i;
478
479       /* Don't evaluate the UNIT number multiple times.  */
480       se.expr = gfc_evaluate_now (se.expr, &se.pre);
481
482       /* UNIT numbers should be greater than the min.  */
483       i = gfc_validate_kind (BT_INTEGER, 4, false);
484       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
485       cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
486                           fold_convert (TREE_TYPE (se.expr), val));
487       gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
488                                "Unit number in I/O statement too small",
489                                &se.pre);
490     
491       /* UNIT numbers should be less than the max.  */
492       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
493       cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
494                           fold_convert (TREE_TYPE (se.expr), val));
495       gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
496                                "Unit number in I/O statement too large",
497                                &se.pre);
498
499     }
500
501   se.expr = convert (dest_type, se.expr);
502   gfc_add_block_to_block (block, &se.pre);
503
504   if (p->param_type == IOPARM_ptype_common)
505     var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
506                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
507
508   tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
509   gfc_add_modify (block, tmp, se.expr);
510   return p->mask;
511 }
512
513
514 /* Generate code to store a non-string I/O parameter into the
515    st_parameter_XXX structure.  This is pass by reference.  */
516
517 static unsigned int
518 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
519                    tree var, enum iofield type, gfc_expr *e)
520 {
521   gfc_se se;
522   tree tmp, addr;
523   gfc_st_parameter_field *p = &st_parameter_field[type];
524
525   gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
526   gfc_init_se (&se, NULL);
527   gfc_conv_expr_lhs (&se, e);
528
529   gfc_add_block_to_block (block, &se.pre);
530
531   if (TYPE_MODE (TREE_TYPE (se.expr))
532       == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
533     {
534       addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
535
536       /* If this is for the iostat variable initialize the
537          user variable to LIBERROR_OK which is zero.  */
538       if (type == IOPARM_common_iostat)
539         gfc_add_modify (block, se.expr,
540                              build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
541     }
542   else
543     {
544       /* The type used by the library has different size
545         from the type of the variable supplied by the user.
546         Need to use a temporary.  */
547       tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
548                                     st_parameter_field[type].name);
549
550       /* If this is for the iostat variable, initialize the
551          user variable to LIBERROR_OK which is zero.  */
552       if (type == IOPARM_common_iostat)
553         gfc_add_modify (block, tmpvar,
554                              build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
555
556       addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
557         /* After the I/O operation, we set the variable from the temporary.  */
558       tmp = convert (TREE_TYPE (se.expr), tmpvar);
559       gfc_add_modify (postblock, se.expr, tmp);
560      }
561
562   if (p->param_type == IOPARM_ptype_common)
563     var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
564                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
565   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
566                      var, p->field, NULL_TREE);
567   gfc_add_modify (block, tmp, addr);
568   return p->mask;
569 }
570
571 /* Given an array expr, find its address and length to get a string. If the
572    array is full, the string's address is the address of array's first element
573    and the length is the size of the whole array.  If it is an element, the
574    string's address is the element's address and the length is the rest size of
575    the array.  */
576
577 static void
578 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
579 {
580   tree size;
581
582   if (e->rank == 0)
583     {
584       tree type, array, tmp;
585       gfc_symbol *sym;
586       int rank;
587
588       /* If it is an element, we need its address and size of the rest.  */
589       gcc_assert (e->expr_type == EXPR_VARIABLE);
590       gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
591       sym = e->symtree->n.sym;
592       rank = sym->as->rank - 1;
593       gfc_conv_expr (se, e);
594
595       array = sym->backend_decl;
596       type = TREE_TYPE (array);
597
598       if (GFC_ARRAY_TYPE_P (type))
599         size = GFC_TYPE_ARRAY_SIZE (type);
600       else
601         {
602           gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
603           size = gfc_conv_array_stride (array, rank);
604           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
605                              gfc_conv_array_ubound (array, rank),
606                              gfc_conv_array_lbound (array, rank));
607           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
608                              gfc_index_one_node);
609           size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
610         }
611       gcc_assert (size);
612
613       size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
614                           TREE_OPERAND (se->expr, 1));
615       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
616       tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
617       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
618                           fold_convert (gfc_array_index_type, tmp));
619       se->string_length = fold_convert (gfc_charlen_type_node, size);
620       return;
621     }
622
623   gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
624   se->string_length = fold_convert (gfc_charlen_type_node, size);
625 }
626
627
628 /* Generate code to store a string and its length into the
629    st_parameter_XXX structure.  */
630
631 static unsigned int
632 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
633             enum iofield type, gfc_expr * e)
634 {
635   gfc_se se;
636   tree tmp;
637   tree io;
638   tree len;
639   gfc_st_parameter_field *p = &st_parameter_field[type];
640
641   gfc_init_se (&se, NULL);
642
643   if (p->param_type == IOPARM_ptype_common)
644     var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
645                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
646   io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
647                     var, p->field, NULL_TREE);
648   len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
649                      var, p->field_len, NULL_TREE);
650
651   /* Integer variable assigned a format label.  */
652   if (e->ts.type == BT_INTEGER
653       && e->rank == 0
654       && e->symtree->n.sym->attr.assign == 1)
655     {
656       char * msg;
657       tree cond;
658
659       gfc_conv_label_variable (&se, e);
660       tmp = GFC_DECL_STRING_LEN (se.expr);
661       cond = fold_build2 (LT_EXPR, boolean_type_node,
662                           tmp, build_int_cst (TREE_TYPE (tmp), 0));
663
664       asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
665                "label", e->symtree->name);
666       gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
667                                fold_convert (long_integer_type_node, tmp));
668       gfc_free (msg);
669
670       gfc_add_modify (&se.pre, io,
671                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
672       gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
673     }
674   else
675     {
676       /* General character.  */
677       if (e->ts.type == BT_CHARACTER && e->rank == 0)
678         gfc_conv_expr (&se, e);
679       /* Array assigned Hollerith constant or character array.  */
680       else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
681         gfc_convert_array_to_string (&se, e);
682       else
683         gcc_unreachable ();
684
685       gfc_conv_string_parameter (&se);
686       gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
687       gfc_add_modify (&se.pre, len, se.string_length);
688     }
689
690   gfc_add_block_to_block (block, &se.pre);
691   gfc_add_block_to_block (postblock, &se.post);
692   return p->mask;
693 }
694
695
696 /* Generate code to store the character (array) and the character length
697    for an internal unit.  */
698
699 static unsigned int
700 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
701                    tree var, gfc_expr * e)
702 {
703   gfc_se se;
704   tree io;
705   tree len;
706   tree desc;
707   tree tmp;
708   gfc_st_parameter_field *p;
709   unsigned int mask;
710
711   gfc_init_se (&se, NULL);
712
713   p = &st_parameter_field[IOPARM_dt_internal_unit];
714   mask = p->mask;
715   io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
716                     var, p->field, NULL_TREE);
717   len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
718                      var, p->field_len, NULL_TREE);
719   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
720   desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
721                       var, p->field, NULL_TREE);
722
723   gcc_assert (e->ts.type == BT_CHARACTER);
724
725   /* Character scalars.  */
726   if (e->rank == 0)
727     {
728       gfc_conv_expr (&se, e);
729       gfc_conv_string_parameter (&se);
730       tmp = se.expr;
731       se.expr = build_int_cst (pchar_type_node, 0);
732     }
733
734   /* Character array.  */
735   else if (e->rank > 0)
736     {
737       se.ss = gfc_walk_expr (e);
738
739       if (is_subref_array (e))
740         {
741           /* Use a temporary for components of arrays of derived types
742              or substring array references.  */
743           gfc_conv_subref_array_arg (&se, e, 0,
744                 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
745           tmp = build_fold_indirect_ref_loc (input_location,
746                                          se.expr);
747           se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
748           tmp = gfc_conv_descriptor_data_get (tmp);
749         }
750       else
751         {
752           /* Return the data pointer and rank from the descriptor.  */
753           gfc_conv_expr_descriptor (&se, e, se.ss);
754           tmp = gfc_conv_descriptor_data_get (se.expr);
755           se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
756         }
757     }
758   else
759     gcc_unreachable ();
760
761   /* The cast is needed for character substrings and the descriptor
762      data.  */
763   gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
764   gfc_add_modify (&se.pre, len,
765                        fold_convert (TREE_TYPE (len), se.string_length));
766   gfc_add_modify (&se.pre, desc, se.expr);
767
768   gfc_add_block_to_block (block, &se.pre);
769   gfc_add_block_to_block (post_block, &se.post);
770   return mask;
771 }
772
773 /* Add a case to a IO-result switch.  */
774
775 static void
776 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
777 {
778   tree tmp, value;
779
780   if (label == NULL)
781     return;                     /* No label, no case */
782
783   value = build_int_cst (NULL_TREE, label_value);
784
785   /* Make a backend label for this case.  */
786   tmp = gfc_build_label_decl (NULL_TREE);
787
788   /* And the case itself.  */
789   tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
790   gfc_add_expr_to_block (body, tmp);
791
792   /* Jump to the label.  */
793   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
794   gfc_add_expr_to_block (body, tmp);
795 }
796
797
798 /* Generate a switch statement that branches to the correct I/O
799    result label.  The last statement of an I/O call stores the
800    result into a variable because there is often cleanup that
801    must be done before the switch, so a temporary would have to
802    be created anyway.  */
803
804 static void
805 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
806            gfc_st_label * end_label, gfc_st_label * eor_label)
807 {
808   stmtblock_t body;
809   tree tmp, rc;
810   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
811
812   /* If no labels are specified, ignore the result instead
813      of building an empty switch.  */
814   if (err_label == NULL
815       && end_label == NULL
816       && eor_label == NULL)
817     return;
818
819   /* Build a switch statement.  */
820   gfc_start_block (&body);
821
822   /* The label values here must be the same as the values
823      in the library_return enum in the runtime library */
824   add_case (1, err_label, &body);
825   add_case (2, end_label, &body);
826   add_case (3, eor_label, &body);
827
828   tmp = gfc_finish_block (&body);
829
830   var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
831                      var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
832   rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
833                     var, p->field, NULL_TREE);
834   rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc),
835                     rc, build_int_cst (TREE_TYPE (rc),
836                                        IOPARM_common_libreturn_mask));
837
838   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
839
840   gfc_add_expr_to_block (block, tmp);
841 }
842
843
844 /* Store the current file and line number to variables so that if a
845    library call goes awry, we can tell the user where the problem is.  */
846
847 static void
848 set_error_locus (stmtblock_t * block, tree var, locus * where)
849 {
850   gfc_file *f;
851   tree str, locus_file;
852   int line;
853   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
854
855   locus_file = fold_build3 (COMPONENT_REF,
856                             st_parameter[IOPARM_ptype_common].type,
857                             var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
858   locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
859                             locus_file, p->field, NULL_TREE);
860   f = where->lb->file;
861   str = gfc_build_cstring_const (f->filename);
862
863   str = gfc_build_addr_expr (pchar_type_node, str);
864   gfc_add_modify (block, locus_file, str);
865
866   line = LOCATION_LINE (where->lb->location);
867   set_parameter_const (block, var, IOPARM_common_line, line);
868 }
869
870
871 /* Translate an OPEN statement.  */
872
873 tree
874 gfc_trans_open (gfc_code * code)
875 {
876   stmtblock_t block, post_block;
877   gfc_open *p;
878   tree tmp, var;
879   unsigned int mask = 0;
880
881   gfc_start_block (&block);
882   gfc_init_block (&post_block);
883
884   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
885
886   set_error_locus (&block, var, &code->loc);
887   p = code->ext.open;
888
889   if (p->iomsg)
890     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
891                         p->iomsg);
892
893   if (p->iostat)
894     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
895                                p->iostat);
896
897   if (p->err)
898     mask |= IOPARM_common_err;
899
900   if (p->file)
901     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
902
903   if (p->status)
904     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
905                         p->status);
906
907   if (p->access)
908     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
909                         p->access);
910
911   if (p->form)
912     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
913
914   if (p->recl)
915     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
916
917   if (p->blank)
918     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
919                         p->blank);
920
921   if (p->position)
922     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
923                         p->position);
924
925   if (p->action)
926     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
927                         p->action);
928
929   if (p->delim)
930     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
931                         p->delim);
932
933   if (p->pad)
934     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
935
936   if (p->decimal)
937     mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
938                         p->decimal);
939
940   if (p->encoding)
941     mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
942                         p->encoding);
943
944   if (p->round)
945     mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
946
947   if (p->sign)
948     mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
949
950   if (p->asynchronous)
951     mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
952                         p->asynchronous);
953
954   if (p->convert)
955     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
956                         p->convert);
957                         
958   if (p->newunit)
959     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
960                                p->newunit);
961
962   set_parameter_const (&block, var, IOPARM_common_flags, mask);
963
964   if (p->unit)
965     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
966   else
967     set_parameter_const (&block, var, IOPARM_common_unit, 0);
968
969   tmp = gfc_build_addr_expr (NULL_TREE, var);
970   tmp = build_call_expr_loc (input_location,
971                          iocall[IOCALL_OPEN], 1, tmp);
972   gfc_add_expr_to_block (&block, tmp);
973
974   gfc_add_block_to_block (&block, &post_block);
975
976   io_result (&block, var, p->err, NULL, NULL);
977
978   return gfc_finish_block (&block);
979 }
980
981
982 /* Translate a CLOSE statement.  */
983
984 tree
985 gfc_trans_close (gfc_code * code)
986 {
987   stmtblock_t block, post_block;
988   gfc_close *p;
989   tree tmp, var;
990   unsigned int mask = 0;
991
992   gfc_start_block (&block);
993   gfc_init_block (&post_block);
994
995   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
996
997   set_error_locus (&block, var, &code->loc);
998   p = code->ext.close;
999
1000   if (p->iomsg)
1001     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1002                         p->iomsg);
1003
1004   if (p->iostat)
1005     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1006                                p->iostat);
1007
1008   if (p->err)
1009     mask |= IOPARM_common_err;
1010
1011   if (p->status)
1012     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1013                         p->status);
1014
1015   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1016
1017   if (p->unit)
1018     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1019   else
1020     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1021
1022   tmp = gfc_build_addr_expr (NULL_TREE, var);
1023   tmp = build_call_expr_loc (input_location,
1024                          iocall[IOCALL_CLOSE], 1, tmp);
1025   gfc_add_expr_to_block (&block, tmp);
1026
1027   gfc_add_block_to_block (&block, &post_block);
1028
1029   io_result (&block, var, p->err, NULL, NULL);
1030
1031   return gfc_finish_block (&block);
1032 }
1033
1034
1035 /* Common subroutine for building a file positioning statement.  */
1036
1037 static tree
1038 build_filepos (tree function, gfc_code * code)
1039 {
1040   stmtblock_t block, post_block;
1041   gfc_filepos *p;
1042   tree tmp, var;
1043   unsigned int mask = 0;
1044
1045   p = code->ext.filepos;
1046
1047   gfc_start_block (&block);
1048   gfc_init_block (&post_block);
1049
1050   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1051                         "filepos_parm");
1052
1053   set_error_locus (&block, var, &code->loc);
1054
1055   if (p->iomsg)
1056     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1057                         p->iomsg);
1058
1059   if (p->iostat)
1060     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1061                                p->iostat);
1062
1063   if (p->err)
1064     mask |= IOPARM_common_err;
1065
1066   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1067
1068   if (p->unit)
1069     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1070   else
1071     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1072
1073   tmp = gfc_build_addr_expr (NULL_TREE, var);
1074   tmp = build_call_expr_loc (input_location,
1075                          function, 1, tmp);
1076   gfc_add_expr_to_block (&block, tmp);
1077
1078   gfc_add_block_to_block (&block, &post_block);
1079
1080   io_result (&block, var, p->err, NULL, NULL);
1081
1082   return gfc_finish_block (&block);
1083 }
1084
1085
1086 /* Translate a BACKSPACE statement.  */
1087
1088 tree
1089 gfc_trans_backspace (gfc_code * code)
1090 {
1091   return build_filepos (iocall[IOCALL_BACKSPACE], code);
1092 }
1093
1094
1095 /* Translate an ENDFILE statement.  */
1096
1097 tree
1098 gfc_trans_endfile (gfc_code * code)
1099 {
1100   return build_filepos (iocall[IOCALL_ENDFILE], code);
1101 }
1102
1103
1104 /* Translate a REWIND statement.  */
1105
1106 tree
1107 gfc_trans_rewind (gfc_code * code)
1108 {
1109   return build_filepos (iocall[IOCALL_REWIND], code);
1110 }
1111
1112
1113 /* Translate a FLUSH statement.  */
1114
1115 tree
1116 gfc_trans_flush (gfc_code * code)
1117 {
1118   return build_filepos (iocall[IOCALL_FLUSH], code);
1119 }
1120
1121
1122 /* Create a dummy iostat variable to catch any error due to bad unit.  */
1123
1124 static gfc_expr *
1125 create_dummy_iostat (void)
1126 {
1127   gfc_symtree *st;
1128   gfc_expr *e;
1129
1130   gfc_get_ha_sym_tree ("@iostat", &st);
1131   st->n.sym->ts.type = BT_INTEGER;
1132   st->n.sym->ts.kind = gfc_default_integer_kind;
1133   gfc_set_sym_referenced (st->n.sym);
1134   gfc_commit_symbol (st->n.sym);
1135   st->n.sym->backend_decl
1136         = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1137                           st->n.sym->name);
1138
1139   e = gfc_get_expr ();
1140   e->expr_type = EXPR_VARIABLE;
1141   e->symtree = st;
1142   e->ts.type = BT_INTEGER;
1143   e->ts.kind = st->n.sym->ts.kind;
1144
1145   return e;
1146 }
1147
1148
1149 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
1150
1151 tree
1152 gfc_trans_inquire (gfc_code * code)
1153 {
1154   stmtblock_t block, post_block;
1155   gfc_inquire *p;
1156   tree tmp, var;
1157   unsigned int mask = 0, mask2 = 0;
1158
1159   gfc_start_block (&block);
1160   gfc_init_block (&post_block);
1161
1162   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1163                         "inquire_parm");
1164
1165   set_error_locus (&block, var, &code->loc);
1166   p = code->ext.inquire;
1167
1168   if (p->iomsg)
1169     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1170                         p->iomsg);
1171
1172   if (p->iostat)
1173     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1174                                p->iostat);
1175
1176   if (p->err)
1177     mask |= IOPARM_common_err;
1178
1179   /* Sanity check.  */
1180   if (p->unit && p->file)
1181     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1182
1183   if (p->file)
1184     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1185                         p->file);
1186
1187   if (p->exist)
1188     {
1189       mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1190                                  p->exist);
1191     
1192       if (p->unit && !p->iostat)
1193         {
1194           p->iostat = create_dummy_iostat ();
1195           mask |= set_parameter_ref (&block, &post_block, var,
1196                                      IOPARM_common_iostat, p->iostat);
1197         }
1198     }
1199
1200   if (p->opened)
1201     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1202                                p->opened);
1203
1204   if (p->number)
1205     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1206                                p->number);
1207
1208   if (p->named)
1209     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1210                                p->named);
1211
1212   if (p->name)
1213     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1214                         p->name);
1215
1216   if (p->access)
1217     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1218                         p->access);
1219
1220   if (p->sequential)
1221     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1222                         p->sequential);
1223
1224   if (p->direct)
1225     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1226                         p->direct);
1227
1228   if (p->form)
1229     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1230                         p->form);
1231
1232   if (p->formatted)
1233     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1234                         p->formatted);
1235
1236   if (p->unformatted)
1237     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1238                         p->unformatted);
1239
1240   if (p->recl)
1241     mask |= set_parameter_ref (&block, &post_block, var,
1242                                IOPARM_inquire_recl_out, p->recl);
1243
1244   if (p->nextrec)
1245     mask |= set_parameter_ref (&block, &post_block, var,
1246                                IOPARM_inquire_nextrec, p->nextrec);
1247
1248   if (p->blank)
1249     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1250                         p->blank);
1251
1252   if (p->delim)
1253     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1254                         p->delim);
1255
1256   if (p->position)
1257     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1258                         p->position);
1259
1260   if (p->action)
1261     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1262                         p->action);
1263
1264   if (p->read)
1265     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1266                         p->read);
1267
1268   if (p->write)
1269     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1270                         p->write);
1271
1272   if (p->readwrite)
1273     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1274                         p->readwrite);
1275
1276   if (p->pad)
1277     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1278                         p->pad);
1279   
1280   if (p->convert)
1281     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1282                         p->convert);
1283
1284   if (p->strm_pos)
1285     mask |= set_parameter_ref (&block, &post_block, var,
1286                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1287
1288   /* The second series of flags.  */
1289   if (p->asynchronous)
1290     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1291                          p->asynchronous);
1292
1293   if (p->decimal)
1294     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1295                          p->decimal);
1296
1297   if (p->encoding)
1298     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1299                          p->encoding);
1300
1301   if (p->round)
1302     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1303                          p->round);
1304
1305   if (p->sign)
1306     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1307                          p->sign);
1308
1309   if (p->pending)
1310     mask2 |= set_parameter_ref (&block, &post_block, var,
1311                                 IOPARM_inquire_pending, p->pending);
1312
1313   if (p->size)
1314     mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1315                                 p->size);
1316
1317   if (p->id)
1318     mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1319                                 p->id);
1320
1321   if (mask2)
1322     mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1323
1324   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1325
1326   if (p->unit)
1327     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1328   else
1329     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1330
1331   tmp = gfc_build_addr_expr (NULL_TREE, var);
1332   tmp = build_call_expr_loc (input_location,
1333                          iocall[IOCALL_INQUIRE], 1, tmp);
1334   gfc_add_expr_to_block (&block, tmp);
1335
1336   gfc_add_block_to_block (&block, &post_block);
1337
1338   io_result (&block, var, p->err, NULL, NULL);
1339
1340   return gfc_finish_block (&block);
1341 }
1342
1343
1344 tree
1345 gfc_trans_wait (gfc_code * code)
1346 {
1347   stmtblock_t block, post_block;
1348   gfc_wait *p;
1349   tree tmp, var;
1350   unsigned int mask = 0;
1351
1352   gfc_start_block (&block);
1353   gfc_init_block (&post_block);
1354
1355   var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1356                         "wait_parm");
1357
1358   set_error_locus (&block, var, &code->loc);
1359   p = code->ext.wait;
1360
1361   /* Set parameters here.  */
1362   if (p->iomsg)
1363     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1364                         p->iomsg);
1365
1366   if (p->iostat)
1367     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1368                                p->iostat);
1369
1370   if (p->err)
1371     mask |= IOPARM_common_err;
1372
1373   if (p->id)
1374     mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1375
1376   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1377
1378   if (p->unit)
1379     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1380
1381   tmp = gfc_build_addr_expr (NULL_TREE, var);
1382   tmp = build_call_expr_loc (input_location,
1383                          iocall[IOCALL_WAIT], 1, tmp);
1384   gfc_add_expr_to_block (&block, tmp);
1385
1386   gfc_add_block_to_block (&block, &post_block);
1387
1388   io_result (&block, var, p->err, NULL, NULL);
1389
1390   return gfc_finish_block (&block);
1391
1392 }
1393
1394
1395 /* nml_full_name builds up the fully qualified name of a
1396    derived type component.  */
1397
1398 static char*
1399 nml_full_name (const char* var_name, const char* cmp_name)
1400 {
1401   int full_name_length;
1402   char * full_name;
1403
1404   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1405   full_name = (char*)gfc_getmem (full_name_length + 1);
1406   strcpy (full_name, var_name);
1407   full_name = strcat (full_name, "%");
1408   full_name = strcat (full_name, cmp_name);
1409   return full_name;
1410 }
1411
1412 /* nml_get_addr_expr builds an address expression from the
1413    gfc_symbol or gfc_component backend_decl's. An offset is
1414    provided so that the address of an element of an array of
1415    derived types is returned. This is used in the runtime to
1416    determine that span of the derived type.  */
1417
1418 static tree
1419 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1420                    tree base_addr)
1421 {
1422   tree decl = NULL_TREE;
1423   tree tmp;
1424   tree itmp;
1425   int array_flagged;
1426   int dummy_arg_flagged;
1427
1428   if (sym)
1429     {
1430       sym->attr.referenced = 1;
1431       decl = gfc_get_symbol_decl (sym);
1432
1433       /* If this is the enclosing function declaration, use
1434          the fake result instead.  */
1435       if (decl == current_function_decl)
1436         decl = gfc_get_fake_result_decl (sym, 0);
1437       else if (decl == DECL_CONTEXT (current_function_decl))
1438         decl =  gfc_get_fake_result_decl (sym, 1);
1439     }
1440   else
1441     decl = c->backend_decl;
1442
1443   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1444                      || TREE_CODE (decl) == VAR_DECL
1445                      || TREE_CODE (decl) == PARM_DECL)
1446                      || TREE_CODE (decl) == COMPONENT_REF));
1447
1448   tmp = decl;
1449
1450   /* Build indirect reference, if dummy argument.  */
1451
1452   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1453
1454   itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
1455                                                         tmp) : tmp;
1456
1457   /* If an array, set flag and use indirect ref. if built.  */
1458
1459   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1460                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1461
1462   if (array_flagged)
1463     tmp = itmp;
1464
1465   /* Treat the component of a derived type, using base_addr for
1466      the derived type.  */
1467
1468   if (TREE_CODE (decl) == FIELD_DECL)
1469     tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
1470                        base_addr, tmp, NULL_TREE);
1471
1472   /* If we have a derived type component, a reference to the first
1473      element of the array is built.  This is done so that base_addr,
1474      used in the build of the component reference, always points to
1475      a RECORD_TYPE.  */
1476
1477   if (array_flagged)
1478     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1479
1480   /* Now build the address expression.  */
1481
1482   tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1483
1484   /* If scalar dummy, resolve indirect reference now.  */
1485
1486   if (dummy_arg_flagged && !array_flagged)
1487     tmp = build_fold_indirect_ref_loc (input_location,
1488                                    tmp);
1489
1490   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1491
1492   return tmp;
1493 }
1494
1495 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1496    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1497    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1498
1499 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1500
1501 static void
1502 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1503                            gfc_symbol * sym, gfc_component * c,
1504                            tree base_addr)
1505 {
1506   gfc_typespec * ts = NULL;
1507   gfc_array_spec * as = NULL;
1508   tree addr_expr = NULL;
1509   tree dt = NULL;
1510   tree string;
1511   tree tmp;
1512   tree dtype;
1513   tree dt_parm_addr;
1514   int n_dim; 
1515   int itype;
1516   int rank = 0;
1517
1518   gcc_assert (sym || c);
1519
1520   /* Build the namelist object name.  */
1521
1522   string = gfc_build_cstring_const (var_name);
1523   string = gfc_build_addr_expr (pchar_type_node, string);
1524
1525   /* Build ts, as and data address using symbol or component.  */
1526
1527   ts = (sym) ? &sym->ts : &c->ts;
1528   as = (sym) ? sym->as : c->as;
1529
1530   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1531
1532   if (as)
1533     rank = as->rank;
1534
1535   if (rank)
1536     {
1537       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1538       dtype = gfc_get_dtype (dt);
1539     }
1540   else
1541     {
1542       itype = GFC_DTYPE_UNKNOWN;
1543
1544       switch (ts->type)
1545
1546         {
1547         case BT_INTEGER:
1548           itype = GFC_DTYPE_INTEGER;
1549           break;
1550         case BT_LOGICAL:
1551           itype = GFC_DTYPE_LOGICAL;
1552           break;
1553         case BT_REAL:
1554           itype = GFC_DTYPE_REAL;
1555           break;
1556         case BT_COMPLEX:
1557           itype = GFC_DTYPE_COMPLEX;
1558         break;
1559         case BT_DERIVED:
1560           itype = GFC_DTYPE_DERIVED;
1561           break;
1562         case BT_CHARACTER:
1563           itype = GFC_DTYPE_CHARACTER;
1564           break;
1565         default:
1566           gcc_unreachable ();
1567         }
1568
1569       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1570     }
1571
1572   /* Build up the arguments for the transfer call.
1573      The call for the scalar part transfers:
1574      (address, name, type, kind or string_length, dtype)  */
1575
1576   dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1577
1578   if (ts->type == BT_CHARACTER)
1579     tmp = ts->u.cl->backend_decl;
1580   else
1581     tmp = build_int_cst (gfc_charlen_type_node, 0);
1582   tmp = build_call_expr_loc (input_location,
1583                          iocall[IOCALL_SET_NML_VAL], 6,
1584                          dt_parm_addr, addr_expr, string,
1585                          IARG (ts->kind), tmp, dtype);
1586   gfc_add_expr_to_block (block, tmp);
1587
1588   /* If the object is an array, transfer rank times:
1589      (null pointer, name, stride, lbound, ubound)  */
1590
1591   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1592     {
1593       tmp = build_call_expr_loc (input_location,
1594                              iocall[IOCALL_SET_NML_VAL_DIM], 5,
1595                              dt_parm_addr,
1596                              IARG (n_dim),
1597                              GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1598                              GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1599                              GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1600       gfc_add_expr_to_block (block, tmp);
1601     }
1602
1603   if (ts->type == BT_DERIVED)
1604     {
1605       gfc_component *cmp;
1606
1607       /* Provide the RECORD_TYPE to build component references.  */
1608
1609       tree expr = build_fold_indirect_ref_loc (input_location,
1610                                            addr_expr);
1611
1612       for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1613         {
1614           char *full_name = nml_full_name (var_name, cmp->name);
1615           transfer_namelist_element (block,
1616                                      full_name,
1617                                      NULL, cmp, expr);
1618           gfc_free (full_name);
1619         }
1620     }
1621 }
1622
1623 #undef IARG
1624
1625 /* Create a data transfer statement.  Not all of the fields are valid
1626    for both reading and writing, but improper use has been filtered
1627    out by now.  */
1628
1629 static tree
1630 build_dt (tree function, gfc_code * code)
1631 {
1632   stmtblock_t block, post_block, post_end_block, post_iu_block;
1633   gfc_dt *dt;
1634   tree tmp, var;
1635   gfc_expr *nmlname;
1636   gfc_namelist *nml;
1637   unsigned int mask = 0;
1638
1639   gfc_start_block (&block);
1640   gfc_init_block (&post_block);
1641   gfc_init_block (&post_end_block);
1642   gfc_init_block (&post_iu_block);
1643
1644   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1645
1646   set_error_locus (&block, var, &code->loc);
1647
1648   if (last_dt == IOLENGTH)
1649     {
1650       gfc_inquire *inq;
1651
1652       inq = code->ext.inquire;
1653
1654       /* First check that preconditions are met.  */
1655       gcc_assert (inq != NULL);
1656       gcc_assert (inq->iolength != NULL);
1657
1658       /* Connect to the iolength variable.  */
1659       mask |= set_parameter_ref (&block, &post_end_block, var,
1660                                  IOPARM_dt_iolength, inq->iolength);
1661       dt = NULL;
1662     }
1663   else
1664     {
1665       dt = code->ext.dt;
1666       gcc_assert (dt != NULL);
1667     }
1668
1669   if (dt && dt->io_unit)
1670     {
1671       if (dt->io_unit->ts.type == BT_CHARACTER)
1672         {
1673           mask |= set_internal_unit (&block, &post_iu_block,
1674                                      var, dt->io_unit);
1675           set_parameter_const (&block, var, IOPARM_common_unit, 0);
1676         }
1677     }
1678   else
1679     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1680
1681   if (dt)
1682     {
1683       if (dt->iomsg)
1684         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1685                             dt->iomsg);
1686
1687       if (dt->iostat)
1688         mask |= set_parameter_ref (&block, &post_end_block, var,
1689                                    IOPARM_common_iostat, dt->iostat);
1690
1691       if (dt->err)
1692         mask |= IOPARM_common_err;
1693
1694       if (dt->eor)
1695         mask |= IOPARM_common_eor;
1696
1697       if (dt->end)
1698         mask |= IOPARM_common_end;
1699
1700       if (dt->id)
1701         mask |= set_parameter_ref (&block, &post_end_block, var,
1702                                    IOPARM_dt_id, dt->id);
1703
1704       if (dt->pos)
1705         mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1706
1707       if (dt->asynchronous)
1708         mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1709                             dt->asynchronous);
1710
1711       if (dt->blank)
1712         mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1713                             dt->blank);
1714
1715       if (dt->decimal)
1716         mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1717                             dt->decimal);
1718
1719       if (dt->delim)
1720         mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1721                             dt->delim);
1722
1723       if (dt->pad)
1724         mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1725                             dt->pad);
1726
1727       if (dt->round)
1728         mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1729                             dt->round);
1730
1731       if (dt->sign)
1732         mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1733                             dt->sign);
1734
1735       if (dt->rec)
1736         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1737
1738       if (dt->advance)
1739         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1740                             dt->advance);
1741
1742       if (dt->format_expr)
1743         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1744                             dt->format_expr);
1745
1746       if (dt->format_label)
1747         {
1748           if (dt->format_label == &format_asterisk)
1749             mask |= IOPARM_dt_list_format;
1750           else
1751             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1752                                 dt->format_label->format);
1753         }
1754
1755       if (dt->size)
1756         mask |= set_parameter_ref (&block, &post_end_block, var,
1757                                    IOPARM_dt_size, dt->size);
1758
1759       if (dt->namelist)
1760         {
1761           if (dt->format_expr || dt->format_label)
1762             gfc_internal_error ("build_dt: format with namelist");
1763
1764           nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1765                                             dt->namelist->name,
1766                                             strlen (dt->namelist->name));
1767
1768           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1769                               nmlname);
1770
1771           if (last_dt == READ)
1772             mask |= IOPARM_dt_namelist_read_mode;
1773
1774           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1775
1776           dt_parm = var;
1777
1778           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1779             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1780                                        NULL, NULL);
1781         }
1782       else
1783         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1784
1785       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1786         set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1787     }
1788   else
1789     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1790
1791   tmp = gfc_build_addr_expr (NULL_TREE, var);
1792   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1793                          function, 1, tmp);
1794   gfc_add_expr_to_block (&block, tmp);
1795
1796   gfc_add_block_to_block (&block, &post_block);
1797
1798   dt_parm = var;
1799   dt_post_end_block = &post_end_block;
1800
1801   /* Set implied do loop exit condition.  */
1802   if (last_dt == READ || last_dt == WRITE)
1803     {
1804       gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1805
1806       tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
1807                          dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
1808       tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
1809                           tmp, p->field, NULL_TREE);
1810       tmp = fold_build2 (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"