OSDN Git Service

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