1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook
6 This file is part of GCC.
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
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
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/>. */
25 #include "coretypes.h"
27 #include "tree-gimple.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
38 /* Members of the ioparm structure. */
66 typedef struct gfc_st_parameter_field GTY(())
70 enum ioparam_type param_type;
71 enum iofield_type type;
75 gfc_st_parameter_field;
77 typedef struct gfc_st_parameter GTY(())
86 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
92 static GTY(()) gfc_st_parameter st_parameter[] =
102 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
104 #define IOPARM(param_type, name, mask, type) \
105 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
106 #include "ioparm.def"
108 { NULL, 0, 0, 0, NULL, NULL }
111 /* Library I/O subroutines */
129 IOCALL_IOLENGTH_DONE,
135 IOCALL_SET_NML_VAL_DIM,
139 static GTY(()) tree iocall[IOCALL_NUM];
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;
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;
152 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
155 gfc_st_parameter_field *p;
158 tree t = make_node (RECORD_TYPE);
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,
165 TYPE_NAME (t) = get_identifier (name);
167 for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
168 if (p->param_type == ptype)
171 case IOPARM_type_int4:
172 case IOPARM_type_intio:
173 case IOPARM_type_pint4:
174 case IOPARM_type_pintio:
175 case IOPARM_type_parray:
176 case IOPARM_type_pchar:
177 case IOPARM_type_pad:
178 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
179 get_identifier (p->name),
182 case IOPARM_type_char1:
183 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
184 get_identifier (p->name),
187 case IOPARM_type_char2:
188 len = strlen (p->name);
189 gcc_assert (len <= sizeof (name) - sizeof ("_len"));
190 memcpy (name, p->name, len);
191 memcpy (name + len, "_len", sizeof ("_len"));
192 p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
193 get_identifier (name),
194 gfc_charlen_type_node);
195 if (p->type == IOPARM_type_char2)
196 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
197 get_identifier (p->name),
200 case IOPARM_type_common:
202 = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
203 get_identifier (p->name),
204 st_parameter[IOPARM_ptype_common].type);
206 case IOPARM_type_num:
211 st_parameter[ptype].type = t;
215 /* Build code to test an error condition and call generate_error if needed.
216 Note: This builds calls to generate_error in the runtime library function.
217 The function generate_error is dependent on certain parameters in the
218 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
219 Therefore, the code to set these flags must be generated before
220 this function is used. */
223 gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
224 const char * msgid, stmtblock_t * pblock)
229 tree arg1, arg2, arg3;
232 if (integer_zerop (cond))
235 /* The code to generate the error. */
236 gfc_start_block (&block);
238 arg1 = build_fold_addr_expr (var);
240 arg2 = build_int_cst (integer_type_node, error_code),
242 asprintf (&message, "%s", _(msgid));
243 arg3 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
246 tmp = build_call_expr (gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
248 gfc_add_expr_to_block (&block, tmp);
250 body = gfc_finish_block (&block);
252 if (integer_onep (cond))
254 gfc_add_expr_to_block (pblock, body);
258 /* Tell the compiler that this isn't likely. */
259 cond = fold_convert (long_integer_type_node, cond);
260 tmp = build_int_cst (long_integer_type_node, 0);
261 cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
262 cond = fold_convert (boolean_type_node, cond);
264 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
265 gfc_add_expr_to_block (pblock, tmp);
270 /* Create function decls for IO library functions. */
273 gfc_build_io_library_fndecls (void)
275 tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
276 tree gfc_intio_type_node;
277 tree parm_type, dt_parm_type;
278 HOST_WIDE_INT pad_size;
279 enum ioparam_type ptype;
281 types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
282 types[IOPARM_type_intio] = gfc_intio_type_node
283 = gfc_get_int_type (gfc_intio_kind);
284 types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
285 types[IOPARM_type_pintio]
286 = build_pointer_type (gfc_intio_type_node);
287 types[IOPARM_type_parray] = pchar_type_node;
288 types[IOPARM_type_pchar] = pchar_type_node;
289 pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
290 pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
291 pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
292 types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
294 /* pad actually contains pointers and integers so it needs to have an
295 alignment that is at least as large as the needed alignment for those
296 types. See the st_parameter_dt structure in libgfortran/io/io.h for
297 what really goes into this space. */
298 TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
299 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind)));
301 for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
302 gfc_build_st_parameter (ptype, types);
304 /* Define the transfer functions. */
306 dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
308 iocall[IOCALL_X_INTEGER] =
309 gfc_build_library_function_decl (get_identifier
310 (PREFIX("transfer_integer")),
311 void_type_node, 3, dt_parm_type,
312 pvoid_type_node, gfc_int4_type_node);
314 iocall[IOCALL_X_LOGICAL] =
315 gfc_build_library_function_decl (get_identifier
316 (PREFIX("transfer_logical")),
317 void_type_node, 3, dt_parm_type,
318 pvoid_type_node, gfc_int4_type_node);
320 iocall[IOCALL_X_CHARACTER] =
321 gfc_build_library_function_decl (get_identifier
322 (PREFIX("transfer_character")),
323 void_type_node, 3, dt_parm_type,
324 pvoid_type_node, gfc_int4_type_node);
326 iocall[IOCALL_X_REAL] =
327 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
328 void_type_node, 3, dt_parm_type,
329 pvoid_type_node, gfc_int4_type_node);
331 iocall[IOCALL_X_COMPLEX] =
332 gfc_build_library_function_decl (get_identifier
333 (PREFIX("transfer_complex")),
334 void_type_node, 3, dt_parm_type,
335 pvoid_type_node, gfc_int4_type_node);
337 iocall[IOCALL_X_ARRAY] =
338 gfc_build_library_function_decl (get_identifier
339 (PREFIX("transfer_array")),
340 void_type_node, 4, dt_parm_type,
341 pvoid_type_node, integer_type_node,
342 gfc_charlen_type_node);
344 /* Library entry points */
346 iocall[IOCALL_READ] =
347 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
348 void_type_node, 1, dt_parm_type);
350 iocall[IOCALL_WRITE] =
351 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
352 void_type_node, 1, dt_parm_type);
354 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
355 iocall[IOCALL_OPEN] =
356 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
357 void_type_node, 1, parm_type);
360 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
361 iocall[IOCALL_CLOSE] =
362 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
363 void_type_node, 1, parm_type);
365 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
366 iocall[IOCALL_INQUIRE] =
367 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
368 gfc_int4_type_node, 1, parm_type);
370 iocall[IOCALL_IOLENGTH] =
371 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
372 void_type_node, 1, dt_parm_type);
374 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
375 iocall[IOCALL_REWIND] =
376 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
377 gfc_int4_type_node, 1, parm_type);
379 iocall[IOCALL_BACKSPACE] =
380 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
381 gfc_int4_type_node, 1, parm_type);
383 iocall[IOCALL_ENDFILE] =
384 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
385 gfc_int4_type_node, 1, parm_type);
387 iocall[IOCALL_FLUSH] =
388 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
389 gfc_int4_type_node, 1, parm_type);
391 /* Library helpers */
393 iocall[IOCALL_READ_DONE] =
394 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
395 gfc_int4_type_node, 1, dt_parm_type);
397 iocall[IOCALL_WRITE_DONE] =
398 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
399 gfc_int4_type_node, 1, dt_parm_type);
401 iocall[IOCALL_IOLENGTH_DONE] =
402 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
403 gfc_int4_type_node, 1, dt_parm_type);
406 iocall[IOCALL_SET_NML_VAL] =
407 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
408 void_type_node, 6, dt_parm_type,
409 pvoid_type_node, pvoid_type_node,
410 gfc_int4_type_node, gfc_charlen_type_node,
413 iocall[IOCALL_SET_NML_VAL_DIM] =
414 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
415 void_type_node, 5, dt_parm_type,
416 gfc_int4_type_node, gfc_array_index_type,
417 gfc_array_index_type, gfc_array_index_type);
421 /* Generate code to store an integer constant into the
422 st_parameter_XXX structure. */
425 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
429 gfc_st_parameter_field *p = &st_parameter_field[type];
431 if (p->param_type == IOPARM_ptype_common)
432 var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
433 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
434 tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
436 gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
441 /* Generate code to store a non-string I/O parameter into the
442 st_parameter_XXX structure. This is a pass by value. */
445 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
450 gfc_st_parameter_field *p = &st_parameter_field[type];
451 tree dest_type = TREE_TYPE (p->field);
453 gfc_init_se (&se, NULL);
454 gfc_conv_expr_val (&se, e);
456 /* If we're storing a UNIT number, we need to check it first. */
457 if (type == IOPARM_common_unit && e->ts.kind != 4)
460 ioerror_codes bad_unit;
463 bad_unit = IOERROR_BAD_UNIT;
465 /* Don't evaluate the UNIT number multiple times. */
466 se.expr = gfc_evaluate_now (se.expr, &se.pre);
468 /* UNIT numbers should be nonnegative. */
469 cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
470 build_int_cst (TREE_TYPE (se.expr),0));
471 gfc_trans_io_runtime_check (cond, var, bad_unit,
472 "Negative unit number in I/O statement",
475 /* UNIT numbers should be less than the max. */
476 i = gfc_validate_kind (BT_INTEGER, 4, false);
477 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
478 cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
479 fold_convert (TREE_TYPE (se.expr), max));
480 gfc_trans_io_runtime_check (cond, var, bad_unit,
481 "Unit number in I/O statement too large",
486 se.expr = convert (dest_type, se.expr);
487 gfc_add_block_to_block (block, &se.pre);
489 if (p->param_type == IOPARM_ptype_common)
490 var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
491 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
493 tmp = build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
494 gfc_add_modify_expr (block, tmp, se.expr);
499 /* Generate code to store a non-string I/O parameter into the
500 st_parameter_XXX structure. This is pass by reference. */
503 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
504 tree var, enum iofield type, gfc_expr *e)
508 gfc_st_parameter_field *p = &st_parameter_field[type];
510 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
511 gfc_init_se (&se, NULL);
512 gfc_conv_expr_lhs (&se, e);
514 gfc_add_block_to_block (block, &se.pre);
516 if (TYPE_MODE (TREE_TYPE (se.expr))
517 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
519 addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr));
521 /* If this is for the iostat variable initialize the
522 user variable to IOERROR_OK which is zero. */
523 if (type == IOPARM_common_iostat)
527 gfc_add_modify_expr (block, se.expr,
528 build_int_cst (TREE_TYPE (se.expr), ok));
533 /* The type used by the library has different size
534 from the type of the variable supplied by the user.
535 Need to use a temporary. */
536 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
537 st_parameter_field[type].name);
539 /* If this is for the iostat variable, initialize the
540 user variable to IOERROR_OK which is zero. */
541 if (type == IOPARM_common_iostat)
545 gfc_add_modify_expr (block, tmpvar,
546 build_int_cst (TREE_TYPE (tmpvar), ok));
549 addr = build_fold_addr_expr (tmpvar);
550 /* After the I/O operation, we set the variable from the temporary. */
551 tmp = convert (TREE_TYPE (se.expr), tmpvar);
552 gfc_add_modify_expr (postblock, se.expr, tmp);
555 if (p->param_type == IOPARM_ptype_common)
556 var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
557 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
558 tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
560 gfc_add_modify_expr (block, tmp, addr);
564 /* Given an array expr, find its address and length to get a string. If the
565 array is full, the string's address is the address of array's first element
566 and the length is the size of the whole array. If it is an element, the
567 string's address is the element's address and the length is the rest size of
572 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
581 sym = e->symtree->n.sym;
582 rank = sym->as->rank - 1;
584 if (e->ref->u.ar.type == AR_FULL)
586 se->expr = gfc_get_symbol_decl (sym);
587 se->expr = gfc_conv_array_data (se->expr);
591 gfc_conv_expr (se, e);
594 array = sym->backend_decl;
595 type = TREE_TYPE (array);
597 if (GFC_ARRAY_TYPE_P (type))
598 size = GFC_TYPE_ARRAY_SIZE (type);
601 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
602 size = gfc_conv_array_stride (array, rank);
603 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
604 gfc_conv_array_ubound (array, rank),
605 gfc_conv_array_lbound (array, rank));
606 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
608 size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
613 /* If it is an element, we need the its address and size of the rest. */
614 if (e->ref->u.ar.type == AR_ELEMENT)
616 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
617 TREE_OPERAND (se->expr, 1));
618 se->expr = build_fold_addr_expr (se->expr);
621 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
622 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
623 fold_convert (gfc_array_index_type, tmp));
625 se->string_length = fold_convert (gfc_charlen_type_node, size);
629 /* Generate code to store a string and its length into the
630 st_parameter_XXX structure. */
633 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
634 enum iofield type, gfc_expr * e)
640 gfc_st_parameter_field *p = &st_parameter_field[type];
642 gfc_init_se (&se, NULL);
644 if (p->param_type == IOPARM_ptype_common)
645 var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
646 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
647 io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
649 len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
652 /* Integer variable assigned a format label. */
653 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
657 gfc_conv_label_variable (&se, e);
658 tmp = GFC_DECL_STRING_LEN (se.expr);
659 tmp = fold_build2 (LT_EXPR, boolean_type_node,
660 tmp, build_int_cst (TREE_TYPE (tmp), 0));
662 asprintf(&msg, "Label assigned to variable '%s' is not a format label",
664 gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where);
667 gfc_add_modify_expr (&se.pre, io,
668 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
669 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
673 /* General character. */
674 if (e->ts.type == BT_CHARACTER && e->rank == 0)
675 gfc_conv_expr (&se, e);
676 /* Array assigned Hollerith constant or character array. */
677 else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
678 gfc_convert_array_to_string (&se, e);
682 gfc_conv_string_parameter (&se);
683 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
684 gfc_add_modify_expr (&se.pre, len, se.string_length);
687 gfc_add_block_to_block (block, &se.pre);
688 gfc_add_block_to_block (postblock, &se.post);
693 /* Generate code to store the character (array) and the character length
694 for an internal unit. */
697 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
698 tree var, gfc_expr * e)
705 gfc_st_parameter_field *p;
708 gfc_init_se (&se, NULL);
710 p = &st_parameter_field[IOPARM_dt_internal_unit];
712 io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
714 len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
716 p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
717 desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
720 gcc_assert (e->ts.type == BT_CHARACTER);
722 /* Character scalars. */
725 gfc_conv_expr (&se, e);
726 gfc_conv_string_parameter (&se);
728 se.expr = build_int_cst (pchar_type_node, 0);
731 /* Character array. */
732 else if (e->rank > 0)
734 se.ss = gfc_walk_expr (e);
736 if (is_aliased_array (e))
738 /* Use a temporary for components of arrays of derived types
739 or substring array references. */
740 gfc_conv_aliased_arg (&se, e, 0,
741 last_dt == READ ? INTENT_IN : INTENT_OUT);
742 tmp = build_fold_indirect_ref (se.expr);
743 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
744 tmp = gfc_conv_descriptor_data_get (tmp);
748 /* Return the data pointer and rank from the descriptor. */
749 gfc_conv_expr_descriptor (&se, e, se.ss);
750 tmp = gfc_conv_descriptor_data_get (se.expr);
751 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
757 /* The cast is needed for character substrings and the descriptor
759 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
760 gfc_add_modify_expr (&se.pre, len,
761 fold_convert (TREE_TYPE (len), se.string_length));
762 gfc_add_modify_expr (&se.pre, desc, se.expr);
764 gfc_add_block_to_block (block, &se.pre);
765 gfc_add_block_to_block (post_block, &se.post);
769 /* Add a case to a IO-result switch. */
772 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
777 return; /* No label, no case */
779 value = build_int_cst (NULL_TREE, label_value);
781 /* Make a backend label for this case. */
782 tmp = gfc_build_label_decl (NULL_TREE);
784 /* And the case itself. */
785 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
786 gfc_add_expr_to_block (body, tmp);
788 /* Jump to the label. */
789 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
790 gfc_add_expr_to_block (body, tmp);
794 /* Generate a switch statement that branches to the correct I/O
795 result label. The last statement of an I/O call stores the
796 result into a variable because there is often cleanup that
797 must be done before the switch, so a temporary would have to
798 be created anyway. */
801 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
802 gfc_st_label * end_label, gfc_st_label * eor_label)
806 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
808 /* If no labels are specified, ignore the result instead
809 of building an empty switch. */
810 if (err_label == NULL
812 && eor_label == NULL)
815 /* Build a switch statement. */
816 gfc_start_block (&body);
818 /* The label values here must be the same as the values
819 in the library_return enum in the runtime library */
820 add_case (1, err_label, &body);
821 add_case (2, end_label, &body);
822 add_case (3, eor_label, &body);
824 tmp = gfc_finish_block (&body);
826 var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
827 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
828 rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
830 rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
831 build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
833 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
835 gfc_add_expr_to_block (block, tmp);
839 /* Store the current file and line number to variables so that if a
840 library call goes awry, we can tell the user where the problem is. */
843 set_error_locus (stmtblock_t * block, tree var, locus * where)
846 tree str, locus_file;
848 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
850 locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
851 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
852 locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
853 p->field, NULL_TREE);
855 str = gfc_build_cstring_const (f->filename);
857 str = gfc_build_addr_expr (pchar_type_node, str);
858 gfc_add_modify_expr (block, locus_file, str);
860 #ifdef USE_MAPPED_LOCATION
861 line = LOCATION_LINE (where->lb->location);
863 line = where->lb->linenum;
865 set_parameter_const (block, var, IOPARM_common_line, line);
869 /* Translate an OPEN statement. */
872 gfc_trans_open (gfc_code * code)
874 stmtblock_t block, post_block;
877 unsigned int mask = 0;
879 gfc_start_block (&block);
880 gfc_init_block (&post_block);
882 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
884 set_error_locus (&block, var, &code->loc);
888 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
892 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
896 mask |= IOPARM_common_err;
899 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
902 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
906 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
910 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
913 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
916 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
920 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
924 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
928 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
932 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
935 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
938 set_parameter_const (&block, var, IOPARM_common_flags, mask);
941 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
943 set_parameter_const (&block, var, IOPARM_common_unit, 0);
945 tmp = build_fold_addr_expr (var);
946 tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
947 gfc_add_expr_to_block (&block, tmp);
949 gfc_add_block_to_block (&block, &post_block);
951 io_result (&block, var, p->err, NULL, NULL);
953 return gfc_finish_block (&block);
957 /* Translate a CLOSE statement. */
960 gfc_trans_close (gfc_code * code)
962 stmtblock_t block, post_block;
965 unsigned int mask = 0;
967 gfc_start_block (&block);
968 gfc_init_block (&post_block);
970 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
972 set_error_locus (&block, var, &code->loc);
976 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
980 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
984 mask |= IOPARM_common_err;
987 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
990 set_parameter_const (&block, var, IOPARM_common_flags, mask);
993 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
995 set_parameter_const (&block, var, IOPARM_common_unit, 0);
997 tmp = build_fold_addr_expr (var);
998 tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp);
999 gfc_add_expr_to_block (&block, tmp);
1001 gfc_add_block_to_block (&block, &post_block);
1003 io_result (&block, var, p->err, NULL, NULL);
1005 return gfc_finish_block (&block);
1009 /* Common subroutine for building a file positioning statement. */
1012 build_filepos (tree function, gfc_code * code)
1014 stmtblock_t block, post_block;
1017 unsigned int mask = 0;
1019 p = code->ext.filepos;
1021 gfc_start_block (&block);
1022 gfc_init_block (&post_block);
1024 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1027 set_error_locus (&block, var, &code->loc);
1030 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1034 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1038 mask |= IOPARM_common_err;
1040 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1043 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1045 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1047 tmp = build_fold_addr_expr (var);
1048 tmp = build_call_expr (function, 1, tmp);
1049 gfc_add_expr_to_block (&block, tmp);
1051 gfc_add_block_to_block (&block, &post_block);
1053 io_result (&block, var, p->err, NULL, NULL);
1055 return gfc_finish_block (&block);
1059 /* Translate a BACKSPACE statement. */
1062 gfc_trans_backspace (gfc_code * code)
1064 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1068 /* Translate an ENDFILE statement. */
1071 gfc_trans_endfile (gfc_code * code)
1073 return build_filepos (iocall[IOCALL_ENDFILE], code);
1077 /* Translate a REWIND statement. */
1080 gfc_trans_rewind (gfc_code * code)
1082 return build_filepos (iocall[IOCALL_REWIND], code);
1086 /* Translate a FLUSH statement. */
1089 gfc_trans_flush (gfc_code * code)
1091 return build_filepos (iocall[IOCALL_FLUSH], code);
1095 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1098 gfc_trans_inquire (gfc_code * code)
1100 stmtblock_t block, post_block;
1103 unsigned int mask = 0;
1105 gfc_start_block (&block);
1106 gfc_init_block (&post_block);
1108 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1111 set_error_locus (&block, var, &code->loc);
1112 p = code->ext.inquire;
1115 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1119 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1123 mask |= IOPARM_common_err;
1126 if (p->unit && p->file)
1127 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1130 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1134 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1138 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1142 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1146 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1150 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1154 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1158 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1162 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1166 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1170 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1174 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1178 mask |= set_parameter_ref (&block, &post_block, var,
1179 IOPARM_inquire_recl_out, p->recl);
1182 mask |= set_parameter_ref (&block, &post_block, var,
1183 IOPARM_inquire_nextrec, p->nextrec);
1186 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1190 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1194 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1198 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1202 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1206 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1210 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1214 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1218 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1222 mask |= set_parameter_ref (&block, &post_block, var,
1223 IOPARM_inquire_strm_pos_out, p->strm_pos);
1225 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1228 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1230 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1232 tmp = build_fold_addr_expr (var);
1233 tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp);
1234 gfc_add_expr_to_block (&block, tmp);
1236 gfc_add_block_to_block (&block, &post_block);
1238 io_result (&block, var, p->err, NULL, NULL);
1240 return gfc_finish_block (&block);
1244 gfc_new_nml_name_expr (const char * name)
1246 gfc_expr * nml_name;
1248 nml_name = gfc_get_expr();
1249 nml_name->ref = NULL;
1250 nml_name->expr_type = EXPR_CONSTANT;
1251 nml_name->ts.kind = gfc_default_character_kind;
1252 nml_name->ts.type = BT_CHARACTER;
1253 nml_name->value.character.length = strlen(name);
1254 nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
1255 strcpy (nml_name->value.character.string, name);
1260 /* nml_full_name builds up the fully qualified name of a
1261 derived type component. */
1264 nml_full_name (const char* var_name, const char* cmp_name)
1266 int full_name_length;
1269 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1270 full_name = (char*)gfc_getmem (full_name_length + 1);
1271 strcpy (full_name, var_name);
1272 full_name = strcat (full_name, "%");
1273 full_name = strcat (full_name, cmp_name);
1277 /* nml_get_addr_expr builds an address expression from the
1278 gfc_symbol or gfc_component backend_decl's. An offset is
1279 provided so that the address of an element of an array of
1280 derived types is returned. This is used in the runtime to
1281 determine that span of the derived type. */
1284 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1287 tree decl = NULL_TREE;
1291 int dummy_arg_flagged;
1295 sym->attr.referenced = 1;
1296 decl = gfc_get_symbol_decl (sym);
1298 /* If this is the enclosing function declaration, use
1299 the fake result instead. */
1300 if (decl == current_function_decl)
1301 decl = gfc_get_fake_result_decl (sym, 0);
1302 else if (decl == DECL_CONTEXT (current_function_decl))
1303 decl = gfc_get_fake_result_decl (sym, 1);
1306 decl = c->backend_decl;
1308 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1309 || TREE_CODE (decl) == VAR_DECL
1310 || TREE_CODE (decl) == PARM_DECL)
1311 || TREE_CODE (decl) == COMPONENT_REF));
1315 /* Build indirect reference, if dummy argument. */
1317 dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1319 itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
1321 /* If an array, set flag and use indirect ref. if built. */
1323 array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1324 && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1329 /* Treat the component of a derived type, using base_addr for
1330 the derived type. */
1332 if (TREE_CODE (decl) == FIELD_DECL)
1333 tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
1334 base_addr, tmp, NULL_TREE);
1336 /* If we have a derived type component, a reference to the first
1337 element of the array is built. This is done so that base_addr,
1338 used in the build of the component reference, always points to
1342 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
1344 /* Now build the address expression. */
1346 tmp = build_fold_addr_expr (tmp);
1348 /* If scalar dummy, resolve indirect reference now. */
1350 if (dummy_arg_flagged && !array_flagged)
1351 tmp = build_fold_indirect_ref (tmp);
1353 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1358 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1359 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1360 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1362 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1365 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1366 gfc_symbol * sym, gfc_component * c,
1369 gfc_typespec * ts = NULL;
1370 gfc_array_spec * as = NULL;
1371 tree addr_expr = NULL;
1381 gcc_assert (sym || c);
1383 /* Build the namelist object name. */
1385 string = gfc_build_cstring_const (var_name);
1386 string = gfc_build_addr_expr (pchar_type_node, string);
1388 /* Build ts, as and data address using symbol or component. */
1390 ts = (sym) ? &sym->ts : &c->ts;
1391 as = (sym) ? sym->as : c->as;
1393 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1400 dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1401 dtype = gfc_get_dtype (dt);
1405 itype = GFC_DTYPE_UNKNOWN;
1411 itype = GFC_DTYPE_INTEGER;
1414 itype = GFC_DTYPE_LOGICAL;
1417 itype = GFC_DTYPE_REAL;
1420 itype = GFC_DTYPE_COMPLEX;
1423 itype = GFC_DTYPE_DERIVED;
1426 itype = GFC_DTYPE_CHARACTER;
1432 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1435 /* Build up the arguments for the transfer call.
1436 The call for the scalar part transfers:
1437 (address, name, type, kind or string_length, dtype) */
1439 dt_parm_addr = build_fold_addr_expr (dt_parm);
1441 if (ts->type == BT_CHARACTER)
1442 tmp = ts->cl->backend_decl;
1444 tmp = build_int_cst (gfc_charlen_type_node, 0);
1445 tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6,
1446 dt_parm_addr, addr_expr, string,
1447 IARG (ts->kind), tmp, dtype);
1448 gfc_add_expr_to_block (block, tmp);
1450 /* If the object is an array, transfer rank times:
1451 (null pointer, name, stride, lbound, ubound) */
1453 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1455 tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5,
1458 GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1459 GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1460 GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1461 gfc_add_expr_to_block (block, tmp);
1464 if (ts->type == BT_DERIVED)
1468 /* Provide the RECORD_TYPE to build component references. */
1470 tree expr = build_fold_indirect_ref (addr_expr);
1472 for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1474 char *full_name = nml_full_name (var_name, cmp->name);
1475 transfer_namelist_element (block,
1478 gfc_free (full_name);
1485 /* Create a data transfer statement. Not all of the fields are valid
1486 for both reading and writing, but improper use has been filtered
1490 build_dt (tree function, gfc_code * code)
1492 stmtblock_t block, post_block, post_end_block, post_iu_block;
1497 unsigned int mask = 0;
1499 gfc_start_block (&block);
1500 gfc_init_block (&post_block);
1501 gfc_init_block (&post_end_block);
1502 gfc_init_block (&post_iu_block);
1504 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1506 set_error_locus (&block, var, &code->loc);
1508 if (last_dt == IOLENGTH)
1512 inq = code->ext.inquire;
1514 /* First check that preconditions are met. */
1515 gcc_assert (inq != NULL);
1516 gcc_assert (inq->iolength != NULL);
1518 /* Connect to the iolength variable. */
1519 mask |= set_parameter_ref (&block, &post_end_block, var,
1520 IOPARM_dt_iolength, inq->iolength);
1526 gcc_assert (dt != NULL);
1529 if (dt && dt->io_unit)
1531 if (dt->io_unit->ts.type == BT_CHARACTER)
1533 mask |= set_internal_unit (&block, &post_iu_block,
1535 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1539 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1544 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1548 mask |= set_parameter_ref (&block, &post_end_block, var,
1549 IOPARM_common_iostat, dt->iostat);
1552 mask |= IOPARM_common_err;
1555 mask |= IOPARM_common_eor;
1558 mask |= IOPARM_common_end;
1561 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1564 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1567 if (dt->format_expr)
1568 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1571 if (dt->format_label)
1573 if (dt->format_label == &format_asterisk)
1574 mask |= IOPARM_dt_list_format;
1576 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1577 dt->format_label->format);
1581 mask |= set_parameter_ref (&block, &post_end_block, var,
1582 IOPARM_dt_size, dt->size);
1586 if (dt->format_expr || dt->format_label)
1587 gfc_internal_error ("build_dt: format with namelist");
1589 nmlname = gfc_new_nml_name_expr (dt->namelist->name);
1591 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1594 if (last_dt == READ)
1595 mask |= IOPARM_dt_namelist_read_mode;
1597 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1601 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1602 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1606 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1608 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1609 set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1612 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1614 tmp = build_fold_addr_expr (var);
1615 tmp = build_call_expr (function, 1, tmp);
1616 gfc_add_expr_to_block (&block, tmp);
1618 gfc_add_block_to_block (&block, &post_block);
1621 dt_post_end_block = &post_end_block;
1623 gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
1625 gfc_add_block_to_block (&block, &post_iu_block);
1628 dt_post_end_block = NULL;
1630 return gfc_finish_block (&block);
1634 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1635 this as a third sort of data transfer statement, except that
1636 lengths are summed instead of actually transferring any data. */
1639 gfc_trans_iolength (gfc_code * code)
1642 return build_dt (iocall[IOCALL_IOLENGTH], code);
1646 /* Translate a READ statement. */
1649 gfc_trans_read (gfc_code * code)
1652 return build_dt (iocall[IOCALL_READ], code);
1656 /* Translate a WRITE statement */
1659 gfc_trans_write (gfc_code * code)
1662 return build_dt (iocall[IOCALL_WRITE], code);
1666 /* Finish a data transfer statement. */
1669 gfc_trans_dt_end (gfc_code * code)
1674 gfc_init_block (&block);
1679 function = iocall[IOCALL_READ_DONE];
1683 function = iocall[IOCALL_WRITE_DONE];
1687 function = iocall[IOCALL_IOLENGTH_DONE];
1694 tmp = build_fold_addr_expr (dt_parm);
1695 tmp = build_call_expr (function, 1, tmp);
1696 gfc_add_expr_to_block (&block, tmp);
1697 gfc_add_block_to_block (&block, dt_post_end_block);
1698 gfc_init_block (dt_post_end_block);
1700 if (last_dt != IOLENGTH)
1702 gcc_assert (code->ext.dt != NULL);
1703 io_result (&block, dt_parm, code->ext.dt->err,
1704 code->ext.dt->end, code->ext.dt->eor);
1707 return gfc_finish_block (&block);
1711 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1713 /* Given an array field in a derived type variable, generate the code
1714 for the loop that iterates over array elements, and the code that
1715 accesses those array elements. Use transfer_expr to generate code
1716 for transferring that element. Because elements may also be
1717 derived types, transfer_expr and transfer_array_component are mutually
1721 transfer_array_component (tree expr, gfc_component * cm)
1731 gfc_start_block (&block);
1732 gfc_init_se (&se, NULL);
1734 /* Create and initialize Scalarization Status. Unlike in
1735 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1736 care of this task, because we don't have a gfc_expr at hand.
1737 Build one manually, as in gfc_trans_subarray_assign. */
1740 ss->type = GFC_SS_COMPONENT;
1742 ss->shape = gfc_get_shape (cm->as->rank);
1743 ss->next = gfc_ss_terminator;
1744 ss->data.info.dimen = cm->as->rank;
1745 ss->data.info.descriptor = expr;
1746 ss->data.info.data = gfc_conv_array_data (expr);
1747 ss->data.info.offset = gfc_conv_array_offset (expr);
1748 for (n = 0; n < cm->as->rank; n++)
1750 ss->data.info.dim[n] = n;
1751 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1752 ss->data.info.stride[n] = gfc_index_one_node;
1754 mpz_init (ss->shape[n]);
1755 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1756 cm->as->lower[n]->value.integer);
1757 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1760 /* Once we got ss, we use scalarizer to create the loop. */
1762 gfc_init_loopinfo (&loop);
1763 gfc_add_ss_to_loop (&loop, ss);
1764 gfc_conv_ss_startstride (&loop);
1765 gfc_conv_loop_setup (&loop);
1766 gfc_mark_ss_chain_used (ss, 1);
1767 gfc_start_scalarized_body (&loop, &body);
1769 gfc_copy_loopinfo_to_se (&se, &loop);
1772 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1774 gfc_conv_tmp_array_ref (&se);
1776 /* Now se.expr contains an element of the array. Take the address and pass
1777 it to the IO routines. */
1778 tmp = build_fold_addr_expr (se.expr);
1779 transfer_expr (&se, &cm->ts, tmp, NULL);
1781 /* We are done now with the loop body. Wrap up the scalarizer and
1784 gfc_add_block_to_block (&body, &se.pre);
1785 gfc_add_block_to_block (&body, &se.post);
1787 gfc_trans_scalarizing_loops (&loop, &body);
1789 gfc_add_block_to_block (&block, &loop.pre);
1790 gfc_add_block_to_block (&block, &loop.post);
1792 for (n = 0; n < cm->as->rank; n++)
1793 mpz_clear (ss->shape[n]);
1794 gfc_free (ss->shape);
1796 gfc_cleanup_loop (&loop);
1798 return gfc_finish_block (&block);
1801 /* Generate the call for a scalar transfer node. */
1804 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
1806 tree tmp, function, arg2, field, expr;
1810 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1811 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1812 We need to translate the expression to a constant if it's either
1813 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1814 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1815 BT_DERIVED (could have been changed by gfc_conv_expr). */
1816 if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
1817 || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
1819 /* C_PTR and C_FUNPTR have private components which means they can not
1820 be printed. However, if -std=gnu and not -pedantic, allow
1821 the component to be printed to help debugging. */
1822 if (gfc_notification_std (GFC_STD_GNU) != SILENT)
1824 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1825 ts->derived->name, code != NULL ? &(code->loc) :
1826 &gfc_current_locus);
1830 ts->type = ts->derived->ts.type;
1831 ts->kind = ts->derived->ts.kind;
1832 ts->f90_type = ts->derived->ts.f90_type;
1842 arg2 = build_int_cst (NULL_TREE, kind);
1843 function = iocall[IOCALL_X_INTEGER];
1847 arg2 = build_int_cst (NULL_TREE, kind);
1848 function = iocall[IOCALL_X_REAL];
1852 arg2 = build_int_cst (NULL_TREE, kind);
1853 function = iocall[IOCALL_X_COMPLEX];
1857 arg2 = build_int_cst (NULL_TREE, kind);
1858 function = iocall[IOCALL_X_LOGICAL];
1863 if (se->string_length)
1864 arg2 = se->string_length;
1867 tmp = build_fold_indirect_ref (addr_expr);
1868 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1869 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1871 function = iocall[IOCALL_X_CHARACTER];
1875 /* Recurse into the elements of the derived type. */
1876 expr = gfc_evaluate_now (addr_expr, &se->pre);
1877 expr = build_fold_indirect_ref (expr);
1879 for (c = ts->derived->components; c; c = c->next)
1881 field = c->backend_decl;
1882 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1884 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1889 tmp = transfer_array_component (tmp, c);
1890 gfc_add_expr_to_block (&se->pre, tmp);
1895 tmp = build_fold_addr_expr (tmp);
1896 transfer_expr (se, &c->ts, tmp, code);
1902 internal_error ("Bad IO basetype (%d)", ts->type);
1905 tmp = build_fold_addr_expr (dt_parm);
1906 tmp = build_call_expr (function, 3, tmp, addr_expr, arg2);
1907 gfc_add_expr_to_block (&se->pre, tmp);
1908 gfc_add_block_to_block (&se->pre, &se->post);
1913 /* Generate a call to pass an array descriptor to the IO library. The
1914 array should be of one of the intrinsic types. */
1917 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1919 tree tmp, charlen_arg, kind_arg;
1921 if (ts->type == BT_CHARACTER)
1922 charlen_arg = se->string_length;
1924 charlen_arg = build_int_cst (NULL_TREE, 0);
1926 kind_arg = build_int_cst (NULL_TREE, ts->kind);
1928 tmp = build_fold_addr_expr (dt_parm);
1929 tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4,
1930 tmp, addr_expr, kind_arg, charlen_arg);
1931 gfc_add_expr_to_block (&se->pre, tmp);
1932 gfc_add_block_to_block (&se->pre, &se->post);
1936 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1939 gfc_trans_transfer (gfc_code * code)
1941 stmtblock_t block, body;
1949 gfc_start_block (&block);
1950 gfc_init_block (&body);
1953 ss = gfc_walk_expr (expr);
1956 gfc_init_se (&se, NULL);
1958 if (ss == gfc_ss_terminator)
1960 /* Transfer a scalar value. */
1961 gfc_conv_expr_reference (&se, expr);
1962 transfer_expr (&se, &expr->ts, se.expr, code);
1966 /* Transfer an array. If it is an array of an intrinsic
1967 type, pass the descriptor to the library. Otherwise
1968 scalarize the transfer. */
1971 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
1973 gcc_assert (ref->type == REF_ARRAY);
1976 if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
1978 /* Get the descriptor. */
1979 gfc_conv_expr_descriptor (&se, expr, ss);
1980 tmp = build_fold_addr_expr (se.expr);
1981 transfer_array_desc (&se, &expr->ts, tmp);
1982 goto finish_block_label;
1985 /* Initialize the scalarizer. */
1986 gfc_init_loopinfo (&loop);
1987 gfc_add_ss_to_loop (&loop, ss);
1989 /* Initialize the loop. */
1990 gfc_conv_ss_startstride (&loop);
1991 gfc_conv_loop_setup (&loop);
1993 /* The main loop body. */
1994 gfc_mark_ss_chain_used (ss, 1);
1995 gfc_start_scalarized_body (&loop, &body);
1997 gfc_copy_loopinfo_to_se (&se, &loop);
2000 gfc_conv_expr_reference (&se, expr);
2001 transfer_expr (&se, &expr->ts, se.expr, code);
2006 gfc_add_block_to_block (&body, &se.pre);
2007 gfc_add_block_to_block (&body, &se.post);
2010 tmp = gfc_finish_block (&body);
2013 gcc_assert (se.ss == gfc_ss_terminator);
2014 gfc_trans_scalarizing_loops (&loop, &body);
2016 gfc_add_block_to_block (&loop.pre, &loop.post);
2017 tmp = gfc_finish_block (&loop.pre);
2018 gfc_cleanup_loop (&loop);
2021 gfc_add_expr_to_block (&block, tmp);
2023 return gfc_finish_block (&block);
2026 #include "gt-fortran-trans-io.h"