1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* This is the seed for an eventual trans-class.c
47 The following parameters should not be used directly since they might
48 in future implementations. Use the corresponding APIs. */
49 #define CLASS_DATA_FIELD 0
50 #define CLASS_VPTR_FIELD 1
51 #define VTABLE_HASH_FIELD 0
52 #define VTABLE_SIZE_FIELD 1
53 #define VTABLE_EXTENDS_FIELD 2
54 #define VTABLE_DEF_INIT_FIELD 3
55 #define VTABLE_COPY_FIELD 4
59 gfc_class_data_get (tree decl)
62 if (POINTER_TYPE_P (TREE_TYPE (decl)))
63 decl = build_fold_indirect_ref_loc (input_location, decl);
64 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
66 return fold_build3_loc (input_location, COMPONENT_REF,
67 TREE_TYPE (data), decl, data,
73 gfc_class_vptr_get (tree decl)
76 if (POINTER_TYPE_P (TREE_TYPE (decl)))
77 decl = build_fold_indirect_ref_loc (input_location, decl);
78 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
80 return fold_build3_loc (input_location, COMPONENT_REF,
81 TREE_TYPE (vptr), decl, vptr,
87 gfc_vtable_field_get (tree decl, int field)
91 vptr = gfc_class_vptr_get (decl);
92 vptr = build_fold_indirect_ref_loc (input_location, vptr);
93 size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
95 size = fold_build3_loc (input_location, COMPONENT_REF,
96 TREE_TYPE (size), vptr, size,
98 /* Always return size as an array index type. */
99 if (field == VTABLE_SIZE_FIELD)
100 size = fold_convert (gfc_array_index_type, size);
107 gfc_vtable_hash_get (tree decl)
109 return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
114 gfc_vtable_size_get (tree decl)
116 return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
121 gfc_vtable_extends_get (tree decl)
123 return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
128 gfc_vtable_def_init_get (tree decl)
130 return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
135 gfc_vtable_copy_get (tree decl)
137 return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
141 #undef CLASS_DATA_FIELD
142 #undef CLASS_VPTR_FIELD
143 #undef VTABLE_HASH_FIELD
144 #undef VTABLE_SIZE_FIELD
145 #undef VTABLE_EXTENDS_FIELD
146 #undef VTABLE_DEF_INIT_FIELD
147 #undef VTABLE_COPY_FIELD
150 /* Takes a derived type expression and returns the address of a temporary
151 class object of the 'declared' type. */
153 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
154 gfc_typespec class_ts)
162 /* The derived type needs to be converted to a temporary
164 tmp = gfc_typenode_for_spec (&class_ts);
165 var = gfc_create_var (tmp, "class");
168 ctree = gfc_class_vptr_get (var);
170 /* Remember the vtab corresponds to the derived type
171 not to the class declared type. */
172 vtab = gfc_find_derived_vtab (e->ts.u.derived);
174 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
175 gfc_add_modify (&parmse->pre, ctree,
176 fold_convert (TREE_TYPE (ctree), tmp));
178 /* Now set the data field. */
179 ctree = gfc_class_data_get (var);
181 if (parmse->ss && parmse->ss->info->useflags)
183 /* For an array reference in an elemental procedure call we need
184 to retain the ss to provide the scalarized array reference. */
185 gfc_conv_expr_reference (parmse, e);
186 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
187 gfc_add_modify (&parmse->pre, ctree, tmp);
191 ss = gfc_walk_expr (e);
192 if (ss == gfc_ss_terminator)
195 gfc_conv_expr_reference (parmse, e);
196 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
197 gfc_add_modify (&parmse->pre, ctree, tmp);
202 gfc_conv_expr_descriptor (parmse, e, ss);
203 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
207 /* Pass the address of the class object. */
208 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
212 /* Takes a scalarized class array expression and returns the
213 address of a temporary scalar class object of the 'declared'
215 OOP-TODO: This could be improved by adding code that branched on
216 the dynamic type being the same as the declared type. In this case
217 the original class expression can be passed directly. */
219 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
220 gfc_typespec class_ts, bool elemental)
228 bool full_array = false;
231 for (ref = e->ref; ref; ref = ref->next)
233 if (ref->type == REF_COMPONENT
234 && ref->u.c.component->ts.type == BT_CLASS)
237 if (ref->next == NULL)
241 if (ref == NULL || class_ref == ref)
244 /* Test for FULL_ARRAY. */
245 gfc_is_class_array_ref (e, &full_array);
247 /* The derived type needs to be converted to a temporary
249 tmp = gfc_typenode_for_spec (&class_ts);
250 var = gfc_create_var (tmp, "class");
253 ctree = gfc_class_data_get (var);
254 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
256 /* Return the data component, except in the case of scalarized array
257 references, where nullification of the cannot occur and so there
259 if (!elemental && full_array)
260 gfc_add_modify (&parmse->post, parmse->expr, ctree);
263 ctree = gfc_class_vptr_get (var);
265 /* The vptr is the second field of the actual argument.
266 First we have to find the corresponding class reference. */
269 if (class_ref == NULL
270 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
271 tmp = e->symtree->n.sym->backend_decl;
274 /* Remove everything after the last class reference, convert the
275 expression and then recover its tailend once more. */
277 ref = class_ref->next;
278 class_ref->next = NULL;
279 gfc_init_se (&tmpse, NULL);
280 gfc_conv_expr (&tmpse, e);
281 class_ref->next = ref;
285 gcc_assert (tmp != NULL_TREE);
287 /* Dereference if needs be. */
288 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
289 tmp = build_fold_indirect_ref_loc (input_location, tmp);
291 vptr = gfc_class_vptr_get (tmp);
292 gfc_add_modify (&parmse->pre, ctree,
293 fold_convert (TREE_TYPE (ctree), vptr));
295 /* Return the vptr component, except in the case of scalarized array
296 references, where the dynamic type cannot change. */
297 if (!elemental && full_array)
298 gfc_add_modify (&parmse->post, vptr,
299 fold_convert (TREE_TYPE (vptr), ctree));
301 /* Pass the address of the class object. */
302 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
306 /* Given a class array declaration and an index, returns the address
307 of the referenced element. */
310 gfc_get_class_array_ref (tree index, tree class_decl)
312 tree data = gfc_class_data_get (class_decl);
313 tree size = gfc_vtable_size_get (class_decl);
314 tree offset = fold_build2_loc (input_location, MULT_EXPR,
315 gfc_array_index_type,
318 data = gfc_conv_descriptor_data_get (data);
319 ptr = fold_convert (pvoid_type_node, data);
320 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
321 return fold_convert (TREE_TYPE (data), ptr);
325 /* Copies one class expression to another, assuming that if either
326 'to' or 'from' are arrays they are packed. Should 'from' be
327 NULL_TREE, the inialization expression for 'to' is used, assuming
328 that the _vptr is set. */
331 gfc_copy_class_to_class (tree from, tree to, tree nelems)
342 stmtblock_t loopbody;
348 if (from != NULL_TREE)
349 fcn = gfc_vtable_copy_get (from);
351 fcn = gfc_vtable_copy_get (to);
353 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
355 if (from != NULL_TREE)
356 from_data = gfc_class_data_get (from);
358 from_data = gfc_vtable_def_init_get (to);
360 to_data = gfc_class_data_get (to);
362 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
364 gfc_init_block (&body);
365 tmp = fold_build2_loc (input_location, MINUS_EXPR,
366 gfc_array_index_type, nelems,
368 nelems = gfc_evaluate_now (tmp, &body);
369 index = gfc_create_var (gfc_array_index_type, "S");
371 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
373 from_ref = gfc_get_class_array_ref (index, from);
374 VEC_safe_push (tree, gc, args, from_ref);
377 VEC_safe_push (tree, gc, args, from_data);
379 to_ref = gfc_get_class_array_ref (index, to);
380 VEC_safe_push (tree, gc, args, to_ref);
382 tmp = build_call_vec (fcn_type, fcn, args);
384 /* Build the body of the loop. */
385 gfc_init_block (&loopbody);
386 gfc_add_expr_to_block (&loopbody, tmp);
388 /* Build the loop and return. */
389 gfc_init_loopinfo (&loop);
391 loop.from[0] = gfc_index_zero_node;
392 loop.loopvar[0] = index;
394 gfc_trans_scalarizing_loops (&loop, &loopbody);
395 gfc_add_block_to_block (&body, &loop.pre);
396 tmp = gfc_finish_block (&body);
400 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
401 VEC_safe_push (tree, gc, args, from_data);
402 VEC_safe_push (tree, gc, args, to_data);
403 tmp = build_call_vec (fcn_type, fcn, args);
410 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
412 gfc_actual_arglist *actual;
417 actual = gfc_get_actual_arglist ();
418 actual->expr = gfc_copy_expr (rhs);
419 actual->next = gfc_get_actual_arglist ();
420 actual->next->expr = gfc_copy_expr (lhs);
421 ppc = gfc_copy_expr (obj);
422 gfc_add_vptr_component (ppc);
423 gfc_add_component_ref (ppc, "_copy");
424 ppc_code = gfc_get_code ();
425 ppc_code->resolved_sym = ppc->symtree->n.sym;
426 /* Although '_copy' is set to be elemental in class.c, it is
427 not staying that way. Find out why, sometime.... */
428 ppc_code->resolved_sym->attr.elemental = 1;
429 ppc_code->ext.actual = actual;
430 ppc_code->expr1 = ppc;
431 ppc_code->op = EXEC_CALL;
432 /* Since '_copy' is elemental, the scalarizer will take care
433 of arrays in gfc_trans_call. */
434 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
435 gfc_free_statements (ppc_code);
439 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
440 A MEMCPY is needed to copy the full data from the default initializer
441 of the dynamic type. */
444 gfc_trans_class_init_assign (gfc_code *code)
448 gfc_se dst,src,memsz;
449 gfc_expr *lhs, *rhs, *sz;
451 gfc_start_block (&block);
453 lhs = gfc_copy_expr (code->expr1);
454 gfc_add_data_component (lhs);
456 rhs = gfc_copy_expr (code->expr1);
457 gfc_add_vptr_component (rhs);
459 /* Make sure that the component backend_decls have been built, which
460 will not have happened if the derived types concerned have not
462 gfc_get_derived_type (rhs->ts.u.derived);
463 gfc_add_def_init_component (rhs);
465 if (code->expr1->ts.type == BT_CLASS
466 && CLASS_DATA (code->expr1)->attr.dimension)
467 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
470 sz = gfc_copy_expr (code->expr1);
471 gfc_add_vptr_component (sz);
472 gfc_add_size_component (sz);
474 gfc_init_se (&dst, NULL);
475 gfc_init_se (&src, NULL);
476 gfc_init_se (&memsz, NULL);
477 gfc_conv_expr (&dst, lhs);
478 gfc_conv_expr (&src, rhs);
479 gfc_conv_expr (&memsz, sz);
480 gfc_add_block_to_block (&block, &src.pre);
481 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
483 gfc_add_expr_to_block (&block, tmp);
485 return gfc_finish_block (&block);
489 /* Translate an assignment to a CLASS object
490 (pointer or ordinary assignment). */
493 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
501 gfc_start_block (&block);
504 while (ref && ref->next)
507 /* Class valued proc_pointer assignments do not need any further
509 if (ref && ref->type == REF_COMPONENT
510 && ref->u.c.component->attr.proc_pointer
511 && expr2->expr_type == EXPR_VARIABLE
512 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
513 && op == EXEC_POINTER_ASSIGN)
516 if (expr2->ts.type != BT_CLASS)
518 /* Insert an additional assignment which sets the '_vptr' field. */
519 gfc_symbol *vtab = NULL;
522 lhs = gfc_copy_expr (expr1);
523 gfc_add_vptr_component (lhs);
525 if (expr2->ts.type == BT_DERIVED)
526 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
527 else if (expr2->expr_type == EXPR_NULL)
528 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
531 rhs = gfc_get_expr ();
532 rhs->expr_type = EXPR_VARIABLE;
533 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
537 tmp = gfc_trans_pointer_assignment (lhs, rhs);
538 gfc_add_expr_to_block (&block, tmp);
543 else if (CLASS_DATA (expr2)->attr.dimension)
545 /* Insert an additional assignment which sets the '_vptr' field. */
546 lhs = gfc_copy_expr (expr1);
547 gfc_add_vptr_component (lhs);
549 rhs = gfc_copy_expr (expr2);
550 gfc_add_vptr_component (rhs);
552 tmp = gfc_trans_pointer_assignment (lhs, rhs);
553 gfc_add_expr_to_block (&block, tmp);
559 /* Do the actual CLASS assignment. */
560 if (expr2->ts.type == BT_CLASS
561 && !CLASS_DATA (expr2)->attr.dimension)
564 gfc_add_data_component (expr1);
568 if (op == EXEC_ASSIGN)
569 tmp = gfc_trans_assignment (expr1, expr2, false, true);
570 else if (op == EXEC_POINTER_ASSIGN)
571 tmp = gfc_trans_pointer_assignment (expr1, expr2);
575 gfc_add_expr_to_block (&block, tmp);
577 return gfc_finish_block (&block);
581 /* End of prototype trans-class.c */
584 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
585 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
588 /* Copy the scalarization loop variables. */
591 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
594 dest->loop = src->loop;
598 /* Initialize a simple expression holder.
600 Care must be taken when multiple se are created with the same parent.
601 The child se must be kept in sync. The easiest way is to delay creation
602 of a child se until after after the previous se has been translated. */
605 gfc_init_se (gfc_se * se, gfc_se * parent)
607 memset (se, 0, sizeof (gfc_se));
608 gfc_init_block (&se->pre);
609 gfc_init_block (&se->post);
614 gfc_copy_se_loopvars (se, parent);
618 /* Advances to the next SS in the chain. Use this rather than setting
619 se->ss = se->ss->next because all the parents needs to be kept in sync.
623 gfc_advance_se_ss_chain (gfc_se * se)
628 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
631 /* Walk down the parent chain. */
634 /* Simple consistency check. */
635 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
636 || p->parent->ss->nested_ss == p->ss);
638 /* If we were in a nested loop, the next scalarized expression can be
639 on the parent ss' next pointer. Thus we should not take the next
640 pointer blindly, but rather go up one nest level as long as next
641 is the end of chain. */
643 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
653 /* Ensures the result of the expression as either a temporary variable
654 or a constant so that it can be used repeatedly. */
657 gfc_make_safe_expr (gfc_se * se)
661 if (CONSTANT_CLASS_P (se->expr))
664 /* We need a temporary for this result. */
665 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
666 gfc_add_modify (&se->pre, var, se->expr);
671 /* Return an expression which determines if a dummy parameter is present.
672 Also used for arguments to procedures with multiple entry points. */
675 gfc_conv_expr_present (gfc_symbol * sym)
679 gcc_assert (sym->attr.dummy);
681 decl = gfc_get_symbol_decl (sym);
682 if (TREE_CODE (decl) != PARM_DECL)
684 /* Array parameters use a temporary descriptor, we want the real
686 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
687 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
688 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
691 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
692 fold_convert (TREE_TYPE (decl), null_pointer_node));
694 /* Fortran 2008 allows to pass null pointers and non-associated pointers
695 as actual argument to denote absent dummies. For array descriptors,
696 we thus also need to check the array descriptor. */
697 if (!sym->attr.pointer && !sym->attr.allocatable
698 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
699 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
702 tmp = build_fold_indirect_ref_loc (input_location, decl);
703 tmp = gfc_conv_array_data (tmp);
704 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
705 fold_convert (TREE_TYPE (tmp), null_pointer_node));
706 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
707 boolean_type_node, cond, tmp);
714 /* Converts a missing, dummy argument into a null or zero. */
717 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
722 present = gfc_conv_expr_present (arg->symtree->n.sym);
726 /* Create a temporary and convert it to the correct type. */
727 tmp = gfc_get_int_type (kind);
728 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
731 /* Test for a NULL value. */
732 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
733 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
734 tmp = gfc_evaluate_now (tmp, &se->pre);
735 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
739 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
741 build_zero_cst (TREE_TYPE (se->expr)));
742 tmp = gfc_evaluate_now (tmp, &se->pre);
746 if (ts.type == BT_CHARACTER)
748 tmp = build_int_cst (gfc_charlen_type_node, 0);
749 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
750 present, se->string_length, tmp);
751 tmp = gfc_evaluate_now (tmp, &se->pre);
752 se->string_length = tmp;
758 /* Get the character length of an expression, looking through gfc_refs
762 gfc_get_expr_charlen (gfc_expr *e)
767 gcc_assert (e->expr_type == EXPR_VARIABLE
768 && e->ts.type == BT_CHARACTER);
770 length = NULL; /* To silence compiler warning. */
772 if (is_subref_array (e) && e->ts.u.cl->length)
775 gfc_init_se (&tmpse, NULL);
776 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
777 e->ts.u.cl->backend_decl = tmpse.expr;
781 /* First candidate: if the variable is of type CHARACTER, the
782 expression's length could be the length of the character
784 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
785 length = e->symtree->n.sym->ts.u.cl->backend_decl;
787 /* Look through the reference chain for component references. */
788 for (r = e->ref; r; r = r->next)
793 if (r->u.c.component->ts.type == BT_CHARACTER)
794 length = r->u.c.component->ts.u.cl->backend_decl;
802 /* We should never got substring references here. These will be
803 broken down by the scalarizer. */
809 gcc_assert (length != NULL);
814 /* Return for an expression the backend decl of the coarray. */
817 get_tree_for_caf_expr (gfc_expr *expr)
819 tree caf_decl = NULL_TREE;
822 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
823 if (expr->symtree->n.sym->attr.codimension)
824 caf_decl = expr->symtree->n.sym->backend_decl;
826 for (ref = expr->ref; ref; ref = ref->next)
827 if (ref->type == REF_COMPONENT)
829 gfc_component *comp = ref->u.c.component;
830 if (comp->attr.pointer || comp->attr.allocatable)
831 caf_decl = NULL_TREE;
832 if (comp->attr.codimension)
833 caf_decl = comp->backend_decl;
836 gcc_assert (caf_decl != NULL_TREE);
841 /* For each character array constructor subexpression without a ts.u.cl->length,
842 replace it by its first element (if there aren't any elements, the length
843 should already be set to zero). */
846 flatten_array_ctors_without_strlen (gfc_expr* e)
848 gfc_actual_arglist* arg;
854 switch (e->expr_type)
858 flatten_array_ctors_without_strlen (e->value.op.op1);
859 flatten_array_ctors_without_strlen (e->value.op.op2);
863 /* TODO: Implement as with EXPR_FUNCTION when needed. */
867 for (arg = e->value.function.actual; arg; arg = arg->next)
868 flatten_array_ctors_without_strlen (arg->expr);
873 /* We've found what we're looking for. */
874 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
879 gcc_assert (e->value.constructor);
881 c = gfc_constructor_first (e->value.constructor);
885 flatten_array_ctors_without_strlen (new_expr);
886 gfc_replace_expr (e, new_expr);
890 /* Otherwise, fall through to handle constructor elements. */
892 for (c = gfc_constructor_first (e->value.constructor);
893 c; c = gfc_constructor_next (c))
894 flatten_array_ctors_without_strlen (c->expr);
904 /* Generate code to initialize a string length variable. Returns the
905 value. For array constructors, cl->length might be NULL and in this case,
906 the first element of the constructor is needed. expr is the original
907 expression so we can access it but can be NULL if this is not needed. */
910 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
914 gfc_init_se (&se, NULL);
918 && TREE_CODE (cl->backend_decl) == VAR_DECL)
921 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
922 "flatten" array constructors by taking their first element; all elements
923 should be the same length or a cl->length should be present. */
928 expr_flat = gfc_copy_expr (expr);
929 flatten_array_ctors_without_strlen (expr_flat);
930 gfc_resolve_expr (expr_flat);
932 gfc_conv_expr (&se, expr_flat);
933 gfc_add_block_to_block (pblock, &se.pre);
934 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
936 gfc_free_expr (expr_flat);
940 /* Convert cl->length. */
942 gcc_assert (cl->length);
944 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
945 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
946 se.expr, build_int_cst (gfc_charlen_type_node, 0));
947 gfc_add_block_to_block (pblock, &se.pre);
949 if (cl->backend_decl)
950 gfc_add_modify (pblock, cl->backend_decl, se.expr);
952 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
957 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
958 const char *name, locus *where)
967 type = gfc_get_character_type (kind, ref->u.ss.length);
968 type = build_pointer_type (type);
970 gfc_init_se (&start, se);
971 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
972 gfc_add_block_to_block (&se->pre, &start.pre);
974 if (integer_onep (start.expr))
975 gfc_conv_string_parameter (se);
980 /* Avoid multiple evaluation of substring start. */
981 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
982 start.expr = gfc_evaluate_now (start.expr, &se->pre);
984 /* Change the start of the string. */
985 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
988 tmp = build_fold_indirect_ref_loc (input_location,
990 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
991 se->expr = gfc_build_addr_expr (type, tmp);
994 /* Length = end + 1 - start. */
995 gfc_init_se (&end, se);
996 if (ref->u.ss.end == NULL)
997 end.expr = se->string_length;
1000 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
1001 gfc_add_block_to_block (&se->pre, &end.pre);
1005 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
1006 end.expr = gfc_evaluate_now (end.expr, &se->pre);
1008 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1010 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
1011 boolean_type_node, start.expr,
1014 /* Check lower bound. */
1015 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1017 build_int_cst (gfc_charlen_type_node, 1));
1018 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1019 boolean_type_node, nonempty, fault);
1021 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
1022 "is less than one", name);
1024 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
1025 "is less than one");
1026 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
1027 fold_convert (long_integer_type_node,
1031 /* Check upper bound. */
1032 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1033 end.expr, se->string_length);
1034 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1035 boolean_type_node, nonempty, fault);
1037 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
1038 "exceeds string length (%%ld)", name);
1040 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
1041 "exceeds string length (%%ld)");
1042 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
1043 fold_convert (long_integer_type_node, end.expr),
1044 fold_convert (long_integer_type_node,
1045 se->string_length));
1049 /* If the start and end expressions are equal, the length is one. */
1051 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
1052 tmp = build_int_cst (gfc_charlen_type_node, 1);
1055 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
1056 end.expr, start.expr);
1057 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
1058 build_int_cst (gfc_charlen_type_node, 1), tmp);
1059 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
1060 tmp, build_int_cst (gfc_charlen_type_node, 0));
1063 se->string_length = tmp;
1067 /* Convert a derived type component reference. */
1070 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
1077 c = ref->u.c.component;
1079 gcc_assert (c->backend_decl);
1081 field = c->backend_decl;
1082 gcc_assert (TREE_CODE (field) == FIELD_DECL);
1085 /* Components can correspond to fields of different containing
1086 types, as components are created without context, whereas
1087 a concrete use of a component has the type of decl as context.
1088 So, if the type doesn't match, we search the corresponding
1089 FIELD_DECL in the parent type. To not waste too much time
1090 we cache this result in norestrict_decl. */
1092 if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
1094 tree f2 = c->norestrict_decl;
1095 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
1096 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
1097 if (TREE_CODE (f2) == FIELD_DECL
1098 && DECL_NAME (f2) == DECL_NAME (field))
1101 c->norestrict_decl = f2;
1104 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1105 decl, field, NULL_TREE);
1109 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
1111 tmp = c->ts.u.cl->backend_decl;
1112 /* Components must always be constant length. */
1113 gcc_assert (tmp && INTEGER_CST_P (tmp));
1114 se->string_length = tmp;
1117 if (((c->attr.pointer || c->attr.allocatable)
1118 && (!c->attr.dimension && !c->attr.codimension)
1119 && c->ts.type != BT_CHARACTER)
1120 || c->attr.proc_pointer)
1121 se->expr = build_fold_indirect_ref_loc (input_location,
1126 /* This function deals with component references to components of the
1127 parent type for derived type extensons. */
1129 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
1137 c = ref->u.c.component;
1139 /* Return if the component is not in the parent type. */
1140 for (cmp = dt->components; cmp; cmp = cmp->next)
1141 if (strcmp (c->name, cmp->name) == 0)
1144 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1145 parent.type = REF_COMPONENT;
1147 parent.u.c.sym = dt;
1148 parent.u.c.component = dt->components;
1150 if (dt->backend_decl == NULL)
1151 gfc_get_derived_type (dt);
1153 /* Build the reference and call self. */
1154 gfc_conv_component_ref (se, &parent);
1155 parent.u.c.sym = dt->components->ts.u.derived;
1156 parent.u.c.component = c;
1157 conv_parent_component_references (se, &parent);
1160 /* Return the contents of a variable. Also handles reference/pointer
1161 variables (all Fortran pointer references are implicit). */
1164 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
1169 tree parent_decl = NULL_TREE;
1172 bool alternate_entry;
1175 sym = expr->symtree->n.sym;
1179 gfc_ss_info *ss_info = ss->info;
1181 /* Check that something hasn't gone horribly wrong. */
1182 gcc_assert (ss != gfc_ss_terminator);
1183 gcc_assert (ss_info->expr == expr);
1185 /* A scalarized term. We already know the descriptor. */
1186 se->expr = ss_info->data.array.descriptor;
1187 se->string_length = ss_info->string_length;
1188 for (ref = ss_info->data.array.ref; ref; ref = ref->next)
1189 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
1194 tree se_expr = NULL_TREE;
1196 se->expr = gfc_get_symbol_decl (sym);
1198 /* Deal with references to a parent results or entries by storing
1199 the current_function_decl and moving to the parent_decl. */
1200 return_value = sym->attr.function && sym->result == sym;
1201 alternate_entry = sym->attr.function && sym->attr.entry
1202 && sym->result == sym;
1203 entry_master = sym->attr.result
1204 && sym->ns->proc_name->attr.entry_master
1205 && !gfc_return_by_reference (sym->ns->proc_name);
1206 if (current_function_decl)
1207 parent_decl = DECL_CONTEXT (current_function_decl);
1209 if ((se->expr == parent_decl && return_value)
1210 || (sym->ns && sym->ns->proc_name
1212 && sym->ns->proc_name->backend_decl == parent_decl
1213 && (alternate_entry || entry_master)))
1218 /* Special case for assigning the return value of a function.
1219 Self recursive functions must have an explicit return value. */
1220 if (return_value && (se->expr == current_function_decl || parent_flag))
1221 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1223 /* Similarly for alternate entry points. */
1224 else if (alternate_entry
1225 && (sym->ns->proc_name->backend_decl == current_function_decl
1228 gfc_entry_list *el = NULL;
1230 for (el = sym->ns->entries; el; el = el->next)
1233 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1238 else if (entry_master
1239 && (sym->ns->proc_name->backend_decl == current_function_decl
1241 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
1246 /* Procedure actual arguments. */
1247 else if (sym->attr.flavor == FL_PROCEDURE
1248 && se->expr != current_function_decl)
1250 if (!sym->attr.dummy && !sym->attr.proc_pointer)
1252 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
1253 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1259 /* Dereference the expression, where needed. Since characters
1260 are entirely different from other types, they are treated
1262 if (sym->ts.type == BT_CHARACTER)
1264 /* Dereference character pointer dummy arguments
1266 if ((sym->attr.pointer || sym->attr.allocatable)
1268 || sym->attr.function
1269 || sym->attr.result))
1270 se->expr = build_fold_indirect_ref_loc (input_location,
1274 else if (!sym->attr.value)
1276 /* Dereference non-character scalar dummy arguments. */
1277 if (sym->attr.dummy && !sym->attr.dimension
1278 && !(sym->attr.codimension && sym->attr.allocatable))
1279 se->expr = build_fold_indirect_ref_loc (input_location,
1282 /* Dereference scalar hidden result. */
1283 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
1284 && (sym->attr.function || sym->attr.result)
1285 && !sym->attr.dimension && !sym->attr.pointer
1286 && !sym->attr.always_explicit)
1287 se->expr = build_fold_indirect_ref_loc (input_location,
1290 /* Dereference non-character pointer variables.
1291 These must be dummies, results, or scalars. */
1292 if ((sym->attr.pointer || sym->attr.allocatable
1293 || gfc_is_associate_pointer (sym))
1295 || sym->attr.function
1297 || (!sym->attr.dimension
1298 && (!sym->attr.codimension || !sym->attr.allocatable))))
1299 se->expr = build_fold_indirect_ref_loc (input_location,
1306 /* For character variables, also get the length. */
1307 if (sym->ts.type == BT_CHARACTER)
1309 /* If the character length of an entry isn't set, get the length from
1310 the master function instead. */
1311 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
1312 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
1314 se->string_length = sym->ts.u.cl->backend_decl;
1315 gcc_assert (se->string_length);
1323 /* Return the descriptor if that's what we want and this is an array
1324 section reference. */
1325 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
1327 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1328 /* Return the descriptor for array pointers and allocations. */
1329 if (se->want_pointer
1330 && ref->next == NULL && (se->descriptor_only))
1333 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
1334 /* Return a pointer to an element. */
1338 if (ref->u.c.sym->attr.extension)
1339 conv_parent_component_references (se, ref);
1341 gfc_conv_component_ref (se, ref);
1346 gfc_conv_substring (se, ref, expr->ts.kind,
1347 expr->symtree->name, &expr->where);
1356 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1358 if (se->want_pointer)
1360 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
1361 gfc_conv_string_parameter (se);
1363 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
1368 /* Unary ops are easy... Or they would be if ! was a valid op. */
1371 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
1376 gcc_assert (expr->ts.type != BT_CHARACTER);
1377 /* Initialize the operand. */
1378 gfc_init_se (&operand, se);
1379 gfc_conv_expr_val (&operand, expr->value.op.op1);
1380 gfc_add_block_to_block (&se->pre, &operand.pre);
1382 type = gfc_typenode_for_spec (&expr->ts);
1384 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1385 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1386 All other unary operators have an equivalent GIMPLE unary operator. */
1387 if (code == TRUTH_NOT_EXPR)
1388 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
1389 build_int_cst (type, 0));
1391 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
1395 /* Expand power operator to optimal multiplications when a value is raised
1396 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1397 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1398 Programming", 3rd Edition, 1998. */
1400 /* This code is mostly duplicated from expand_powi in the backend.
1401 We establish the "optimal power tree" lookup table with the defined size.
1402 The items in the table are the exponents used to calculate the index
1403 exponents. Any integer n less than the value can get an "addition chain",
1404 with the first node being one. */
1405 #define POWI_TABLE_SIZE 256
1407 /* The table is from builtins.c. */
1408 static const unsigned char powi_table[POWI_TABLE_SIZE] =
1410 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1411 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1412 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1413 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1414 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1415 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1416 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1417 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1418 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1419 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1420 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1421 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1422 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1423 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1424 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1425 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1426 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1427 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1428 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1429 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1430 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1431 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1432 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1433 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1434 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1435 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1436 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1437 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1438 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1439 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1440 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1441 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1444 /* If n is larger than lookup table's max index, we use the "window
1446 #define POWI_WINDOW_SIZE 3
1448 /* Recursive function to expand the power operator. The temporary
1449 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1451 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
1458 if (n < POWI_TABLE_SIZE)
1463 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
1464 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
1468 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
1469 op0 = gfc_conv_powi (se, n - digit, tmpvar);
1470 op1 = gfc_conv_powi (se, digit, tmpvar);
1474 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
1478 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
1479 tmp = gfc_evaluate_now (tmp, &se->pre);
1481 if (n < POWI_TABLE_SIZE)
1488 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1489 return 1. Else return 0 and a call to runtime library functions
1490 will have to be built. */
1492 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
1497 tree vartmp[POWI_TABLE_SIZE];
1499 unsigned HOST_WIDE_INT n;
1502 /* If exponent is too large, we won't expand it anyway, so don't bother
1503 with large integer values. */
1504 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
1507 m = double_int_to_shwi (TREE_INT_CST (rhs));
1508 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1509 of the asymmetric range of the integer type. */
1510 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
1512 type = TREE_TYPE (lhs);
1513 sgn = tree_int_cst_sgn (rhs);
1515 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
1516 || optimize_size) && (m > 2 || m < -1))
1522 se->expr = gfc_build_const (type, integer_one_node);
1526 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1527 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
1529 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1530 lhs, build_int_cst (TREE_TYPE (lhs), -1));
1531 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1532 lhs, build_int_cst (TREE_TYPE (lhs), 1));
1535 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1538 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1539 boolean_type_node, tmp, cond);
1540 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1541 tmp, build_int_cst (type, 1),
1542 build_int_cst (type, 0));
1546 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1547 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
1548 build_int_cst (type, -1),
1549 build_int_cst (type, 0));
1550 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
1551 cond, build_int_cst (type, 1), tmp);
1555 memset (vartmp, 0, sizeof (vartmp));
1559 tmp = gfc_build_const (type, integer_one_node);
1560 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
1564 se->expr = gfc_conv_powi (se, n, vartmp);
1570 /* Power op (**). Constant integer exponent has special handling. */
1573 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
1575 tree gfc_int4_type_node;
1578 int res_ikind_1, res_ikind_2;
1583 gfc_init_se (&lse, se);
1584 gfc_conv_expr_val (&lse, expr->value.op.op1);
1585 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
1586 gfc_add_block_to_block (&se->pre, &lse.pre);
1588 gfc_init_se (&rse, se);
1589 gfc_conv_expr_val (&rse, expr->value.op.op2);
1590 gfc_add_block_to_block (&se->pre, &rse.pre);
1592 if (expr->value.op.op2->ts.type == BT_INTEGER
1593 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
1594 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
1597 gfc_int4_type_node = gfc_get_int_type (4);
1599 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1600 library routine. But in the end, we have to convert the result back
1601 if this case applies -- with res_ikind_K, we keep track whether operand K
1602 falls into this case. */
1606 kind = expr->value.op.op1->ts.kind;
1607 switch (expr->value.op.op2->ts.type)
1610 ikind = expr->value.op.op2->ts.kind;
1615 rse.expr = convert (gfc_int4_type_node, rse.expr);
1616 res_ikind_2 = ikind;
1638 if (expr->value.op.op1->ts.type == BT_INTEGER)
1640 lse.expr = convert (gfc_int4_type_node, lse.expr);
1667 switch (expr->value.op.op1->ts.type)
1670 if (kind == 3) /* Case 16 was not handled properly above. */
1672 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1676 /* Use builtins for real ** int4. */
1682 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
1686 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
1690 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1694 /* Use the __builtin_powil() only if real(kind=16) is
1695 actually the C long double type. */
1696 if (!gfc_real16_is_float128)
1697 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
1705 /* If we don't have a good builtin for this, go for the
1706 library function. */
1708 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1712 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1721 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1725 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1733 se->expr = build_call_expr_loc (input_location,
1734 fndecl, 2, lse.expr, rse.expr);
1736 /* Convert the result back if it is of wrong integer kind. */
1737 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1739 /* We want the maximum of both operand kinds as result. */
1740 if (res_ikind_1 < res_ikind_2)
1741 res_ikind_1 = res_ikind_2;
1742 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1747 /* Generate code to allocate a string temporary. */
1750 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1755 if (gfc_can_put_var_on_stack (len))
1757 /* Create a temporary variable to hold the result. */
1758 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1759 gfc_charlen_type_node, len,
1760 build_int_cst (gfc_charlen_type_node, 1));
1761 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1763 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1764 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1766 tmp = build_array_type (TREE_TYPE (type), tmp);
1768 var = gfc_create_var (tmp, "str");
1769 var = gfc_build_addr_expr (type, var);
1773 /* Allocate a temporary to hold the result. */
1774 var = gfc_create_var (type, "pstr");
1775 tmp = gfc_call_malloc (&se->pre, type,
1776 fold_build2_loc (input_location, MULT_EXPR,
1777 TREE_TYPE (len), len,
1778 fold_convert (TREE_TYPE (len),
1779 TYPE_SIZE (type))));
1780 gfc_add_modify (&se->pre, var, tmp);
1782 /* Free the temporary afterwards. */
1783 tmp = gfc_call_free (convert (pvoid_type_node, var));
1784 gfc_add_expr_to_block (&se->post, tmp);
1791 /* Handle a string concatenation operation. A temporary will be allocated to
1795 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1798 tree len, type, var, tmp, fndecl;
1800 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1801 && expr->value.op.op2->ts.type == BT_CHARACTER);
1802 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1804 gfc_init_se (&lse, se);
1805 gfc_conv_expr (&lse, expr->value.op.op1);
1806 gfc_conv_string_parameter (&lse);
1807 gfc_init_se (&rse, se);
1808 gfc_conv_expr (&rse, expr->value.op.op2);
1809 gfc_conv_string_parameter (&rse);
1811 gfc_add_block_to_block (&se->pre, &lse.pre);
1812 gfc_add_block_to_block (&se->pre, &rse.pre);
1814 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1815 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1816 if (len == NULL_TREE)
1818 len = fold_build2_loc (input_location, PLUS_EXPR,
1819 TREE_TYPE (lse.string_length),
1820 lse.string_length, rse.string_length);
1823 type = build_pointer_type (type);
1825 var = gfc_conv_string_tmp (se, type, len);
1827 /* Do the actual concatenation. */
1828 if (expr->ts.kind == 1)
1829 fndecl = gfor_fndecl_concat_string;
1830 else if (expr->ts.kind == 4)
1831 fndecl = gfor_fndecl_concat_string_char4;
1835 tmp = build_call_expr_loc (input_location,
1836 fndecl, 6, len, var, lse.string_length, lse.expr,
1837 rse.string_length, rse.expr);
1838 gfc_add_expr_to_block (&se->pre, tmp);
1840 /* Add the cleanup for the operands. */
1841 gfc_add_block_to_block (&se->pre, &rse.post);
1842 gfc_add_block_to_block (&se->pre, &lse.post);
1845 se->string_length = len;
1848 /* Translates an op expression. Common (binary) cases are handled by this
1849 function, others are passed on. Recursion is used in either case.
1850 We use the fact that (op1.ts == op2.ts) (except for the power
1852 Operators need no special handling for scalarized expressions as long as
1853 they call gfc_conv_simple_val to get their operands.
1854 Character strings get special handling. */
1857 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1859 enum tree_code code;
1868 switch (expr->value.op.op)
1870 case INTRINSIC_PARENTHESES:
1871 if ((expr->ts.type == BT_REAL
1872 || expr->ts.type == BT_COMPLEX)
1873 && gfc_option.flag_protect_parens)
1875 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1876 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1881 case INTRINSIC_UPLUS:
1882 gfc_conv_expr (se, expr->value.op.op1);
1885 case INTRINSIC_UMINUS:
1886 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1890 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1893 case INTRINSIC_PLUS:
1897 case INTRINSIC_MINUS:
1901 case INTRINSIC_TIMES:
1905 case INTRINSIC_DIVIDE:
1906 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1907 an integer, we must round towards zero, so we use a
1909 if (expr->ts.type == BT_INTEGER)
1910 code = TRUNC_DIV_EXPR;
1915 case INTRINSIC_POWER:
1916 gfc_conv_power_op (se, expr);
1919 case INTRINSIC_CONCAT:
1920 gfc_conv_concat_op (se, expr);
1924 code = TRUTH_ANDIF_EXPR;
1929 code = TRUTH_ORIF_EXPR;
1933 /* EQV and NEQV only work on logicals, but since we represent them
1934 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1936 case INTRINSIC_EQ_OS:
1944 case INTRINSIC_NE_OS:
1945 case INTRINSIC_NEQV:
1952 case INTRINSIC_GT_OS:
1959 case INTRINSIC_GE_OS:
1966 case INTRINSIC_LT_OS:
1973 case INTRINSIC_LE_OS:
1979 case INTRINSIC_USER:
1980 case INTRINSIC_ASSIGN:
1981 /* These should be converted into function calls by the frontend. */
1985 fatal_error ("Unknown intrinsic op");
1989 /* The only exception to this is **, which is handled separately anyway. */
1990 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1992 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1996 gfc_init_se (&lse, se);
1997 gfc_conv_expr (&lse, expr->value.op.op1);
1998 gfc_add_block_to_block (&se->pre, &lse.pre);
2001 gfc_init_se (&rse, se);
2002 gfc_conv_expr (&rse, expr->value.op.op2);
2003 gfc_add_block_to_block (&se->pre, &rse.pre);
2007 gfc_conv_string_parameter (&lse);
2008 gfc_conv_string_parameter (&rse);
2010 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
2011 rse.string_length, rse.expr,
2012 expr->value.op.op1->ts.kind,
2014 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
2015 gfc_add_block_to_block (&lse.post, &rse.post);
2018 type = gfc_typenode_for_spec (&expr->ts);
2022 /* The result of logical ops is always boolean_type_node. */
2023 tmp = fold_build2_loc (input_location, code, boolean_type_node,
2024 lse.expr, rse.expr);
2025 se->expr = convert (type, tmp);
2028 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
2030 /* Add the post blocks. */
2031 gfc_add_block_to_block (&se->post, &rse.post);
2032 gfc_add_block_to_block (&se->post, &lse.post);
2035 /* If a string's length is one, we convert it to a single character. */
2038 gfc_string_to_single_character (tree len, tree str, int kind)
2041 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
2042 || !POINTER_TYPE_P (TREE_TYPE (str)))
2045 if (TREE_INT_CST_LOW (len) == 1)
2047 str = fold_convert (gfc_get_pchar_type (kind), str);
2048 return build_fold_indirect_ref_loc (input_location, str);
2052 && TREE_CODE (str) == ADDR_EXPR
2053 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2054 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2055 && array_ref_low_bound (TREE_OPERAND (str, 0))
2056 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2057 && TREE_INT_CST_LOW (len) > 1
2058 && TREE_INT_CST_LOW (len)
2059 == (unsigned HOST_WIDE_INT)
2060 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2062 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
2063 ret = build_fold_indirect_ref_loc (input_location, ret);
2064 if (TREE_CODE (ret) == INTEGER_CST)
2066 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2067 int i, length = TREE_STRING_LENGTH (string_cst);
2068 const char *ptr = TREE_STRING_POINTER (string_cst);
2070 for (i = 1; i < length; i++)
2083 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
2086 if (sym->backend_decl)
2088 /* This becomes the nominal_type in
2089 function.c:assign_parm_find_data_types. */
2090 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
2091 /* This becomes the passed_type in
2092 function.c:assign_parm_find_data_types. C promotes char to
2093 integer for argument passing. */
2094 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
2096 DECL_BY_REFERENCE (sym->backend_decl) = 0;
2101 /* If we have a constant character expression, make it into an
2103 if ((*expr)->expr_type == EXPR_CONSTANT)
2108 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
2109 (int)(*expr)->value.character.string[0]);
2110 if ((*expr)->ts.kind != gfc_c_int_kind)
2112 /* The expr needs to be compatible with a C int. If the
2113 conversion fails, then the 2 causes an ICE. */
2114 ts.type = BT_INTEGER;
2115 ts.kind = gfc_c_int_kind;
2116 gfc_convert_type (*expr, &ts, 2);
2119 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
2121 if ((*expr)->ref == NULL)
2123 se->expr = gfc_string_to_single_character
2124 (build_int_cst (integer_type_node, 1),
2125 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2127 ((*expr)->symtree->n.sym)),
2132 gfc_conv_variable (se, *expr);
2133 se->expr = gfc_string_to_single_character
2134 (build_int_cst (integer_type_node, 1),
2135 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
2143 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2144 if STR is a string literal, otherwise return -1. */
2147 gfc_optimize_len_trim (tree len, tree str, int kind)
2150 && TREE_CODE (str) == ADDR_EXPR
2151 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
2152 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
2153 && array_ref_low_bound (TREE_OPERAND (str, 0))
2154 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
2155 && TREE_INT_CST_LOW (len) >= 1
2156 && TREE_INT_CST_LOW (len)
2157 == (unsigned HOST_WIDE_INT)
2158 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
2160 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
2161 folded = build_fold_indirect_ref_loc (input_location, folded);
2162 if (TREE_CODE (folded) == INTEGER_CST)
2164 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
2165 int length = TREE_STRING_LENGTH (string_cst);
2166 const char *ptr = TREE_STRING_POINTER (string_cst);
2168 for (; length > 0; length--)
2169 if (ptr[length - 1] != ' ')
2178 /* Compare two strings. If they are all single characters, the result is the
2179 subtraction of them. Otherwise, we build a library call. */
2182 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
2183 enum tree_code code)
2189 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
2190 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
2192 sc1 = gfc_string_to_single_character (len1, str1, kind);
2193 sc2 = gfc_string_to_single_character (len2, str2, kind);
2195 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
2197 /* Deal with single character specially. */
2198 sc1 = fold_convert (integer_type_node, sc1);
2199 sc2 = fold_convert (integer_type_node, sc2);
2200 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
2204 if ((code == EQ_EXPR || code == NE_EXPR)
2206 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
2208 /* If one string is a string literal with LEN_TRIM longer
2209 than the length of the second string, the strings
2211 int len = gfc_optimize_len_trim (len1, str1, kind);
2212 if (len > 0 && compare_tree_int (len2, len) < 0)
2213 return integer_one_node;
2214 len = gfc_optimize_len_trim (len2, str2, kind);
2215 if (len > 0 && compare_tree_int (len1, len) < 0)
2216 return integer_one_node;
2219 /* Build a call for the comparison. */
2221 fndecl = gfor_fndecl_compare_string;
2223 fndecl = gfor_fndecl_compare_string_char4;
2227 return build_call_expr_loc (input_location, fndecl, 4,
2228 len1, str1, len2, str2);
2232 /* Return the backend_decl for a procedure pointer component. */
2235 get_proc_ptr_comp (gfc_expr *e)
2241 gfc_init_se (&comp_se, NULL);
2242 e2 = gfc_copy_expr (e);
2243 /* We have to restore the expr type later so that gfc_free_expr frees
2244 the exact same thing that was allocated.
2245 TODO: This is ugly. */
2246 old_type = e2->expr_type;
2247 e2->expr_type = EXPR_VARIABLE;
2248 gfc_conv_expr (&comp_se, e2);
2249 e2->expr_type = old_type;
2251 return build_fold_addr_expr_loc (input_location, comp_se.expr);
2255 /* Convert a typebound function reference from a class object. */
2257 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
2262 if (TREE_CODE (base_object) != VAR_DECL)
2264 var = gfc_create_var (TREE_TYPE (base_object), NULL);
2265 gfc_add_modify (&se->pre, var, base_object);
2267 se->expr = gfc_class_vptr_get (base_object);
2268 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2270 while (ref && ref->next)
2272 gcc_assert (ref && ref->type == REF_COMPONENT);
2273 if (ref->u.c.sym->attr.extension)
2274 conv_parent_component_references (se, ref);
2275 gfc_conv_component_ref (se, ref);
2276 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
2281 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
2285 if (gfc_is_proc_ptr_comp (expr, NULL))
2286 tmp = get_proc_ptr_comp (expr);
2287 else if (sym->attr.dummy)
2289 tmp = gfc_get_symbol_decl (sym);
2290 if (sym->attr.proc_pointer)
2291 tmp = build_fold_indirect_ref_loc (input_location,
2293 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
2294 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
2298 if (!sym->backend_decl)
2299 sym->backend_decl = gfc_get_extern_function_decl (sym);
2301 tmp = sym->backend_decl;
2303 if (sym->attr.cray_pointee)
2305 /* TODO - make the cray pointee a pointer to a procedure,
2306 assign the pointer to it and use it for the call. This
2308 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
2309 gfc_get_symbol_decl (sym->cp_pointer));
2310 tmp = gfc_evaluate_now (tmp, &se->pre);
2313 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
2315 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
2316 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2323 /* Initialize MAPPING. */
2326 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
2328 mapping->syms = NULL;
2329 mapping->charlens = NULL;
2333 /* Free all memory held by MAPPING (but not MAPPING itself). */
2336 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
2338 gfc_interface_sym_mapping *sym;
2339 gfc_interface_sym_mapping *nextsym;
2341 gfc_charlen *nextcl;
2343 for (sym = mapping->syms; sym; sym = nextsym)
2345 nextsym = sym->next;
2346 sym->new_sym->n.sym->formal = NULL;
2347 gfc_free_symbol (sym->new_sym->n.sym);
2348 gfc_free_expr (sym->expr);
2349 free (sym->new_sym);
2352 for (cl = mapping->charlens; cl; cl = nextcl)
2355 gfc_free_expr (cl->length);
2361 /* Return a copy of gfc_charlen CL. Add the returned structure to
2362 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2364 static gfc_charlen *
2365 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
2368 gfc_charlen *new_charlen;
2370 new_charlen = gfc_get_charlen ();
2371 new_charlen->next = mapping->charlens;
2372 new_charlen->length = gfc_copy_expr (cl->length);
2374 mapping->charlens = new_charlen;
2379 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2380 array variable that can be used as the actual argument for dummy
2381 argument SYM. Add any initialization code to BLOCK. PACKED is as
2382 for gfc_get_nodesc_array_type and DATA points to the first element
2383 in the passed array. */
2386 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
2387 gfc_packed packed, tree data)
2392 type = gfc_typenode_for_spec (&sym->ts);
2393 type = gfc_get_nodesc_array_type (type, sym->as, packed,
2394 !sym->attr.target && !sym->attr.pointer
2395 && !sym->attr.proc_pointer);
2397 var = gfc_create_var (type, "ifm");
2398 gfc_add_modify (block, var, fold_convert (type, data));
2404 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2405 and offset of descriptorless array type TYPE given that it has the same
2406 size as DESC. Add any set-up code to BLOCK. */
2409 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
2416 offset = gfc_index_zero_node;
2417 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
2419 dim = gfc_rank_cst[n];
2420 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
2421 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
2423 GFC_TYPE_ARRAY_LBOUND (type, n)
2424 = gfc_conv_descriptor_lbound_get (desc, dim);
2425 GFC_TYPE_ARRAY_UBOUND (type, n)
2426 = gfc_conv_descriptor_ubound_get (desc, dim);
2428 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
2430 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2431 gfc_array_index_type,
2432 gfc_conv_descriptor_ubound_get (desc, dim),
2433 gfc_conv_descriptor_lbound_get (desc, dim));
2434 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2435 gfc_array_index_type,
2436 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
2437 tmp = gfc_evaluate_now (tmp, block);
2438 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
2440 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2441 GFC_TYPE_ARRAY_LBOUND (type, n),
2442 GFC_TYPE_ARRAY_STRIDE (type, n));
2443 offset = fold_build2_loc (input_location, MINUS_EXPR,
2444 gfc_array_index_type, offset, tmp);
2446 offset = gfc_evaluate_now (offset, block);
2447 GFC_TYPE_ARRAY_OFFSET (type) = offset;
2451 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2452 in SE. The caller may still use se->expr and se->string_length after
2453 calling this function. */
2456 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
2457 gfc_symbol * sym, gfc_se * se,
2460 gfc_interface_sym_mapping *sm;
2464 gfc_symbol *new_sym;
2466 gfc_symtree *new_symtree;
2468 /* Create a new symbol to represent the actual argument. */
2469 new_sym = gfc_new_symbol (sym->name, NULL);
2470 new_sym->ts = sym->ts;
2471 new_sym->as = gfc_copy_array_spec (sym->as);
2472 new_sym->attr.referenced = 1;
2473 new_sym->attr.dimension = sym->attr.dimension;
2474 new_sym->attr.contiguous = sym->attr.contiguous;
2475 new_sym->attr.codimension = sym->attr.codimension;
2476 new_sym->attr.pointer = sym->attr.pointer;
2477 new_sym->attr.allocatable = sym->attr.allocatable;
2478 new_sym->attr.flavor = sym->attr.flavor;
2479 new_sym->attr.function = sym->attr.function;
2481 /* Ensure that the interface is available and that
2482 descriptors are passed for array actual arguments. */
2483 if (sym->attr.flavor == FL_PROCEDURE)
2485 new_sym->formal = expr->symtree->n.sym->formal;
2486 new_sym->attr.always_explicit
2487 = expr->symtree->n.sym->attr.always_explicit;
2490 /* Create a fake symtree for it. */
2492 new_symtree = gfc_new_symtree (&root, sym->name);
2493 new_symtree->n.sym = new_sym;
2494 gcc_assert (new_symtree == root);
2496 /* Create a dummy->actual mapping. */
2497 sm = XCNEW (gfc_interface_sym_mapping);
2498 sm->next = mapping->syms;
2500 sm->new_sym = new_symtree;
2501 sm->expr = gfc_copy_expr (expr);
2504 /* Stabilize the argument's value. */
2505 if (!sym->attr.function && se)
2506 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2508 if (sym->ts.type == BT_CHARACTER)
2510 /* Create a copy of the dummy argument's length. */
2511 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
2512 sm->expr->ts.u.cl = new_sym->ts.u.cl;
2514 /* If the length is specified as "*", record the length that
2515 the caller is passing. We should use the callee's length
2516 in all other cases. */
2517 if (!new_sym->ts.u.cl->length && se)
2519 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
2520 new_sym->ts.u.cl->backend_decl = se->string_length;
2527 /* Use the passed value as-is if the argument is a function. */
2528 if (sym->attr.flavor == FL_PROCEDURE)
2531 /* If the argument is either a string or a pointer to a string,
2532 convert it to a boundless character type. */
2533 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
2535 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
2536 tmp = build_pointer_type (tmp);
2537 if (sym->attr.pointer)
2538 value = build_fold_indirect_ref_loc (input_location,
2542 value = fold_convert (tmp, value);
2545 /* If the argument is a scalar, a pointer to an array or an allocatable,
2547 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
2548 value = build_fold_indirect_ref_loc (input_location,
2551 /* For character(*), use the actual argument's descriptor. */
2552 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
2553 value = build_fold_indirect_ref_loc (input_location,
2556 /* If the argument is an array descriptor, use it to determine
2557 information about the actual argument's shape. */
2558 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
2559 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
2561 /* Get the actual argument's descriptor. */
2562 desc = build_fold_indirect_ref_loc (input_location,
2565 /* Create the replacement variable. */
2566 tmp = gfc_conv_descriptor_data_get (desc);
2567 value = gfc_get_interface_mapping_array (&se->pre, sym,
2570 /* Use DESC to work out the upper bounds, strides and offset. */
2571 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
2574 /* Otherwise we have a packed array. */
2575 value = gfc_get_interface_mapping_array (&se->pre, sym,
2576 PACKED_FULL, se->expr);
2578 new_sym->backend_decl = value;
2582 /* Called once all dummy argument mappings have been added to MAPPING,
2583 but before the mapping is used to evaluate expressions. Pre-evaluate
2584 the length of each argument, adding any initialization code to PRE and
2585 any finalization code to POST. */
2588 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
2589 stmtblock_t * pre, stmtblock_t * post)
2591 gfc_interface_sym_mapping *sym;
2595 for (sym = mapping->syms; sym; sym = sym->next)
2596 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
2597 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
2599 expr = sym->new_sym->n.sym->ts.u.cl->length;
2600 gfc_apply_interface_mapping_to_expr (mapping, expr);
2601 gfc_init_se (&se, NULL);
2602 gfc_conv_expr (&se, expr);
2603 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
2604 se.expr = gfc_evaluate_now (se.expr, &se.pre);
2605 gfc_add_block_to_block (pre, &se.pre);
2606 gfc_add_block_to_block (post, &se.post);
2608 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
2613 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2617 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
2618 gfc_constructor_base base)
2621 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2623 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2626 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2627 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2628 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2634 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2638 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2643 for (; ref; ref = ref->next)
2647 for (n = 0; n < ref->u.ar.dimen; n++)
2649 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2650 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2651 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2653 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2660 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2661 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2667 /* Convert intrinsic function calls into result expressions. */
2670 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2678 arg1 = expr->value.function.actual->expr;
2679 if (expr->value.function.actual->next)
2680 arg2 = expr->value.function.actual->next->expr;
2684 sym = arg1->symtree->n.sym;
2686 if (sym->attr.dummy)
2691 switch (expr->value.function.isym->id)
2694 /* TODO figure out why this condition is necessary. */
2695 if (sym->attr.function
2696 && (arg1->ts.u.cl->length == NULL
2697 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2698 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2701 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2705 if (!sym->as || sym->as->rank == 0)
2708 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2710 dup = mpz_get_si (arg2->value.integer);
2715 dup = sym->as->rank;
2719 for (; d < dup; d++)
2723 if (!sym->as->upper[d] || !sym->as->lower[d])
2725 gfc_free_expr (new_expr);
2729 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2730 gfc_get_int_expr (gfc_default_integer_kind,
2732 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2734 new_expr = gfc_multiply (new_expr, tmp);
2740 case GFC_ISYM_LBOUND:
2741 case GFC_ISYM_UBOUND:
2742 /* TODO These implementations of lbound and ubound do not limit if
2743 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2745 if (!sym->as || sym->as->rank == 0)
2748 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2749 d = mpz_get_si (arg2->value.integer) - 1;
2751 /* TODO: If the need arises, this could produce an array of
2755 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2757 if (sym->as->lower[d])
2758 new_expr = gfc_copy_expr (sym->as->lower[d]);
2762 if (sym->as->upper[d])
2763 new_expr = gfc_copy_expr (sym->as->upper[d]);
2771 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2775 gfc_replace_expr (expr, new_expr);
2781 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2782 gfc_interface_mapping * mapping)
2784 gfc_formal_arglist *f;
2785 gfc_actual_arglist *actual;
2787 actual = expr->value.function.actual;
2788 f = map_expr->symtree->n.sym->formal;
2790 for (; f && actual; f = f->next, actual = actual->next)
2795 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2798 if (map_expr->symtree->n.sym->attr.dimension)
2803 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2805 for (d = 0; d < as->rank; d++)
2807 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2808 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2811 expr->value.function.esym->as = as;
2814 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2816 expr->value.function.esym->ts.u.cl->length
2817 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2819 gfc_apply_interface_mapping_to_expr (mapping,
2820 expr->value.function.esym->ts.u.cl->length);
2825 /* EXPR is a copy of an expression that appeared in the interface
2826 associated with MAPPING. Walk it recursively looking for references to
2827 dummy arguments that MAPPING maps to actual arguments. Replace each such
2828 reference with a reference to the associated actual argument. */
2831 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2834 gfc_interface_sym_mapping *sym;
2835 gfc_actual_arglist *actual;
2840 /* Copying an expression does not copy its length, so do that here. */
2841 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2843 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2844 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2847 /* Apply the mapping to any references. */
2848 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2850 /* ...and to the expression's symbol, if it has one. */
2851 /* TODO Find out why the condition on expr->symtree had to be moved into
2852 the loop rather than being outside it, as originally. */
2853 for (sym = mapping->syms; sym; sym = sym->next)
2854 if (expr->symtree && sym->old == expr->symtree->n.sym)
2856 if (sym->new_sym->n.sym->backend_decl)
2857 expr->symtree = sym->new_sym;
2859 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2860 /* Replace base type for polymorphic arguments. */
2861 if (expr->ref && expr->ref->type == REF_COMPONENT
2862 && sym->expr && sym->expr->ts.type == BT_CLASS)
2863 expr->ref->u.c.sym = sym->expr->ts.u.derived;
2866 /* ...and to subexpressions in expr->value. */
2867 switch (expr->expr_type)
2872 case EXPR_SUBSTRING:
2876 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2877 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2881 for (actual = expr->value.function.actual; actual; actual = actual->next)
2882 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2884 if (expr->value.function.esym == NULL
2885 && expr->value.function.isym != NULL
2886 && expr->value.function.actual->expr->symtree
2887 && gfc_map_intrinsic_function (expr, mapping))
2890 for (sym = mapping->syms; sym; sym = sym->next)
2891 if (sym->old == expr->value.function.esym)
2893 expr->value.function.esym = sym->new_sym->n.sym;
2894 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2895 expr->value.function.esym->result = sym->new_sym->n.sym;
2900 case EXPR_STRUCTURE:
2901 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2914 /* Evaluate interface expression EXPR using MAPPING. Store the result
2918 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2919 gfc_se * se, gfc_expr * expr)
2921 expr = gfc_copy_expr (expr);
2922 gfc_apply_interface_mapping_to_expr (mapping, expr);
2923 gfc_conv_expr (se, expr);
2924 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2925 gfc_free_expr (expr);
2929 /* Returns a reference to a temporary array into which a component of
2930 an actual argument derived type array is copied and then returned
2931 after the function call. */
2933 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2934 sym_intent intent, bool formal_ptr)
2942 gfc_array_info *info;
2952 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2954 gfc_init_se (&lse, NULL);
2955 gfc_init_se (&rse, NULL);
2957 /* Walk the argument expression. */
2958 rss = gfc_walk_expr (expr);
2960 gcc_assert (rss != gfc_ss_terminator);
2962 /* Initialize the scalarizer. */
2963 gfc_init_loopinfo (&loop);
2964 gfc_add_ss_to_loop (&loop, rss);
2966 /* Calculate the bounds of the scalarization. */
2967 gfc_conv_ss_startstride (&loop);
2969 /* Build an ss for the temporary. */
2970 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2971 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2973 base_type = gfc_typenode_for_spec (&expr->ts);
2974 if (GFC_ARRAY_TYPE_P (base_type)
2975 || GFC_DESCRIPTOR_TYPE_P (base_type))
2976 base_type = gfc_get_element_type (base_type);
2978 if (expr->ts.type == BT_CLASS)
2979 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
2981 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
2982 ? expr->ts.u.cl->backend_decl
2986 parmse->string_length = loop.temp_ss->info->string_length;
2988 /* Associate the SS with the loop. */
2989 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2991 /* Setup the scalarizing loops. */
2992 gfc_conv_loop_setup (&loop, &expr->where);
2994 /* Pass the temporary descriptor back to the caller. */
2995 info = &loop.temp_ss->info->data.array;
2996 parmse->expr = info->descriptor;
2998 /* Setup the gfc_se structures. */
2999 gfc_copy_loopinfo_to_se (&lse, &loop);
3000 gfc_copy_loopinfo_to_se (&rse, &loop);
3003 lse.ss = loop.temp_ss;
3004 gfc_mark_ss_chain_used (rss, 1);
3005 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3007 /* Start the scalarized loop body. */
3008 gfc_start_scalarized_body (&loop, &body);
3010 /* Translate the expression. */
3011 gfc_conv_expr (&rse, expr);
3013 gfc_conv_tmp_array_ref (&lse);
3015 if (intent != INTENT_OUT)
3017 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
3018 gfc_add_expr_to_block (&body, tmp);
3019 gcc_assert (rse.ss == gfc_ss_terminator);
3020 gfc_trans_scalarizing_loops (&loop, &body);
3024 /* Make sure that the temporary declaration survives by merging
3025 all the loop declarations into the current context. */
3026 for (n = 0; n < loop.dimen; n++)
3028 gfc_merge_block_scope (&body);
3029 body = loop.code[loop.order[n]];
3031 gfc_merge_block_scope (&body);
3034 /* Add the post block after the second loop, so that any
3035 freeing of allocated memory is done at the right time. */
3036 gfc_add_block_to_block (&parmse->pre, &loop.pre);
3038 /**********Copy the temporary back again.*********/
3040 gfc_init_se (&lse, NULL);
3041 gfc_init_se (&rse, NULL);
3043 /* Walk the argument expression. */
3044 lss = gfc_walk_expr (expr);
3045 rse.ss = loop.temp_ss;
3048 /* Initialize the scalarizer. */
3049 gfc_init_loopinfo (&loop2);
3050 gfc_add_ss_to_loop (&loop2, lss);
3052 /* Calculate the bounds of the scalarization. */
3053 gfc_conv_ss_startstride (&loop2);
3055 /* Setup the scalarizing loops. */
3056 gfc_conv_loop_setup (&loop2, &expr->where);
3058 gfc_copy_loopinfo_to_se (&lse, &loop2);
3059 gfc_copy_loopinfo_to_se (&rse, &loop2);
3061 gfc_mark_ss_chain_used (lss, 1);
3062 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3064 /* Declare the variable to hold the temporary offset and start the
3065 scalarized loop body. */
3066 offset = gfc_create_var (gfc_array_index_type, NULL);
3067 gfc_start_scalarized_body (&loop2, &body);
3069 /* Build the offsets for the temporary from the loop variables. The
3070 temporary array has lbounds of zero and strides of one in all
3071 dimensions, so this is very simple. The offset is only computed
3072 outside the innermost loop, so the overall transfer could be
3073 optimized further. */
3074 info = &rse.ss->info->data.array;
3075 dimen = rse.ss->dimen;
3077 tmp_index = gfc_index_zero_node;
3078 for (n = dimen - 1; n > 0; n--)
3081 tmp = rse.loop->loopvar[n];
3082 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3083 tmp, rse.loop->from[n]);
3084 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3087 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
3088 gfc_array_index_type,
3089 rse.loop->to[n-1], rse.loop->from[n-1]);
3090 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
3091 gfc_array_index_type,
3092 tmp_str, gfc_index_one_node);
3094 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
3095 gfc_array_index_type, tmp, tmp_str);
3098 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
3099 gfc_array_index_type,
3100 tmp_index, rse.loop->from[0]);
3101 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
3103 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
3104 gfc_array_index_type,
3105 rse.loop->loopvar[0], offset);
3107 /* Now use the offset for the reference. */
3108 tmp = build_fold_indirect_ref_loc (input_location,
3110 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
3112 if (expr->ts.type == BT_CHARACTER)
3113 rse.string_length = expr->ts.u.cl->backend_decl;
3115 gfc_conv_expr (&lse, expr);
3117 gcc_assert (lse.ss == gfc_ss_terminator);
3119 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
3120 gfc_add_expr_to_block (&body, tmp);
3122 /* Generate the copying loops. */
3123 gfc_trans_scalarizing_loops (&loop2, &body);
3125 /* Wrap the whole thing up by adding the second loop to the post-block
3126 and following it by the post-block of the first loop. In this way,
3127 if the temporary needs freeing, it is done after use! */
3128 if (intent != INTENT_IN)
3130 gfc_add_block_to_block (&parmse->post, &loop2.pre);
3131 gfc_add_block_to_block (&parmse->post, &loop2.post);
3134 gfc_add_block_to_block (&parmse->post, &loop.post);
3136 gfc_cleanup_loop (&loop);
3137 gfc_cleanup_loop (&loop2);
3139 /* Pass the string length to the argument expression. */
3140 if (expr->ts.type == BT_CHARACTER)
3141 parmse->string_length = expr->ts.u.cl->backend_decl;
3143 /* Determine the offset for pointer formal arguments and set the
3147 size = gfc_index_one_node;
3148 offset = gfc_index_zero_node;
3149 for (n = 0; n < dimen; n++)
3151 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
3153 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3154 gfc_array_index_type, tmp,
3155 gfc_index_one_node);
3156 gfc_conv_descriptor_ubound_set (&parmse->pre,
3160 gfc_conv_descriptor_lbound_set (&parmse->pre,
3163 gfc_index_one_node);
3164 size = gfc_evaluate_now (size, &parmse->pre);
3165 offset = fold_build2_loc (input_location, MINUS_EXPR,
3166 gfc_array_index_type,
3168 offset = gfc_evaluate_now (offset, &parmse->pre);
3169 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3170 gfc_array_index_type,
3171 rse.loop->to[n], rse.loop->from[n]);
3172 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3173 gfc_array_index_type,
3174 tmp, gfc_index_one_node);
3175 size = fold_build2_loc (input_location, MULT_EXPR,
3176 gfc_array_index_type, size, tmp);
3179 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
3183 /* We want either the address for the data or the address of the descriptor,
3184 depending on the mode of passing array arguments. */
3186 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
3188 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
3194 /* Generate the code for argument list functions. */
3197 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
3199 /* Pass by value for g77 %VAL(arg), pass the address
3200 indirectly for %LOC, else by reference. Thus %REF
3201 is a "do-nothing" and %LOC is the same as an F95
3203 if (strncmp (name, "%VAL", 4) == 0)
3204 gfc_conv_expr (se, expr);
3205 else if (strncmp (name, "%LOC", 4) == 0)
3207 gfc_conv_expr_reference (se, expr);
3208 se->expr = gfc_build_addr_expr (NULL, se->expr);
3210 else if (strncmp (name, "%REF", 4) == 0)
3211 gfc_conv_expr_reference (se, expr);
3213 gfc_error ("Unknown argument list function at %L", &expr->where);
3217 /* The following routine generates code for the intrinsic
3218 procedures from the ISO_C_BINDING module:
3220 * C_FUNLOC (function)
3221 * C_F_POINTER (subroutine)
3222 * C_F_PROCPOINTER (subroutine)
3223 * C_ASSOCIATED (function)
3224 One exception which is not handled here is C_F_POINTER with non-scalar
3225 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3228 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
3229 gfc_actual_arglist * arg)
3234 if (sym->intmod_sym_id == ISOCBINDING_LOC)
3236 if (arg->expr->rank == 0)
3237 gfc_conv_expr_reference (se, arg->expr);
3241 /* This is really the actual arg because no formal arglist is
3242 created for C_LOC. */
3243 fsym = arg->expr->symtree->n.sym;
3245 /* We should want it to do g77 calling convention. */
3247 && !(fsym->attr.pointer || fsym->attr.allocatable)
3248 && fsym->as->type != AS_ASSUMED_SHAPE;
3249 f = f || !sym->attr.always_explicit;
3251 argss = gfc_walk_expr (arg->expr);
3252 gfc_conv_array_parameter (se, arg->expr, argss, f,
3256 /* TODO -- the following two lines shouldn't be necessary, but if
3257 they're removed, a bug is exposed later in the code path.
3258 This workaround was thus introduced, but will have to be
3259 removed; please see PR 35150 for details about the issue. */
3260 se->expr = convert (pvoid_type_node, se->expr);
3261 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3265 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
3267 arg->expr->ts.type = sym->ts.u.derived->ts.type;
3268 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
3269 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
3270 gfc_conv_expr_reference (se, arg->expr);
3274 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
3275 && arg->next->expr->rank == 0)
3276 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3278 /* Convert c_f_pointer if fptr is a scalar
3279 and convert c_f_procpointer. */
3283 gfc_init_se (&cptrse, NULL);
3284 gfc_conv_expr (&cptrse, arg->expr);
3285 gfc_add_block_to_block (&se->pre, &cptrse.pre);
3286 gfc_add_block_to_block (&se->post, &cptrse.post);
3288 gfc_init_se (&fptrse, NULL);
3289 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
3290 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
3291 fptrse.want_pointer = 1;
3293 gfc_conv_expr (&fptrse, arg->next->expr);
3294 gfc_add_block_to_block (&se->pre, &fptrse.pre);
3295 gfc_add_block_to_block (&se->post, &fptrse.post);
3297 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
3298 && arg->next->expr->symtree->n.sym->attr.dummy)
3299 fptrse.expr = build_fold_indirect_ref_loc (input_location,
3302 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
3303 TREE_TYPE (fptrse.expr),
3305 fold_convert (TREE_TYPE (fptrse.expr),
3310 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3315 /* Build the addr_expr for the first argument. The argument is
3316 already an *address* so we don't need to set want_pointer in
3318 gfc_init_se (&arg1se, NULL);
3319 gfc_conv_expr (&arg1se, arg->expr);
3320 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3321 gfc_add_block_to_block (&se->post, &arg1se.post);
3323 /* See if we were given two arguments. */
3324 if (arg->next == NULL)
3325 /* Only given one arg so generate a null and do a
3326 not-equal comparison against the first arg. */
3327 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3329 fold_convert (TREE_TYPE (arg1se.expr),
3330 null_pointer_node));
3336 /* Given two arguments so build the arg2se from second arg. */
3337 gfc_init_se (&arg2se, NULL);
3338 gfc_conv_expr (&arg2se, arg->next->expr);
3339 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3340 gfc_add_block_to_block (&se->post, &arg2se.post);
3342 /* Generate test to compare that the two args are equal. */
3343 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3344 arg1se.expr, arg2se.expr);
3345 /* Generate test to ensure that the first arg is not null. */
3346 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
3348 arg1se.expr, null_pointer_node);
3350 /* Finally, the generated test must check that both arg1 is not
3351 NULL and that it is equal to the second arg. */
3352 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3354 not_null_expr, eq_expr);
3360 /* Nothing was done. */
3365 /* Generate code for a procedure call. Note can return se->post != NULL.
3366 If se->direct_byref is set then se->expr contains the return parameter.
3367 Return nonzero, if the call has alternate specifiers.
3368 'expr' is only needed for procedure pointer components. */
3371 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
3372 gfc_actual_arglist * args, gfc_expr * expr,
3373 VEC(tree,gc) *append_args)
3375 gfc_interface_mapping mapping;
3376 VEC(tree,gc) *arglist;
3377 VEC(tree,gc) *retargs;
3382 gfc_array_info *info;
3389 VEC(tree,gc) *stringargs;
3391 gfc_formal_arglist *formal;
3392 gfc_actual_arglist *arg;
3393 int has_alternate_specifier = 0;
3394 bool need_interface_mapping;
3401 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
3402 gfc_component *comp = NULL;
3412 if (sym->from_intmod == INTMOD_ISO_C_BINDING
3413 && conv_isocbinding_procedure (se, sym, args))
3416 gfc_is_proc_ptr_comp (expr, &comp);
3420 if (!sym->attr.elemental && !(comp && comp->attr.elemental))
3422 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
3423 if (se->ss->info->useflags)
3425 gcc_assert ((!comp && gfc_return_by_reference (sym)
3426 && sym->result->attr.dimension)
3427 || (comp && comp->attr.dimension));
3428 gcc_assert (se->loop != NULL);
3430 /* Access the previously obtained result. */
3431 gfc_conv_tmp_array_ref (se);
3435 info = &se->ss->info->data.array;
3440 gfc_init_block (&post);
3441 gfc_init_interface_mapping (&mapping);
3444 formal = sym->formal;
3445 need_interface_mapping = sym->attr.dimension ||
3446 (sym->ts.type == BT_CHARACTER
3447 && sym->ts.u.cl->length
3448 && sym->ts.u.cl->length->expr_type
3453 formal = comp->formal;
3454 need_interface_mapping = comp->attr.dimension ||
3455 (comp->ts.type == BT_CHARACTER
3456 && comp->ts.u.cl->length
3457 && comp->ts.u.cl->length->expr_type
3461 base_object = NULL_TREE;
3463 /* Evaluate the arguments. */
3464 for (arg = args; arg != NULL;
3465 arg = arg->next, formal = formal ? formal->next : NULL)
3468 fsym = formal ? formal->sym : NULL;
3469 parm_kind = MISSING;
3471 /* Class array expressions are sometimes coming completely unadorned
3472 with either arrayspec or _data component. Correct that here.
3473 OOP-TODO: Move this to the frontend. */
3474 if (e && e->expr_type == EXPR_VARIABLE
3476 && e->ts.type == BT_CLASS
3477 && CLASS_DATA (e)->attr.dimension)
3479 gfc_typespec temp_ts = e->ts;
3480 gfc_add_class_array_ref (e);
3486 if (se->ignore_optional)
3488 /* Some intrinsics have already been resolved to the correct
3492 else if (arg->label)
3494 has_alternate_specifier = 1;
3499 /* Pass a NULL pointer for an absent arg. */
3500 gfc_init_se (&parmse, NULL);
3501 parmse.expr = null_pointer_node;
3502 if (arg->missing_arg_type == BT_CHARACTER)
3503 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
3506 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
3508 /* Pass a NULL pointer to denote an absent arg. */
3509 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
3510 gfc_init_se (&parmse, NULL);
3511 parmse.expr = null_pointer_node;
3512 if (arg->missing_arg_type == BT_CHARACTER)
3513 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
3515 else if (fsym && fsym->ts.type == BT_CLASS
3516 && e->ts.type == BT_DERIVED)
3518 /* The derived type needs to be converted to a temporary
3520 gfc_init_se (&parmse, se);
3521 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
3523 else if (se->ss && se->ss->info->useflags)
3525 /* An elemental function inside a scalarized loop. */
3526 gfc_init_se (&parmse, se);
3527 parm_kind = ELEMENTAL;
3529 if (se->ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
3530 && se->ss->info->data.array.ref == NULL)
3532 gfc_conv_tmp_array_ref (&parmse);
3533 if (e->ts.type == BT_CHARACTER)
3534 gfc_conv_string_parameter (&parmse);
3536 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3539 gfc_conv_expr_reference (&parmse, e);
3541 /* The scalarizer does not repackage the reference to a class
3542 array - instead it returns a pointer to the data element. */
3543 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
3544 gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
3548 /* A scalar or transformational function. */
3549 gfc_init_se (&parmse, NULL);
3550 argss = gfc_walk_expr (e);
3552 if (argss == gfc_ss_terminator)
3554 if (e->expr_type == EXPR_VARIABLE
3555 && e->symtree->n.sym->attr.cray_pointee
3556 && fsym && fsym->attr.flavor == FL_PROCEDURE)
3558 /* The Cray pointer needs to be converted to a pointer to
3559 a type given by the expression. */
3560 gfc_conv_expr (&parmse, e);
3561 type = build_pointer_type (TREE_TYPE (parmse.expr));
3562 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
3563 parmse.expr = convert (type, tmp);
3565 else if (fsym && fsym->attr.value)
3567 if (fsym->ts.type == BT_CHARACTER
3568 && fsym->ts.is_c_interop
3569 && fsym->ns->proc_name != NULL
3570 && fsym->ns->proc_name->attr.is_bind_c)
3573 gfc_conv_scalar_char_value (fsym, &parmse, &e);
3574 if (parmse.expr == NULL)
3575 gfc_conv_expr (&parmse, e);
3578 gfc_conv_expr (&parmse, e);
3580 else if (arg->name && arg->name[0] == '%')
3581 /* Argument list functions %VAL, %LOC and %REF are signalled
3582 through arg->name. */
3583 conv_arglist_function (&parmse, arg->expr, arg->name);
3584 else if ((e->expr_type == EXPR_FUNCTION)
3585 && ((e->value.function.esym
3586 && e->value.function.esym->result->attr.pointer)
3587 || (!e->value.function.esym
3588 && e->symtree->n.sym->attr.pointer))
3589 && fsym && fsym->attr.target)
3591 gfc_conv_expr (&parmse, e);
3592 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3594 else if (e->expr_type == EXPR_FUNCTION
3595 && e->symtree->n.sym->result
3596 && e->symtree->n.sym->result != e->symtree->n.sym
3597 && e->symtree->n.sym->result->attr.proc_pointer)
3599 /* Functions returning procedure pointers. */
3600 gfc_conv_expr (&parmse, e);
3601 if (fsym && fsym->attr.proc_pointer)
3602 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3606 gfc_conv_expr_reference (&parmse, e);
3608 /* Catch base objects that are not variables. */
3609 if (e->ts.type == BT_CLASS
3610 && e->expr_type != EXPR_VARIABLE
3611 && expr && e == expr->base_expr)
3612 base_object = build_fold_indirect_ref_loc (input_location,
3615 /* A class array element needs converting back to be a
3616 class object, if the formal argument is a class object. */
3617 if (fsym && fsym->ts.type == BT_CLASS
3618 && e->ts.type == BT_CLASS
3619 && CLASS_DATA (e)->attr.dimension)
3620 gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
3622 if (fsym && fsym->ts.type == BT_DERIVED
3623 && e->ts.type == BT_CLASS
3624 && !CLASS_DATA (e)->attr.dimension
3625 && !CLASS_DATA (e)->attr.codimension)
3626 parmse.expr = gfc_class_data_get (parmse.expr);
3628 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3629 allocated on entry, it must be deallocated. */
3630 if (fsym && fsym->attr.allocatable
3631 && fsym->attr.intent == INTENT_OUT)
3635 gfc_init_block (&block);
3636 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3637 NULL_TREE, NULL_TREE,
3638 NULL_TREE, true, NULL,
3640 gfc_add_expr_to_block (&block, tmp);
3641 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3642 void_type_node, parmse.expr,
3644 gfc_add_expr_to_block (&block, tmp);
3646 if (fsym->attr.optional
3647 && e->expr_type == EXPR_VARIABLE
3648 && e->symtree->n.sym->attr.optional)
3650 tmp = fold_build3_loc (input_location, COND_EXPR,
3652 gfc_conv_expr_present (e->symtree->n.sym),
3653 gfc_finish_block (&block),
3654 build_empty_stmt (input_location));
3657 tmp = gfc_finish_block (&block);
3659 gfc_add_expr_to_block (&se->pre, tmp);
3662 if (fsym && e->expr_type != EXPR_NULL
3663 && ((fsym->attr.pointer
3664 && fsym->attr.flavor != FL_PROCEDURE)
3665 || (fsym->attr.proc_pointer
3666 && !(e->expr_type == EXPR_VARIABLE
3667 && e->symtree->n.sym->attr.dummy))
3668 || (fsym->attr.proc_pointer
3669 && e->expr_type == EXPR_VARIABLE
3670 && gfc_is_proc_ptr_comp (e, NULL))
3671 || (fsym->attr.allocatable
3672 && fsym->attr.flavor != FL_PROCEDURE)))
3674 /* Scalar pointer dummy args require an extra level of
3675 indirection. The null pointer already contains
3676 this level of indirection. */
3677 parm_kind = SCALAR_POINTER;
3678 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3682 else if (e->ts.type == BT_CLASS
3683 && fsym && fsym->ts.type == BT_CLASS
3684 && CLASS_DATA (fsym)->attr.dimension)
3686 /* Pass a class array. */
3687 gfc_init_se (&parmse, se);
3688 gfc_conv_expr_descriptor (&parmse, e, argss);
3689 /* The conversion does not repackage the reference to a class
3690 array - _data descriptor. */
3691 gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
3695 /* If the procedure requires an explicit interface, the actual
3696 argument is passed according to the corresponding formal
3697 argument. If the corresponding formal argument is a POINTER,
3698 ALLOCATABLE or assumed shape, we do not use g77's calling
3699 convention, and pass the address of the array descriptor
3700 instead. Otherwise we use g77's calling convention. */
3703 && !(fsym->attr.pointer || fsym->attr.allocatable)
3704 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3706 f = f || !comp->attr.always_explicit;
3708 f = f || !sym->attr.always_explicit;
3710 /* If the argument is a function call that may not create
3711 a temporary for the result, we have to check that we
3712 can do it, i.e. that there is no alias between this
3713 argument and another one. */
3714 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3720 intent = fsym->attr.intent;
3722 intent = INTENT_UNKNOWN;
3724 if (gfc_check_fncall_dependency (e, intent, sym, args,
3726 parmse.force_tmp = 1;
3728 iarg = e->value.function.actual->expr;
3730 /* Temporary needed if aliasing due to host association. */
3731 if (sym->attr.contained
3733 && !sym->attr.implicit_pure
3734 && !sym->attr.use_assoc
3735 && iarg->expr_type == EXPR_VARIABLE
3736 && sym->ns == iarg->symtree->n.sym->ns)
3737 parmse.force_tmp = 1;
3739 /* Ditto within module. */
3740 if (sym->attr.use_assoc
3742 && !sym->attr.implicit_pure
3743 && iarg->expr_type == EXPR_VARIABLE
3744 && sym->module == iarg->symtree->n.sym->module)
3745 parmse.force_tmp = 1;
3748 if (e->expr_type == EXPR_VARIABLE
3749 && is_subref_array (e))
3750 /* The actual argument is a component reference to an
3751 array of derived types. In this case, the argument
3752 is converted to a temporary, which is passed and then
3753 written back after the procedure call. */
3754 gfc_conv_subref_array_arg (&parmse, e, f,
3755 fsym ? fsym->attr.intent : INTENT_INOUT,
3756 fsym && fsym->attr.pointer);
3757 else if (gfc_is_class_array_ref (e, NULL)
3758 && fsym && fsym->ts.type == BT_DERIVED)
3759 /* The actual argument is a component reference to an
3760 array of derived types. In this case, the argument
3761 is converted to a temporary, which is passed and then
3762 written back after the procedure call.
3763 OOP-TODO: Insert code so that if the dynamic type is
3764 the same as the declared type, copy-in/copy-out does
3766 gfc_conv_subref_array_arg (&parmse, e, f,
3767 fsym ? fsym->attr.intent : INTENT_INOUT,
3768 fsym && fsym->attr.pointer);
3770 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3773 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3774 allocated on entry, it must be deallocated. */
3775 if (fsym && fsym->attr.allocatable
3776 && fsym->attr.intent == INTENT_OUT)
3778 tmp = build_fold_indirect_ref_loc (input_location,
3780 tmp = gfc_trans_dealloc_allocated (tmp, false);
3781 if (fsym->attr.optional
3782 && e->expr_type == EXPR_VARIABLE
3783 && e->symtree->n.sym->attr.optional)
3784 tmp = fold_build3_loc (input_location, COND_EXPR,
3786 gfc_conv_expr_present (e->symtree->n.sym),
3787 tmp, build_empty_stmt (input_location));
3788 gfc_add_expr_to_block (&se->pre, tmp);
3793 /* The case with fsym->attr.optional is that of a user subroutine
3794 with an interface indicating an optional argument. When we call
3795 an intrinsic subroutine, however, fsym is NULL, but we might still
3796 have an optional argument, so we proceed to the substitution
3798 if (e && (fsym == NULL || fsym->attr.optional))
3800 /* If an optional argument is itself an optional dummy argument,
3801 check its presence and substitute a null if absent. This is
3802 only needed when passing an array to an elemental procedure
3803 as then array elements are accessed - or no NULL pointer is
3804 allowed and a "1" or "0" should be passed if not present.
3805 When passing a non-array-descriptor full array to a
3806 non-array-descriptor dummy, no check is needed. For
3807 array-descriptor actual to array-descriptor dummy, see
3808 PR 41911 for why a check has to be inserted.
3809 fsym == NULL is checked as intrinsics required the descriptor
3810 but do not always set fsym. */
3811 if (e->expr_type == EXPR_VARIABLE
3812 && e->symtree->n.sym->attr.optional
3813 && ((e->rank > 0 && sym->attr.elemental)
3814 || e->representation.length || e->ts.type == BT_CHARACTER
3818 && (fsym->as->type == AS_ASSUMED_SHAPE
3819 || fsym->as->type == AS_DEFERRED))))))
3820 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3821 e->representation.length);
3826 /* Obtain the character length of an assumed character length
3827 length procedure from the typespec. */
3828 if (fsym->ts.type == BT_CHARACTER
3829 && parmse.string_length == NULL_TREE
3830 && e->ts.type == BT_PROCEDURE
3831 && e->symtree->n.sym->ts.type == BT_CHARACTER
3832 && e->symtree->n.sym->ts.u.cl->length != NULL
3833 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3835 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3836 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3840 if (fsym && need_interface_mapping && e)
3841 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3843 gfc_add_block_to_block (&se->pre, &parmse.pre);
3844 gfc_add_block_to_block (&post, &parmse.post);
3846 /* Allocated allocatable components of derived types must be
3847 deallocated for non-variable scalars. Non-variable arrays are
3848 dealt with in trans-array.c(gfc_conv_array_parameter). */
3849 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
3850 && e->ts.u.derived->attr.alloc_comp
3851 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3852 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3855 tmp = build_fold_indirect_ref_loc (input_location,
3857 parm_rank = e->rank;
3865 case (SCALAR_POINTER):
3866 tmp = build_fold_indirect_ref_loc (input_location,
3871 if (e->expr_type == EXPR_OP
3872 && e->value.op.op == INTRINSIC_PARENTHESES
3873 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3876 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3877 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3878 gfc_add_expr_to_block (&se->post, local_tmp);
3881 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
3883 /* The derived type is passed to gfc_deallocate_alloc_comp.
3884 Therefore, class actuals can handled correctly but derived
3885 types passed to class formals need the _data component. */
3886 tmp = gfc_class_data_get (tmp);
3887 if (!CLASS_DATA (fsym)->attr.dimension)
3888 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3891 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3893 gfc_add_expr_to_block (&se->post, tmp);
3896 /* Add argument checking of passing an unallocated/NULL actual to
3897 a nonallocatable/nonpointer dummy. */
3899 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3901 symbol_attribute attr;
3905 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3906 attr = gfc_expr_attr (e);
3908 goto end_pointer_check;
3910 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3911 allocatable to an optional dummy, cf. 12.5.2.12. */
3912 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
3913 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3914 goto end_pointer_check;
3918 /* If the actual argument is an optional pointer/allocatable and
3919 the formal argument takes an nonpointer optional value,
3920 it is invalid to pass a non-present argument on, even
3921 though there is no technical reason for this in gfortran.
3922 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3923 tree present, null_ptr, type;
3925 if (attr.allocatable
3926 && (fsym == NULL || !fsym->attr.allocatable))
3927 asprintf (&msg, "Allocatable actual argument '%s' is not "
3928 "allocated or not present", e->symtree->n.sym->name);
3929 else if (attr.pointer
3930 && (fsym == NULL || !fsym->attr.pointer))
3931 asprintf (&msg, "Pointer actual argument '%s' is not "
3932 "associated or not present",
3933 e->symtree->n.sym->name);
3934 else if (attr.proc_pointer
3935 && (fsym == NULL || !fsym->attr.proc_pointer))
3936 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3937 "associated or not present",
3938 e->symtree->n.sym->name);
3940 goto end_pointer_check;
3942 present = gfc_conv_expr_present (e->symtree->n.sym);
3943 type = TREE_TYPE (present);
3944 present = fold_build2_loc (input_location, EQ_EXPR,
3945 boolean_type_node, present,
3947 null_pointer_node));
3948 type = TREE_TYPE (parmse.expr);
3949 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3950 boolean_type_node, parmse.expr,
3952 null_pointer_node));
3953 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3954 boolean_type_node, present, null_ptr);
3958 if (attr.allocatable
3959 && (fsym == NULL || !fsym->attr.allocatable))
3960 asprintf (&msg, "Allocatable actual argument '%s' is not "
3961 "allocated", e->symtree->n.sym->name);
3962 else if (attr.pointer
3963 && (fsym == NULL || !fsym->attr.pointer))
3964 asprintf (&msg, "Pointer actual argument '%s' is not "
3965 "associated", e->symtree->n.sym->name);
3966 else if (attr.proc_pointer
3967 && (fsym == NULL || !fsym->attr.proc_pointer))
3968 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3969 "associated", e->symtree->n.sym->name);
3971 goto end_pointer_check;
3975 /* If the argument is passed by value, we need to strip the
3977 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
3978 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3980 cond = fold_build2_loc (input_location, EQ_EXPR,
3981 boolean_type_node, tmp,
3982 fold_convert (TREE_TYPE (tmp),
3983 null_pointer_node));
3986 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3992 /* Deferred length dummies pass the character length by reference
3993 so that the value can be returned. */
3994 if (parmse.string_length && fsym && fsym->ts.deferred)
3996 tmp = parmse.string_length;
3997 if (TREE_CODE (tmp) != VAR_DECL)
3998 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
3999 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
4002 /* Character strings are passed as two parameters, a length and a
4003 pointer - except for Bind(c) which only passes the pointer. */
4004 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
4005 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
4007 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4008 pass the token and the offset as additional arguments. */
4009 if (fsym && fsym->attr.codimension
4010 && gfc_option.coarray == GFC_FCOARRAY_LIB
4011 && !fsym->attr.allocatable
4014 /* Token and offset. */
4015 VEC_safe_push (tree, gc, stringargs, null_pointer_node);
4016 VEC_safe_push (tree, gc, stringargs,
4017 build_int_cst (gfc_array_index_type, 0));
4018 gcc_assert (fsym->attr.optional);
4020 else if (fsym && fsym->attr.codimension
4021 && !fsym->attr.allocatable
4022 && gfc_option.coarray == GFC_FCOARRAY_LIB)
4024 tree caf_decl, caf_type;
4027 caf_decl = get_tree_for_caf_expr (e);
4028 caf_type = TREE_TYPE (caf_decl);
4030 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
4031 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
4032 tmp = gfc_conv_descriptor_token (caf_decl);
4033 else if (DECL_LANG_SPECIFIC (caf_decl)
4034 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
4035 tmp = GFC_DECL_TOKEN (caf_decl);
4038 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
4039 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
4040 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
4043 VEC_safe_push (tree, gc, stringargs, tmp);
4045 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
4046 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
4047 offset = build_int_cst (gfc_array_index_type, 0);
4048 else if (DECL_LANG_SPECIFIC (caf_decl)
4049 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
4050 offset = GFC_DECL_CAF_OFFSET (caf_decl);
4051 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
4052 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
4054 offset = build_int_cst (gfc_array_index_type, 0);
4056 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
4057 tmp = gfc_conv_descriptor_data_get (caf_decl);
4060 gcc_assert (POINTER_TYPE_P (caf_type));
4064 if (fsym->as->type == AS_ASSUMED_SHAPE)
4066 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
4067 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4068 (TREE_TYPE (parmse.expr))));
4069 tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
4070 tmp2 = gfc_conv_descriptor_data_get (tmp2);
4072 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
4073 tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
4076 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
4080 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4081 gfc_array_index_type,
4082 fold_convert (gfc_array_index_type, tmp2),
4083 fold_convert (gfc_array_index_type, tmp));
4084 offset = fold_build2_loc (input_location, PLUS_EXPR,
4085 gfc_array_index_type, offset, tmp);
4087 VEC_safe_push (tree, gc, stringargs, offset);
4090 VEC_safe_push (tree, gc, arglist, parmse.expr);
4092 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
4099 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
4100 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
4101 else if (ts.type == BT_CHARACTER)
4103 if (ts.u.cl->length == NULL)
4105 /* Assumed character length results are not allowed by 5.1.1.5 of the
4106 standard and are trapped in resolve.c; except in the case of SPREAD
4107 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4108 we take the character length of the first argument for the result.
4109 For dummies, we have to look through the formal argument list for
4110 this function and use the character length found there.*/
4111 if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
4112 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
4113 else if (!sym->attr.dummy)
4114 cl.backend_decl = VEC_index (tree, stringargs, 0);
4117 formal = sym->ns->proc_name->formal;
4118 for (; formal; formal = formal->next)
4119 if (strcmp (formal->sym->name, sym->name) == 0)
4120 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
4127 /* Calculate the length of the returned string. */
4128 gfc_init_se (&parmse, NULL);
4129 if (need_interface_mapping)
4130 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
4132 gfc_conv_expr (&parmse, ts.u.cl->length);
4133 gfc_add_block_to_block (&se->pre, &parmse.pre);
4134 gfc_add_block_to_block (&se->post, &parmse.post);
4136 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
4137 tmp = fold_build2_loc (input_location, MAX_EXPR,
4138 gfc_charlen_type_node, tmp,
4139 build_int_cst (gfc_charlen_type_node, 0));
4140 cl.backend_decl = tmp;
4143 /* Set up a charlen structure for it. */
4148 len = cl.backend_decl;
4151 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
4152 || (!comp && gfc_return_by_reference (sym));
4155 if (se->direct_byref)
4157 /* Sometimes, too much indirection can be applied; e.g. for
4158 function_result = array_valued_recursive_function. */
4159 if (TREE_TYPE (TREE_TYPE (se->expr))
4160 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
4161 && GFC_DESCRIPTOR_TYPE_P
4162 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
4163 se->expr = build_fold_indirect_ref_loc (input_location,
4166 /* If the lhs of an assignment x = f(..) is allocatable and
4167 f2003 is allowed, we must do the automatic reallocation.
4168 TODO - deal with intrinsics, without using a temporary. */
4169 if (gfc_option.flag_realloc_lhs
4170 && se->ss && se->ss->loop_chain
4171 && se->ss->loop_chain->is_alloc_lhs
4172 && !expr->value.function.isym
4173 && sym->result->as != NULL)
4175 /* Evaluate the bounds of the result, if known. */
4176 gfc_set_loop_bounds_from_array_spec (&mapping, se,
4179 /* Perform the automatic reallocation. */
4180 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
4182 gfc_add_expr_to_block (&se->pre, tmp);
4184 /* Pass the temporary as the first argument. */
4185 result = info->descriptor;
4188 result = build_fold_indirect_ref_loc (input_location,
4190 VEC_safe_push (tree, gc, retargs, se->expr);
4192 else if (comp && comp->attr.dimension)
4194 gcc_assert (se->loop && info);
4196 /* Set the type of the array. */
4197 tmp = gfc_typenode_for_spec (&comp->ts);
4198 gcc_assert (se->ss->dimen == se->loop->dimen);
4200 /* Evaluate the bounds of the result, if known. */
4201 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
4203 /* If the lhs of an assignment x = f(..) is allocatable and
4204 f2003 is allowed, we must not generate the function call
4205 here but should just send back the results of the mapping.
4206 This is signalled by the function ss being flagged. */
4207 if (gfc_option.flag_realloc_lhs
4208 && se->ss && se->ss->is_alloc_lhs)
4210 gfc_free_interface_mapping (&mapping);
4211 return has_alternate_specifier;
4214 /* Create a temporary to store the result. In case the function
4215 returns a pointer, the temporary will be a shallow copy and
4216 mustn't be deallocated. */
4217 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
4218 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4219 tmp, NULL_TREE, false,
4220 !comp->attr.pointer, callee_alloc,
4221 &se->ss->info->expr->where);
4223 /* Pass the temporary as the first argument. */
4224 result = info->descriptor;
4225 tmp = gfc_build_addr_expr (NULL_TREE, result);
4226 VEC_safe_push (tree, gc, retargs, tmp);
4228 else if (!comp && sym->result->attr.dimension)
4230 gcc_assert (se->loop && info);
4232 /* Set the type of the array. */
4233 tmp = gfc_typenode_for_spec (&ts);
4234 gcc_assert (se->ss->dimen == se->loop->dimen);
4236 /* Evaluate the bounds of the result, if known. */
4237 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
4239 /* If the lhs of an assignment x = f(..) is allocatable and
4240 f2003 is allowed, we must not generate the function call
4241 here but should just send back the results of the mapping.
4242 This is signalled by the function ss being flagged. */
4243 if (gfc_option.flag_realloc_lhs
4244 && se->ss && se->ss->is_alloc_lhs)
4246 gfc_free_interface_mapping (&mapping);
4247 return has_alternate_specifier;
4250 /* Create a temporary to store the result. In case the function
4251 returns a pointer, the temporary will be a shallow copy and
4252 mustn't be deallocated. */
4253 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
4254 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
4255 tmp, NULL_TREE, false,
4256 !sym->attr.pointer, callee_alloc,
4257 &se->ss->info->expr->where);
4259 /* Pass the temporary as the first argument. */
4260 result = info->descriptor;
4261 tmp = gfc_build_addr_expr (NULL_TREE, result);
4262 VEC_safe_push (tree, gc, retargs, tmp);
4264 else if (ts.type == BT_CHARACTER)
4266 /* Pass the string length. */
4267 type = gfc_get_character_type (ts.kind, ts.u.cl);
4268 type = build_pointer_type (type);
4270 /* Return an address to a char[0:len-1]* temporary for
4271 character pointers. */
4272 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4273 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
4275 var = gfc_create_var (type, "pstr");
4277 if ((!comp && sym->attr.allocatable)
4278 || (comp && comp->attr.allocatable))
4279 gfc_add_modify (&se->pre, var,
4280 fold_convert (TREE_TYPE (var),
4281 null_pointer_node));
4283 /* Provide an address expression for the function arguments. */
4284 var = gfc_build_addr_expr (NULL_TREE, var);
4287 var = gfc_conv_string_tmp (se, type, len);
4289 VEC_safe_push (tree, gc, retargs, var);
4293 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
4295 type = gfc_get_complex_type (ts.kind);
4296 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
4297 VEC_safe_push (tree, gc, retargs, var);
4300 if (ts.type == BT_CHARACTER && ts.deferred
4301 && (sym->attr.allocatable || sym->attr.pointer))
4304 if (TREE_CODE (tmp) != VAR_DECL)
4305 tmp = gfc_evaluate_now (len, &se->pre);
4306 len = gfc_build_addr_expr (NULL_TREE, tmp);
4309 /* Add the string length to the argument list. */
4310 if (ts.type == BT_CHARACTER)
4311 VEC_safe_push (tree, gc, retargs, len);
4313 gfc_free_interface_mapping (&mapping);
4315 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
4316 arglen = (VEC_length (tree, arglist)
4317 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
4318 VEC_reserve_exact (tree, gc, retargs, arglen);
4320 /* Add the return arguments. */
4321 VEC_splice (tree, retargs, arglist);
4323 /* Add the hidden string length parameters to the arguments. */
4324 VEC_splice (tree, retargs, stringargs);
4326 /* We may want to append extra arguments here. This is used e.g. for
4327 calls to libgfortran_matmul_??, which need extra information. */
4328 if (!VEC_empty (tree, append_args))
4329 VEC_splice (tree, retargs, append_args);
4332 /* Generate the actual call. */
4333 if (base_object == NULL_TREE)
4334 conv_function_val (se, sym, expr);
4336 conv_base_obj_fcn_val (se, base_object, expr);
4338 /* If there are alternate return labels, function type should be
4339 integer. Can't modify the type in place though, since it can be shared
4340 with other functions. For dummy arguments, the typing is done to
4341 this result, even if it has to be repeated for each call. */
4342 if (has_alternate_specifier
4343 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
4345 if (!sym->attr.dummy)
4347 TREE_TYPE (sym->backend_decl)
4348 = build_function_type (integer_type_node,
4349 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
4350 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
4353 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
4356 fntype = TREE_TYPE (TREE_TYPE (se->expr));
4357 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
4359 /* If we have a pointer function, but we don't want a pointer, e.g.
4362 where f is pointer valued, we have to dereference the result. */
4363 if (!se->want_pointer && !byref
4364 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4365 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
4366 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4368 /* f2c calling conventions require a scalar default real function to
4369 return a double precision result. Convert this back to default
4370 real. We only care about the cases that can happen in Fortran 77.
4372 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
4373 && sym->ts.kind == gfc_default_real_kind
4374 && !sym->attr.always_explicit)
4375 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
4377 /* A pure function may still have side-effects - it may modify its
4379 TREE_SIDE_EFFECTS (se->expr) = 1;
4381 if (!sym->attr.pure)
4382 TREE_SIDE_EFFECTS (se->expr) = 1;
4387 /* Add the function call to the pre chain. There is no expression. */
4388 gfc_add_expr_to_block (&se->pre, se->expr);
4389 se->expr = NULL_TREE;
4391 if (!se->direct_byref)
4393 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
4395 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4397 /* Check the data pointer hasn't been modified. This would
4398 happen in a function returning a pointer. */
4399 tmp = gfc_conv_descriptor_data_get (info->descriptor);
4400 tmp = fold_build2_loc (input_location, NE_EXPR,
4403 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
4406 se->expr = info->descriptor;
4407 /* Bundle in the string length. */
4408 se->string_length = len;
4410 else if (ts.type == BT_CHARACTER)
4412 /* Dereference for character pointer results. */
4413 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
4414 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
4415 se->expr = build_fold_indirect_ref_loc (input_location, var);
4420 se->string_length = len;
4421 else if (sym->attr.allocatable || sym->attr.pointer)
4422 se->string_length = cl.backend_decl;
4426 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
4427 se->expr = build_fold_indirect_ref_loc (input_location, var);
4432 /* Follow the function call with the argument post block. */
4435 gfc_add_block_to_block (&se->pre, &post);
4437 /* Transformational functions of derived types with allocatable
4438 components must have the result allocatable components copied. */
4439 arg = expr->value.function.actual;
4440 if (result && arg && expr->rank
4441 && expr->value.function.isym
4442 && expr->value.function.isym->transformational
4443 && arg->expr->ts.type == BT_DERIVED
4444 && arg->expr->ts.u.derived->attr.alloc_comp)
4447 /* Copy the allocatable components. We have to use a
4448 temporary here to prevent source allocatable components
4449 from being corrupted. */
4450 tmp2 = gfc_evaluate_now (result, &se->pre);
4451 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
4452 result, tmp2, expr->rank);
4453 gfc_add_expr_to_block (&se->pre, tmp);
4454 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
4456 gfc_add_expr_to_block (&se->pre, tmp);
4458 /* Finally free the temporary's data field. */
4459 tmp = gfc_conv_descriptor_data_get (tmp2);
4460 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
4461 NULL_TREE, NULL_TREE, true,
4463 gfc_add_expr_to_block (&se->pre, tmp);
4467 gfc_add_block_to_block (&se->post, &post);
4469 return has_alternate_specifier;
4473 /* Fill a character string with spaces. */
4476 fill_with_spaces (tree start, tree type, tree size)
4478 stmtblock_t block, loop;
4479 tree i, el, exit_label, cond, tmp;
4481 /* For a simple char type, we can call memset(). */
4482 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
4483 return build_call_expr_loc (input_location,
4484 builtin_decl_explicit (BUILT_IN_MEMSET),
4486 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
4487 lang_hooks.to_target_charset (' ')),
4490 /* Otherwise, we use a loop:
4491 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
4495 /* Initialize variables. */
4496 gfc_init_block (&block);
4497 i = gfc_create_var (sizetype, "i");
4498 gfc_add_modify (&block, i, fold_convert (sizetype, size));
4499 el = gfc_create_var (build_pointer_type (type), "el");
4500 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
4501 exit_label = gfc_build_label_decl (NULL_TREE);
4502 TREE_USED (exit_label) = 1;
4506 gfc_init_block (&loop);
4508 /* Exit condition. */
4509 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
4510 build_zero_cst (sizetype));
4511 tmp = build1_v (GOTO_EXPR, exit_label);
4512 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4513 build_empty_stmt (input_location));
4514 gfc_add_expr_to_block (&loop, tmp);
4517 gfc_add_modify (&loop,
4518 fold_build1_loc (input_location, INDIRECT_REF, type, el),
4519 build_int_cst (type, lang_hooks.to_target_charset (' ')));
4521 /* Increment loop variables. */
4522 gfc_add_modify (&loop, i,
4523 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
4524 TYPE_SIZE_UNIT (type)));
4525 gfc_add_modify (&loop, el,
4526 fold_build_pointer_plus_loc (input_location,
4527 el, TYPE_SIZE_UNIT (type)));
4529 /* Making the loop... actually loop! */
4530 tmp = gfc_finish_block (&loop);
4531 tmp = build1_v (LOOP_EXPR, tmp);
4532 gfc_add_expr_to_block (&block, tmp);
4534 /* The exit label. */
4535 tmp = build1_v (LABEL_EXPR, exit_label);
4536 gfc_add_expr_to_block (&block, tmp);
4539 return gfc_finish_block (&block);
4543 /* Generate code to copy a string. */
4546 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
4547 int dkind, tree slength, tree src, int skind)
4549 tree tmp, dlen, slen;
4558 stmtblock_t tempblock;
4560 gcc_assert (dkind == skind);
4562 if (slength != NULL_TREE)
4564 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
4565 ssc = gfc_string_to_single_character (slen, src, skind);
4569 slen = build_int_cst (size_type_node, 1);
4573 if (dlength != NULL_TREE)
4575 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
4576 dsc = gfc_string_to_single_character (dlen, dest, dkind);
4580 dlen = build_int_cst (size_type_node, 1);
4584 /* Assign directly if the types are compatible. */
4585 if (dsc != NULL_TREE && ssc != NULL_TREE
4586 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
4588 gfc_add_modify (block, dsc, ssc);
4592 /* Do nothing if the destination length is zero. */
4593 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
4594 build_int_cst (size_type_node, 0));
4596 /* The following code was previously in _gfortran_copy_string:
4598 // The two strings may overlap so we use memmove.
4600 copy_string (GFC_INTEGER_4 destlen, char * dest,
4601 GFC_INTEGER_4 srclen, const char * src)
4603 if (srclen >= destlen)
4605 // This will truncate if too long.
4606 memmove (dest, src, destlen);
4610 memmove (dest, src, srclen);
4612 memset (&dest[srclen], ' ', destlen - srclen);
4616 We're now doing it here for better optimization, but the logic
4619 /* For non-default character kinds, we have to multiply the string
4620 length by the base type size. */
4621 chartype = gfc_get_char_type (dkind);
4622 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4623 fold_convert (size_type_node, slen),
4624 fold_convert (size_type_node,
4625 TYPE_SIZE_UNIT (chartype)));
4626 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4627 fold_convert (size_type_node, dlen),
4628 fold_convert (size_type_node,
4629 TYPE_SIZE_UNIT (chartype)));
4631 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
4632 dest = fold_convert (pvoid_type_node, dest);
4634 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4636 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
4637 src = fold_convert (pvoid_type_node, src);
4639 src = gfc_build_addr_expr (pvoid_type_node, src);
4641 /* Truncate string if source is too long. */
4642 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
4644 tmp2 = build_call_expr_loc (input_location,
4645 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4646 3, dest, src, dlen);
4648 /* Else copy and pad with spaces. */
4649 tmp3 = build_call_expr_loc (input_location,
4650 builtin_decl_explicit (BUILT_IN_MEMMOVE),
4651 3, dest, src, slen);
4653 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
4654 tmp4 = fill_with_spaces (tmp4, chartype,
4655 fold_build2_loc (input_location, MINUS_EXPR,
4656 TREE_TYPE(dlen), dlen, slen));
4658 gfc_init_block (&tempblock);
4659 gfc_add_expr_to_block (&tempblock, tmp3);
4660 gfc_add_expr_to_block (&tempblock, tmp4);
4661 tmp3 = gfc_finish_block (&tempblock);
4663 /* The whole copy_string function is there. */
4664 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
4666 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
4667 build_empty_stmt (input_location));
4668 gfc_add_expr_to_block (block, tmp);
4672 /* Translate a statement function.
4673 The value of a statement function reference is obtained by evaluating the
4674 expression using the values of the actual arguments for the values of the
4675 corresponding dummy arguments. */
4678 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
4682 gfc_formal_arglist *fargs;
4683 gfc_actual_arglist *args;
4686 gfc_saved_var *saved_vars;
4692 sym = expr->symtree->n.sym;
4693 args = expr->value.function.actual;
4694 gfc_init_se (&lse, NULL);
4695 gfc_init_se (&rse, NULL);
4698 for (fargs = sym->formal; fargs; fargs = fargs->next)
4700 saved_vars = XCNEWVEC (gfc_saved_var, n);
4701 temp_vars = XCNEWVEC (tree, n);
4703 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4705 /* Each dummy shall be specified, explicitly or implicitly, to be
4707 gcc_assert (fargs->sym->attr.dimension == 0);
4710 if (fsym->ts.type == BT_CHARACTER)
4712 /* Copy string arguments. */
4715 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
4716 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
4718 /* Create a temporary to hold the value. */
4719 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
4720 fsym->ts.u.cl->backend_decl
4721 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
4723 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
4724 temp_vars[n] = gfc_create_var (type, fsym->name);
4726 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4728 gfc_conv_expr (&rse, args->expr);
4729 gfc_conv_string_parameter (&rse);
4730 gfc_add_block_to_block (&se->pre, &lse.pre);
4731 gfc_add_block_to_block (&se->pre, &rse.pre);
4733 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
4734 rse.string_length, rse.expr, fsym->ts.kind);
4735 gfc_add_block_to_block (&se->pre, &lse.post);
4736 gfc_add_block_to_block (&se->pre, &rse.post);
4740 /* For everything else, just evaluate the expression. */
4742 /* Create a temporary to hold the value. */
4743 type = gfc_typenode_for_spec (&fsym->ts);
4744 temp_vars[n] = gfc_create_var (type, fsym->name);
4746 gfc_conv_expr (&lse, args->expr);
4748 gfc_add_block_to_block (&se->pre, &lse.pre);
4749 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
4750 gfc_add_block_to_block (&se->pre, &lse.post);
4756 /* Use the temporary variables in place of the real ones. */
4757 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4758 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
4760 gfc_conv_expr (se, sym->value);
4762 if (sym->ts.type == BT_CHARACTER)
4764 gfc_conv_const_charlen (sym->ts.u.cl);
4766 /* Force the expression to the correct length. */
4767 if (!INTEGER_CST_P (se->string_length)
4768 || tree_int_cst_lt (se->string_length,
4769 sym->ts.u.cl->backend_decl))
4771 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
4772 tmp = gfc_create_var (type, sym->name);
4773 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
4774 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
4775 sym->ts.kind, se->string_length, se->expr,
4779 se->string_length = sym->ts.u.cl->backend_decl;
4782 /* Restore the original variables. */
4783 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4784 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4789 /* Translate a function expression. */
4792 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4796 if (expr->value.function.isym)
4798 gfc_conv_intrinsic_function (se, expr);
4802 /* We distinguish statement functions from general functions to improve
4803 runtime performance. */
4804 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4806 gfc_conv_statement_function (se, expr);
4810 /* expr.value.function.esym is the resolved (specific) function symbol for
4811 most functions. However this isn't set for dummy procedures. */
4812 sym = expr->value.function.esym;
4814 sym = expr->symtree->n.sym;
4816 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4820 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4823 is_zero_initializer_p (gfc_expr * expr)
4825 if (expr->expr_type != EXPR_CONSTANT)
4828 /* We ignore constants with prescribed memory representations for now. */
4829 if (expr->representation.string)
4832 switch (expr->ts.type)
4835 return mpz_cmp_si (expr->value.integer, 0) == 0;
4838 return mpfr_zero_p (expr->value.real)
4839 && MPFR_SIGN (expr->value.real) >= 0;
4842 return expr->value.logical == 0;
4845 return mpfr_zero_p (mpc_realref (expr->value.complex))
4846 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4847 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4848 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4858 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4863 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
4864 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
4866 gfc_conv_tmp_array_ref (se);
4870 /* Build a static initializer. EXPR is the expression for the initial value.
4871 The other parameters describe the variable of the component being
4872 initialized. EXPR may be null. */
4875 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4876 bool array, bool pointer, bool procptr)
4880 if (!(expr || pointer || procptr))
4883 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4884 (these are the only two iso_c_binding derived types that can be
4885 used as initialization expressions). If so, we need to modify
4886 the 'expr' to be that for a (void *). */
4887 if (expr != NULL && expr->ts.type == BT_DERIVED
4888 && expr->ts.is_iso_c && expr->ts.u.derived)
4890 gfc_symbol *derived = expr->ts.u.derived;
4892 /* The derived symbol has already been converted to a (void *). Use
4894 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4895 expr->ts.f90_type = derived->ts.f90_type;
4897 gfc_init_se (&se, NULL);
4898 gfc_conv_constant (&se, expr);
4899 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4903 if (array && !procptr)
4906 /* Arrays need special handling. */
4908 ctor = gfc_build_null_descriptor (type);
4909 /* Special case assigning an array to zero. */
4910 else if (is_zero_initializer_p (expr))
4911 ctor = build_constructor (type, NULL);
4913 ctor = gfc_conv_array_initializer (type, expr);
4914 TREE_STATIC (ctor) = 1;
4917 else if (pointer || procptr)
4919 if (!expr || expr->expr_type == EXPR_NULL)
4920 return fold_convert (type, null_pointer_node);
4923 gfc_init_se (&se, NULL);
4924 se.want_pointer = 1;
4925 gfc_conv_expr (&se, expr);
4926 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4936 gfc_init_se (&se, NULL);
4937 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4938 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4940 gfc_conv_structure (&se, expr, 1);
4941 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4942 TREE_STATIC (se.expr) = 1;
4947 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4948 TREE_STATIC (ctor) = 1;
4953 gfc_init_se (&se, NULL);
4954 gfc_conv_constant (&se, expr);
4955 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4962 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4968 gfc_array_info *lss_array;
4975 gfc_start_block (&block);
4977 /* Initialize the scalarizer. */
4978 gfc_init_loopinfo (&loop);
4980 gfc_init_se (&lse, NULL);
4981 gfc_init_se (&rse, NULL);
4984 rss = gfc_walk_expr (expr);
4985 if (rss == gfc_ss_terminator)
4986 /* The rhs is scalar. Add a ss for the expression. */
4987 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
4989 /* Create a SS for the destination. */
4990 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
4992 lss_array = &lss->info->data.array;
4993 lss_array->shape = gfc_get_shape (cm->as->rank);
4994 lss_array->descriptor = dest;
4995 lss_array->data = gfc_conv_array_data (dest);
4996 lss_array->offset = gfc_conv_array_offset (dest);
4997 for (n = 0; n < cm->as->rank; n++)
4999 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
5000 lss_array->stride[n] = gfc_index_one_node;
5002 mpz_init (lss_array->shape[n]);
5003 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
5004 cm->as->lower[n]->value.integer);
5005 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
5008 /* Associate the SS with the loop. */
5009 gfc_add_ss_to_loop (&loop, lss);
5010 gfc_add_ss_to_loop (&loop, rss);
5012 /* Calculate the bounds of the scalarization. */
5013 gfc_conv_ss_startstride (&loop);
5015 /* Setup the scalarizing loops. */
5016 gfc_conv_loop_setup (&loop, &expr->where);
5018 /* Setup the gfc_se structures. */
5019 gfc_copy_loopinfo_to_se (&lse, &loop);
5020 gfc_copy_loopinfo_to_se (&rse, &loop);
5023 gfc_mark_ss_chain_used (rss, 1);
5025 gfc_mark_ss_chain_used (lss, 1);
5027 /* Start the scalarized loop body. */
5028 gfc_start_scalarized_body (&loop, &body);
5030 gfc_conv_tmp_array_ref (&lse);
5031 if (cm->ts.type == BT_CHARACTER)
5032 lse.string_length = cm->ts.u.cl->backend_decl;
5034 gfc_conv_expr (&rse, expr);
5036 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
5037 gfc_add_expr_to_block (&body, tmp);
5039 gcc_assert (rse.ss == gfc_ss_terminator);
5041 /* Generate the copying loops. */
5042 gfc_trans_scalarizing_loops (&loop, &body);
5044 /* Wrap the whole thing up. */
5045 gfc_add_block_to_block (&block, &loop.pre);
5046 gfc_add_block_to_block (&block, &loop.post);
5048 gcc_assert (lss_array->shape != NULL);
5049 gfc_free_shape (&lss_array->shape, cm->as->rank);
5050 gfc_cleanup_loop (&loop);
5052 return gfc_finish_block (&block);
5057 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
5068 gfc_expr *arg = NULL;
5070 gfc_start_block (&block);
5071 gfc_init_se (&se, NULL);
5073 /* Get the descriptor for the expressions. */
5074 rss = gfc_walk_expr (expr);
5075 se.want_pointer = 0;
5076 gfc_conv_expr_descriptor (&se, expr, rss);
5077 gfc_add_block_to_block (&block, &se.pre);
5078 gfc_add_modify (&block, dest, se.expr);
5080 /* Deal with arrays of derived types with allocatable components. */
5081 if (cm->ts.type == BT_DERIVED
5082 && cm->ts.u.derived->attr.alloc_comp)
5083 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
5087 tmp = gfc_duplicate_allocatable (dest, se.expr,
5088 TREE_TYPE(cm->backend_decl),
5091 gfc_add_expr_to_block (&block, tmp);
5092 gfc_add_block_to_block (&block, &se.post);
5094 if (expr->expr_type != EXPR_VARIABLE)
5095 gfc_conv_descriptor_data_set (&block, se.expr,
5098 /* We need to know if the argument of a conversion function is a
5099 variable, so that the correct lower bound can be used. */
5100 if (expr->expr_type == EXPR_FUNCTION
5101 && expr->value.function.isym
5102 && expr->value.function.isym->conversion
5103 && expr->value.function.actual->expr
5104 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
5105 arg = expr->value.function.actual->expr;
5107 /* Obtain the array spec of full array references. */
5109 as = gfc_get_full_arrayspec_from_expr (arg);
5111 as = gfc_get_full_arrayspec_from_expr (expr);
5113 /* Shift the lbound and ubound of temporaries to being unity,
5114 rather than zero, based. Always calculate the offset. */
5115 offset = gfc_conv_descriptor_offset_get (dest);
5116 gfc_add_modify (&block, offset, gfc_index_zero_node);
5117 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
5119 for (n = 0; n < expr->rank; n++)
5124 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5125 TODO It looks as if gfc_conv_expr_descriptor should return
5126 the correct bounds and that the following should not be
5127 necessary. This would simplify gfc_conv_intrinsic_bound
5129 if (as && as->lower[n])
5132 gfc_init_se (&lbse, NULL);
5133 gfc_conv_expr (&lbse, as->lower[n]);
5134 gfc_add_block_to_block (&block, &lbse.pre);
5135 lbound = gfc_evaluate_now (lbse.expr, &block);
5139 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
5140 lbound = gfc_conv_descriptor_lbound_get (tmp,
5144 lbound = gfc_conv_descriptor_lbound_get (dest,
5147 lbound = gfc_index_one_node;
5149 lbound = fold_convert (gfc_array_index_type, lbound);
5151 /* Shift the bounds and set the offset accordingly. */
5152 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
5153 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5154 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
5155 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5157 gfc_conv_descriptor_ubound_set (&block, dest,
5158 gfc_rank_cst[n], tmp);
5159 gfc_conv_descriptor_lbound_set (&block, dest,
5160 gfc_rank_cst[n], lbound);
5162 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5163 gfc_conv_descriptor_lbound_get (dest,
5165 gfc_conv_descriptor_stride_get (dest,
5167 gfc_add_modify (&block, tmp2, tmp);
5168 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5170 gfc_conv_descriptor_offset_set (&block, dest, tmp);
5175 /* If a conversion expression has a null data pointer
5176 argument, nullify the allocatable component. */
5180 if (arg->symtree->n.sym->attr.allocatable
5181 || arg->symtree->n.sym->attr.pointer)
5183 non_null_expr = gfc_finish_block (&block);
5184 gfc_start_block (&block);
5185 gfc_conv_descriptor_data_set (&block, dest,
5187 null_expr = gfc_finish_block (&block);
5188 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
5189 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5190 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5191 return build3_v (COND_EXPR, tmp,
5192 null_expr, non_null_expr);
5196 return gfc_finish_block (&block);
5200 /* Assign a single component of a derived type constructor. */
5203 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
5211 gfc_start_block (&block);
5213 if (cm->attr.pointer)
5215 gfc_init_se (&se, NULL);
5216 /* Pointer component. */
5217 if (cm->attr.dimension)
5219 /* Array pointer. */
5220 if (expr->expr_type == EXPR_NULL)
5221 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5224 rss = gfc_walk_expr (expr);
5225 se.direct_byref = 1;
5227 gfc_conv_expr_descriptor (&se, expr, rss);
5228 gfc_add_block_to_block (&block, &se.pre);
5229 gfc_add_block_to_block (&block, &se.post);
5234 /* Scalar pointers. */
5235 se.want_pointer = 1;
5236 gfc_conv_expr (&se, expr);
5237 gfc_add_block_to_block (&block, &se.pre);
5238 gfc_add_modify (&block, dest,
5239 fold_convert (TREE_TYPE (dest), se.expr));
5240 gfc_add_block_to_block (&block, &se.post);
5243 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
5245 /* NULL initialization for CLASS components. */
5246 tmp = gfc_trans_structure_assign (dest,
5247 gfc_class_null_initializer (&cm->ts));
5248 gfc_add_expr_to_block (&block, tmp);
5250 else if (cm->attr.dimension && !cm->attr.proc_pointer)
5252 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
5253 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5254 else if (cm->attr.allocatable)
5256 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
5257 gfc_add_expr_to_block (&block, tmp);
5261 tmp = gfc_trans_subarray_assign (dest, cm, expr);
5262 gfc_add_expr_to_block (&block, tmp);
5265 else if (expr->ts.type == BT_DERIVED)
5267 if (expr->expr_type != EXPR_STRUCTURE)
5269 gfc_init_se (&se, NULL);
5270 gfc_conv_expr (&se, expr);
5271 gfc_add_block_to_block (&block, &se.pre);
5272 gfc_add_modify (&block, dest,
5273 fold_convert (TREE_TYPE (dest), se.expr));
5274 gfc_add_block_to_block (&block, &se.post);
5278 /* Nested constructors. */
5279 tmp = gfc_trans_structure_assign (dest, expr);
5280 gfc_add_expr_to_block (&block, tmp);
5285 /* Scalar component. */
5286 gfc_init_se (&se, NULL);
5287 gfc_init_se (&lse, NULL);
5289 gfc_conv_expr (&se, expr);
5290 if (cm->ts.type == BT_CHARACTER)
5291 lse.string_length = cm->ts.u.cl->backend_decl;
5293 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
5294 gfc_add_expr_to_block (&block, tmp);
5296 return gfc_finish_block (&block);
5299 /* Assign a derived type constructor to a variable. */
5302 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
5310 gfc_start_block (&block);
5311 cm = expr->ts.u.derived->components;
5313 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
5314 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
5315 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
5319 gcc_assert (cm->backend_decl == NULL);
5320 gfc_init_se (&se, NULL);
5321 gfc_init_se (&lse, NULL);
5322 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
5324 gfc_add_modify (&block, lse.expr,
5325 fold_convert (TREE_TYPE (lse.expr), se.expr));
5327 return gfc_finish_block (&block);
5330 for (c = gfc_constructor_first (expr->value.constructor);
5331 c; c = gfc_constructor_next (c), cm = cm->next)
5333 /* Skip absent members in default initializers. */
5337 field = cm->backend_decl;
5338 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
5339 dest, field, NULL_TREE);
5340 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
5341 gfc_add_expr_to_block (&block, tmp);
5343 return gfc_finish_block (&block);
5346 /* Build an expression for a constructor. If init is nonzero then
5347 this is part of a static variable initializer. */
5350 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
5357 VEC(constructor_elt,gc) *v = NULL;
5359 gcc_assert (se->ss == NULL);
5360 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
5361 type = gfc_typenode_for_spec (&expr->ts);
5365 /* Create a temporary variable and fill it in. */
5366 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
5367 tmp = gfc_trans_structure_assign (se->expr, expr);
5368 gfc_add_expr_to_block (&se->pre, tmp);
5372 cm = expr->ts.u.derived->components;
5374 for (c = gfc_constructor_first (expr->value.constructor);
5375 c; c = gfc_constructor_next (c), cm = cm->next)
5377 /* Skip absent members in default initializers and allocatable
5378 components. Although the latter have a default initializer
5379 of EXPR_NULL,... by default, the static nullify is not needed
5380 since this is done every time we come into scope. */
5381 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
5384 if (strcmp (cm->name, "_size") == 0)
5386 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
5387 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
5389 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
5390 && strcmp (cm->name, "_extends") == 0)
5394 vtabs = cm->initializer->symtree->n.sym;
5395 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
5396 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
5400 val = gfc_conv_initializer (c->expr, &cm->ts,
5401 TREE_TYPE (cm->backend_decl),
5402 cm->attr.dimension, cm->attr.pointer,
5403 cm->attr.proc_pointer);
5405 /* Append it to the constructor list. */
5406 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
5409 se->expr = build_constructor (type, v);
5411 TREE_CONSTANT (se->expr) = 1;
5415 /* Translate a substring expression. */
5418 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
5424 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
5426 se->expr = gfc_build_wide_string_const (expr->ts.kind,
5427 expr->value.character.length,
5428 expr->value.character.string);
5430 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
5431 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
5434 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
5438 /* Entry point for expression translation. Evaluates a scalar quantity.
5439 EXPR is the expression to be translated, and SE is the state structure if
5440 called from within the scalarized. */
5443 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
5448 if (ss && ss->info->expr == expr
5449 && (ss->info->type == GFC_SS_SCALAR
5450 || ss->info->type == GFC_SS_REFERENCE))
5452 gfc_ss_info *ss_info;
5455 /* Substitute a scalar expression evaluated outside the scalarization
5457 se->expr = ss_info->data.scalar.value;
5458 /* If the reference can be NULL, the value field contains the reference,
5459 not the value the reference points to (see gfc_add_loop_ss_code). */
5460 if (ss_info->data.scalar.can_be_null_ref)
5461 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5463 se->string_length = ss_info->string_length;
5464 gfc_advance_se_ss_chain (se);
5468 /* We need to convert the expressions for the iso_c_binding derived types.
5469 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
5470 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
5471 typespec for the C_PTR and C_FUNPTR symbols, which has already been
5472 updated to be an integer with a kind equal to the size of a (void *). */
5473 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
5474 && expr->ts.u.derived->attr.is_iso_c)
5476 if (expr->expr_type == EXPR_VARIABLE
5477 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
5478 || expr->symtree->n.sym->intmod_sym_id
5479 == ISOCBINDING_NULL_FUNPTR))
5481 /* Set expr_type to EXPR_NULL, which will result in
5482 null_pointer_node being used below. */
5483 expr->expr_type = EXPR_NULL;
5487 /* Update the type/kind of the expression to be what the new
5488 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
5489 expr->ts.type = expr->ts.u.derived->ts.type;
5490 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
5491 expr->ts.kind = expr->ts.u.derived->ts.kind;
5495 gfc_fix_class_refs (expr);
5497 switch (expr->expr_type)
5500 gfc_conv_expr_op (se, expr);
5504 gfc_conv_function_expr (se, expr);
5508 gfc_conv_constant (se, expr);
5512 gfc_conv_variable (se, expr);
5516 se->expr = null_pointer_node;
5519 case EXPR_SUBSTRING:
5520 gfc_conv_substring_expr (se, expr);
5523 case EXPR_STRUCTURE:
5524 gfc_conv_structure (se, expr, 0);
5528 gfc_conv_array_constructor_expr (se, expr);
5537 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
5538 of an assignment. */
5540 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
5542 gfc_conv_expr (se, expr);
5543 /* All numeric lvalues should have empty post chains. If not we need to
5544 figure out a way of rewriting an lvalue so that it has no post chain. */
5545 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
5548 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
5549 numeric expressions. Used for scalar values where inserting cleanup code
5552 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
5556 gcc_assert (expr->ts.type != BT_CHARACTER);
5557 gfc_conv_expr (se, expr);
5560 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
5561 gfc_add_modify (&se->pre, val, se->expr);
5563 gfc_add_block_to_block (&se->pre, &se->post);
5567 /* Helper to translate an expression and convert it to a particular type. */
5569 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
5571 gfc_conv_expr_val (se, expr);
5572 se->expr = convert (type, se->expr);
5576 /* Converts an expression so that it can be passed by reference. Scalar
5580 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
5586 if (ss && ss->info->expr == expr
5587 && ss->info->type == GFC_SS_REFERENCE)
5589 /* Returns a reference to the scalar evaluated outside the loop
5591 gfc_conv_expr (se, expr);
5592 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5596 if (expr->ts.type == BT_CHARACTER)
5598 gfc_conv_expr (se, expr);
5599 gfc_conv_string_parameter (se);
5603 if (expr->expr_type == EXPR_VARIABLE)
5605 se->want_pointer = 1;
5606 gfc_conv_expr (se, expr);
5609 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5610 gfc_add_modify (&se->pre, var, se->expr);
5611 gfc_add_block_to_block (&se->pre, &se->post);
5617 if (expr->expr_type == EXPR_FUNCTION
5618 && ((expr->value.function.esym
5619 && expr->value.function.esym->result->attr.pointer
5620 && !expr->value.function.esym->result->attr.dimension)
5621 || (!expr->value.function.esym
5622 && expr->symtree->n.sym->attr.pointer
5623 && !expr->symtree->n.sym->attr.dimension)))
5625 se->want_pointer = 1;
5626 gfc_conv_expr (se, expr);
5627 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5628 gfc_add_modify (&se->pre, var, se->expr);
5633 gfc_conv_expr (se, expr);
5635 /* Create a temporary var to hold the value. */
5636 if (TREE_CONSTANT (se->expr))
5638 tree tmp = se->expr;
5639 STRIP_TYPE_NOPS (tmp);
5640 var = build_decl (input_location,
5641 CONST_DECL, NULL, TREE_TYPE (tmp));
5642 DECL_INITIAL (var) = tmp;
5643 TREE_STATIC (var) = 1;
5648 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
5649 gfc_add_modify (&se->pre, var, se->expr);
5651 gfc_add_block_to_block (&se->pre, &se->post);
5653 /* Take the address of that value. */
5654 se->expr = gfc_build_addr_expr (NULL_TREE, var);
5659 gfc_trans_pointer_assign (gfc_code * code)
5661 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
5665 /* Generate code for a pointer assignment. */
5668 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
5679 gfc_start_block (&block);
5681 gfc_init_se (&lse, NULL);
5683 lss = gfc_walk_expr (expr1);
5684 rss = gfc_walk_expr (expr2);
5685 if (lss == gfc_ss_terminator)
5687 /* Scalar pointers. */
5688 lse.want_pointer = 1;
5689 gfc_conv_expr (&lse, expr1);
5690 gcc_assert (rss == gfc_ss_terminator);
5691 gfc_init_se (&rse, NULL);
5692 rse.want_pointer = 1;
5693 gfc_conv_expr (&rse, expr2);
5695 if (expr1->symtree->n.sym->attr.proc_pointer
5696 && expr1->symtree->n.sym->attr.dummy)
5697 lse.expr = build_fold_indirect_ref_loc (input_location,
5700 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
5701 && expr2->symtree->n.sym->attr.dummy)
5702 rse.expr = build_fold_indirect_ref_loc (input_location,
5705 gfc_add_block_to_block (&block, &lse.pre);
5706 gfc_add_block_to_block (&block, &rse.pre);
5708 /* Check character lengths if character expression. The test is only
5709 really added if -fbounds-check is enabled. Exclude deferred
5710 character length lefthand sides. */
5711 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
5712 && !(expr1->ts.deferred
5713 && (TREE_CODE (lse.string_length) == VAR_DECL))
5714 && !expr1->symtree->n.sym->attr.proc_pointer
5715 && !gfc_is_proc_ptr_comp (expr1, NULL))
5717 gcc_assert (expr2->ts.type == BT_CHARACTER);
5718 gcc_assert (lse.string_length && rse.string_length);
5719 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5720 lse.string_length, rse.string_length,
5724 /* The assignment to an deferred character length sets the string
5725 length to that of the rhs. */
5726 if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
5728 if (expr2->expr_type != EXPR_NULL)
5729 gfc_add_modify (&block, lse.string_length, rse.string_length);
5731 gfc_add_modify (&block, lse.string_length,
5732 build_int_cst (gfc_charlen_type_node, 0));
5735 gfc_add_modify (&block, lse.expr,
5736 fold_convert (TREE_TYPE (lse.expr), rse.expr));
5738 gfc_add_block_to_block (&block, &rse.post);
5739 gfc_add_block_to_block (&block, &lse.post);
5746 tree strlen_rhs = NULL_TREE;
5748 /* Array pointer. Find the last reference on the LHS and if it is an
5749 array section ref, we're dealing with bounds remapping. In this case,
5750 set it to AR_FULL so that gfc_conv_expr_descriptor does
5751 not see it and process the bounds remapping afterwards explicitely. */
5752 for (remap = expr1->ref; remap; remap = remap->next)
5753 if (!remap->next && remap->type == REF_ARRAY
5754 && remap->u.ar.type == AR_SECTION)
5756 remap->u.ar.type = AR_FULL;
5759 rank_remap = (remap && remap->u.ar.end[0]);
5761 gfc_conv_expr_descriptor (&lse, expr1, lss);
5762 strlen_lhs = lse.string_length;
5765 if (expr2->expr_type == EXPR_NULL)
5767 /* Just set the data pointer to null. */
5768 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
5770 else if (rank_remap)
5772 /* If we are rank-remapping, just get the RHS's descriptor and
5773 process this later on. */
5774 gfc_init_se (&rse, NULL);
5775 rse.direct_byref = 1;
5776 rse.byref_noassign = 1;
5777 gfc_conv_expr_descriptor (&rse, expr2, rss);
5778 strlen_rhs = rse.string_length;
5780 else if (expr2->expr_type == EXPR_VARIABLE)
5782 /* Assign directly to the LHS's descriptor. */
5783 lse.direct_byref = 1;
5784 gfc_conv_expr_descriptor (&lse, expr2, rss);
5785 strlen_rhs = lse.string_length;
5787 /* If this is a subreference array pointer assignment, use the rhs
5788 descriptor element size for the lhs span. */
5789 if (expr1->symtree->n.sym->attr.subref_array_pointer)
5791 decl = expr1->symtree->n.sym->backend_decl;
5792 gfc_init_se (&rse, NULL);
5793 rse.descriptor_only = 1;
5794 gfc_conv_expr (&rse, expr2);
5795 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
5796 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
5797 if (!INTEGER_CST_P (tmp))
5798 gfc_add_block_to_block (&lse.post, &rse.pre);
5799 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5804 /* Assign to a temporary descriptor and then copy that
5805 temporary to the pointer. */
5806 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5809 lse.direct_byref = 1;
5810 gfc_conv_expr_descriptor (&lse, expr2, rss);
5811 strlen_rhs = lse.string_length;
5812 gfc_add_modify (&lse.pre, desc, tmp);
5815 gfc_add_block_to_block (&block, &lse.pre);
5817 gfc_add_block_to_block (&block, &rse.pre);
5819 /* If we do bounds remapping, update LHS descriptor accordingly. */
5823 gcc_assert (remap->u.ar.dimen == expr1->rank);
5827 /* Do rank remapping. We already have the RHS's descriptor
5828 converted in rse and now have to build the correct LHS
5829 descriptor for it. */
5833 tree lbound, ubound;
5836 dtype = gfc_conv_descriptor_dtype (desc);
5837 tmp = gfc_get_dtype (TREE_TYPE (desc));
5838 gfc_add_modify (&block, dtype, tmp);
5840 /* Copy data pointer. */
5841 data = gfc_conv_descriptor_data_get (rse.expr);
5842 gfc_conv_descriptor_data_set (&block, desc, data);
5844 /* Copy offset but adjust it such that it would correspond
5845 to a lbound of zero. */
5846 offs = gfc_conv_descriptor_offset_get (rse.expr);
5847 for (dim = 0; dim < expr2->rank; ++dim)
5849 stride = gfc_conv_descriptor_stride_get (rse.expr,
5851 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5853 tmp = fold_build2_loc (input_location, MULT_EXPR,
5854 gfc_array_index_type, stride, lbound);
5855 offs = fold_build2_loc (input_location, PLUS_EXPR,
5856 gfc_array_index_type, offs, tmp);
5858 gfc_conv_descriptor_offset_set (&block, desc, offs);
5860 /* Set the bounds as declared for the LHS and calculate strides as
5861 well as another offset update accordingly. */
5862 stride = gfc_conv_descriptor_stride_get (rse.expr,
5864 for (dim = 0; dim < expr1->rank; ++dim)
5869 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5871 /* Convert declared bounds. */
5872 gfc_init_se (&lower_se, NULL);
5873 gfc_init_se (&upper_se, NULL);
5874 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5875 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5877 gfc_add_block_to_block (&block, &lower_se.pre);
5878 gfc_add_block_to_block (&block, &upper_se.pre);
5880 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5881 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5883 lbound = gfc_evaluate_now (lbound, &block);
5884 ubound = gfc_evaluate_now (ubound, &block);
5886 gfc_add_block_to_block (&block, &lower_se.post);
5887 gfc_add_block_to_block (&block, &upper_se.post);
5889 /* Set bounds in descriptor. */
5890 gfc_conv_descriptor_lbound_set (&block, desc,
5891 gfc_rank_cst[dim], lbound);
5892 gfc_conv_descriptor_ubound_set (&block, desc,
5893 gfc_rank_cst[dim], ubound);
5896 stride = gfc_evaluate_now (stride, &block);
5897 gfc_conv_descriptor_stride_set (&block, desc,
5898 gfc_rank_cst[dim], stride);
5900 /* Update offset. */
5901 offs = gfc_conv_descriptor_offset_get (desc);
5902 tmp = fold_build2_loc (input_location, MULT_EXPR,
5903 gfc_array_index_type, lbound, stride);
5904 offs = fold_build2_loc (input_location, MINUS_EXPR,
5905 gfc_array_index_type, offs, tmp);
5906 offs = gfc_evaluate_now (offs, &block);
5907 gfc_conv_descriptor_offset_set (&block, desc, offs);
5909 /* Update stride. */
5910 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5911 stride = fold_build2_loc (input_location, MULT_EXPR,
5912 gfc_array_index_type, stride, tmp);
5917 /* Bounds remapping. Just shift the lower bounds. */
5919 gcc_assert (expr1->rank == expr2->rank);
5921 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5925 gcc_assert (remap->u.ar.start[dim]);
5926 gcc_assert (!remap->u.ar.end[dim]);
5927 gfc_init_se (&lbound_se, NULL);
5928 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5930 gfc_add_block_to_block (&block, &lbound_se.pre);
5931 gfc_conv_shift_descriptor_lbound (&block, desc,
5932 dim, lbound_se.expr);
5933 gfc_add_block_to_block (&block, &lbound_se.post);
5938 /* Check string lengths if applicable. The check is only really added
5939 to the output code if -fbounds-check is enabled. */
5940 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5942 gcc_assert (expr2->ts.type == BT_CHARACTER);
5943 gcc_assert (strlen_lhs && strlen_rhs);
5944 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5945 strlen_lhs, strlen_rhs, &block);
5948 /* If rank remapping was done, check with -fcheck=bounds that
5949 the target is at least as large as the pointer. */
5950 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5956 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5957 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5959 lsize = gfc_evaluate_now (lsize, &block);
5960 rsize = gfc_evaluate_now (rsize, &block);
5961 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5964 msg = _("Target of rank remapping is too small (%ld < %ld)");
5965 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5969 gfc_add_block_to_block (&block, &lse.post);
5971 gfc_add_block_to_block (&block, &rse.post);
5974 return gfc_finish_block (&block);
5978 /* Makes sure se is suitable for passing as a function string parameter. */
5979 /* TODO: Need to check all callers of this function. It may be abused. */
5982 gfc_conv_string_parameter (gfc_se * se)
5986 if (TREE_CODE (se->expr) == STRING_CST)
5988 type = TREE_TYPE (TREE_TYPE (se->expr));
5989 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5993 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5995 if (TREE_CODE (se->expr) != INDIRECT_REF)
5997 type = TREE_TYPE (se->expr);
5998 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
6002 type = gfc_get_character_type_len (gfc_default_character_kind,
6004 type = build_pointer_type (type);
6005 se->expr = gfc_build_addr_expr (type, se->expr);
6009 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
6013 /* Generate code for assignment of scalar variables. Includes character
6014 strings and derived types with allocatable components.
6015 If you know that the LHS has no allocations, set dealloc to false. */
6018 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
6019 bool l_is_temp, bool r_is_var, bool dealloc)
6025 gfc_init_block (&block);
6027 if (ts.type == BT_CHARACTER)
6032 if (lse->string_length != NULL_TREE)
6034 gfc_conv_string_parameter (lse);
6035 gfc_add_block_to_block (&block, &lse->pre);
6036 llen = lse->string_length;
6039 if (rse->string_length != NULL_TREE)
6041 gcc_assert (rse->string_length != NULL_TREE);
6042 gfc_conv_string_parameter (rse);
6043 gfc_add_block_to_block (&block, &rse->pre);
6044 rlen = rse->string_length;
6047 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
6048 rse->expr, ts.kind);
6050 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
6054 /* Are the rhs and the lhs the same? */
6057 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6058 gfc_build_addr_expr (NULL_TREE, lse->expr),
6059 gfc_build_addr_expr (NULL_TREE, rse->expr));
6060 cond = gfc_evaluate_now (cond, &lse->pre);
6063 /* Deallocate the lhs allocated components as long as it is not
6064 the same as the rhs. This must be done following the assignment
6065 to prevent deallocating data that could be used in the rhs
6067 if (!l_is_temp && dealloc)
6069 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
6070 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
6072 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
6074 gfc_add_expr_to_block (&lse->post, tmp);
6077 gfc_add_block_to_block (&block, &rse->pre);
6078 gfc_add_block_to_block (&block, &lse->pre);
6080 gfc_add_modify (&block, lse->expr,
6081 fold_convert (TREE_TYPE (lse->expr), rse->expr));
6083 /* Do a deep copy if the rhs is a variable, if it is not the
6087 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
6088 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
6090 gfc_add_expr_to_block (&block, tmp);
6093 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
6095 gfc_add_block_to_block (&block, &lse->pre);
6096 gfc_add_block_to_block (&block, &rse->pre);
6097 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
6098 TREE_TYPE (lse->expr), rse->expr);
6099 gfc_add_modify (&block, lse->expr, tmp);
6103 gfc_add_block_to_block (&block, &lse->pre);
6104 gfc_add_block_to_block (&block, &rse->pre);
6106 gfc_add_modify (&block, lse->expr,
6107 fold_convert (TREE_TYPE (lse->expr), rse->expr));
6110 gfc_add_block_to_block (&block, &lse->post);
6111 gfc_add_block_to_block (&block, &rse->post);
6113 return gfc_finish_block (&block);
6117 /* There are quite a lot of restrictions on the optimisation in using an
6118 array function assign without a temporary. */
6121 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
6124 bool seen_array_ref;
6126 gfc_symbol *sym = expr1->symtree->n.sym;
6128 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6129 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
6132 /* Elemental functions are scalarized so that they don't need a
6133 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6134 they would need special treatment in gfc_trans_arrayfunc_assign. */
6135 if (expr2->value.function.esym != NULL
6136 && expr2->value.function.esym->attr.elemental)
6139 /* Need a temporary if rhs is not FULL or a contiguous section. */
6140 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
6143 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6144 if (gfc_ref_needs_temporary_p (expr1->ref))
6147 /* Functions returning pointers or allocatables need temporaries. */
6148 c = expr2->value.function.esym
6149 ? (expr2->value.function.esym->attr.pointer
6150 || expr2->value.function.esym->attr.allocatable)
6151 : (expr2->symtree->n.sym->attr.pointer
6152 || expr2->symtree->n.sym->attr.allocatable);
6156 /* Character array functions need temporaries unless the
6157 character lengths are the same. */
6158 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
6160 if (expr1->ts.u.cl->length == NULL
6161 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6164 if (expr2->ts.u.cl->length == NULL
6165 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6168 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
6169 expr2->ts.u.cl->length->value.integer) != 0)
6173 /* Check that no LHS component references appear during an array
6174 reference. This is needed because we do not have the means to
6175 span any arbitrary stride with an array descriptor. This check
6176 is not needed for the rhs because the function result has to be
6178 seen_array_ref = false;
6179 for (ref = expr1->ref; ref; ref = ref->next)
6181 if (ref->type == REF_ARRAY)
6182 seen_array_ref= true;
6183 else if (ref->type == REF_COMPONENT && seen_array_ref)
6187 /* Check for a dependency. */
6188 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
6189 expr2->value.function.esym,
6190 expr2->value.function.actual,
6194 /* If we have reached here with an intrinsic function, we do not
6195 need a temporary except in the particular case that reallocation
6196 on assignment is active and the lhs is allocatable and a target. */
6197 if (expr2->value.function.isym)
6198 return (gfc_option.flag_realloc_lhs
6199 && sym->attr.allocatable
6200 && sym->attr.target);
6202 /* If the LHS is a dummy, we need a temporary if it is not
6204 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
6207 /* If the lhs has been host_associated, is in common, a pointer or is
6208 a target and the function is not using a RESULT variable, aliasing
6209 can occur and a temporary is needed. */
6210 if ((sym->attr.host_assoc
6211 || sym->attr.in_common
6212 || sym->attr.pointer
6213 || sym->attr.cray_pointee
6214 || sym->attr.target)
6215 && expr2->symtree != NULL
6216 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
6219 /* A PURE function can unconditionally be called without a temporary. */
6220 if (expr2->value.function.esym != NULL
6221 && expr2->value.function.esym->attr.pure)
6224 /* Implicit_pure functions are those which could legally be declared
6226 if (expr2->value.function.esym != NULL
6227 && expr2->value.function.esym->attr.implicit_pure)
6230 if (!sym->attr.use_assoc
6231 && !sym->attr.in_common
6232 && !sym->attr.pointer
6233 && !sym->attr.target
6234 && !sym->attr.cray_pointee
6235 && expr2->value.function.esym)
6237 /* A temporary is not needed if the function is not contained and
6238 the variable is local or host associated and not a pointer or
6240 if (!expr2->value.function.esym->attr.contained)
6243 /* A temporary is not needed if the lhs has never been host
6244 associated and the procedure is contained. */
6245 else if (!sym->attr.host_assoc)
6248 /* A temporary is not needed if the variable is local and not
6249 a pointer, a target or a result. */
6251 && expr2->value.function.esym->ns == sym->ns->parent)
6255 /* Default to temporary use. */
6260 /* Provide the loop info so that the lhs descriptor can be built for
6261 reallocatable assignments from extrinsic function calls. */
6264 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
6267 /* Signal that the function call should not be made by
6268 gfc_conv_loop_setup. */
6269 se->ss->is_alloc_lhs = 1;
6270 gfc_init_loopinfo (loop);
6271 gfc_add_ss_to_loop (loop, *ss);
6272 gfc_add_ss_to_loop (loop, se->ss);
6273 gfc_conv_ss_startstride (loop);
6274 gfc_conv_loop_setup (loop, where);
6275 gfc_copy_loopinfo_to_se (se, loop);
6276 gfc_add_block_to_block (&se->pre, &loop->pre);
6277 gfc_add_block_to_block (&se->pre, &loop->post);
6278 se->ss->is_alloc_lhs = 0;
6282 /* For assignment to a reallocatable lhs from intrinsic functions,
6283 replace the se.expr (ie. the result) with a temporary descriptor.
6284 Null the data field so that the library allocates space for the
6285 result. Free the data of the original descriptor after the function,
6286 in case it appears in an argument expression and transfer the
6287 result to the original descriptor. */
6290 fcncall_realloc_result (gfc_se *se, int rank)
6299 /* Use the allocation done by the library. Substitute the lhs
6300 descriptor with a copy, whose data field is nulled.*/
6301 desc = build_fold_indirect_ref_loc (input_location, se->expr);
6302 if (POINTER_TYPE_P (TREE_TYPE (desc)))
6303 desc = build_fold_indirect_ref_loc (input_location, desc);
6305 /* Unallocated, the descriptor does not have a dtype. */
6306 tmp = gfc_conv_descriptor_dtype (desc);
6307 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
6309 res_desc = gfc_evaluate_now (desc, &se->pre);
6310 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
6311 se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
6313 /* Free the lhs after the function call and copy the result data to
6314 the lhs descriptor. */
6315 tmp = gfc_conv_descriptor_data_get (desc);
6316 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
6317 boolean_type_node, tmp,
6318 build_int_cst (TREE_TYPE (tmp), 0));
6319 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
6320 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
6321 gfc_add_expr_to_block (&se->post, tmp);
6323 tmp = gfc_conv_descriptor_data_get (res_desc);
6324 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
6326 /* Check that the shapes are the same between lhs and expression. */
6327 for (n = 0 ; n < rank; n++)
6330 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
6331 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
6332 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6333 gfc_array_index_type, tmp, tmp1);
6334 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
6335 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6336 gfc_array_index_type, tmp, tmp1);
6337 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
6338 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6339 gfc_array_index_type, tmp, tmp1);
6340 tmp = fold_build2_loc (input_location, NE_EXPR,
6341 boolean_type_node, tmp,
6342 gfc_index_zero_node);
6343 tmp = gfc_evaluate_now (tmp, &se->post);
6344 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6345 boolean_type_node, tmp,
6349 /* 'zero_cond' being true is equal to lhs not being allocated or the
6350 shapes being different. */
6351 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
6353 /* Now reset the bounds returned from the function call to bounds based
6354 on the lhs lbounds, except where the lhs is not allocated or the shapes
6355 of 'variable and 'expr' are different. Set the offset accordingly. */
6356 offset = gfc_index_zero_node;
6357 for (n = 0 ; n < rank; n++)
6361 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
6362 lbound = fold_build3_loc (input_location, COND_EXPR,
6363 gfc_array_index_type, zero_cond,
6364 gfc_index_one_node, lbound);
6365 lbound = gfc_evaluate_now (lbound, &se->post);
6367 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
6368 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6369 gfc_array_index_type, tmp, lbound);
6370 gfc_conv_descriptor_lbound_set (&se->post, desc,
6371 gfc_rank_cst[n], lbound);
6372 gfc_conv_descriptor_ubound_set (&se->post, desc,
6373 gfc_rank_cst[n], tmp);
6375 /* Set stride and accumulate the offset. */
6376 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
6377 gfc_conv_descriptor_stride_set (&se->post, desc,
6378 gfc_rank_cst[n], tmp);
6379 tmp = fold_build2_loc (input_location, MULT_EXPR,
6380 gfc_array_index_type, lbound, tmp);
6381 offset = fold_build2_loc (input_location, MINUS_EXPR,
6382 gfc_array_index_type, offset, tmp);
6383 offset = gfc_evaluate_now (offset, &se->post);
6386 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
6391 /* Try to translate array(:) = func (...), where func is a transformational
6392 array function, without using a temporary. Returns NULL if this isn't the
6396 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
6400 gfc_component *comp = NULL;
6403 if (arrayfunc_assign_needs_temporary (expr1, expr2))
6406 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
6408 gcc_assert (expr2->value.function.isym
6409 || (gfc_is_proc_ptr_comp (expr2, &comp)
6410 && comp && comp->attr.dimension)
6411 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
6412 && expr2->value.function.esym->result->attr.dimension));
6414 ss = gfc_walk_expr (expr1);
6415 gcc_assert (ss != gfc_ss_terminator);
6416 gfc_init_se (&se, NULL);
6417 gfc_start_block (&se.pre);
6418 se.want_pointer = 1;
6420 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
6422 if (expr1->ts.type == BT_DERIVED
6423 && expr1->ts.u.derived->attr.alloc_comp)
6426 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
6428 gfc_add_expr_to_block (&se.pre, tmp);
6431 se.direct_byref = 1;
6432 se.ss = gfc_walk_expr (expr2);
6433 gcc_assert (se.ss != gfc_ss_terminator);
6435 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
6436 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
6437 Clearly, this cannot be done for an allocatable function result, since
6438 the shape of the result is unknown and, in any case, the function must
6439 correctly take care of the reallocation internally. For intrinsic
6440 calls, the array data is freed and the library takes care of allocation.
6441 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
6443 if (gfc_option.flag_realloc_lhs
6444 && gfc_is_reallocatable_lhs (expr1)
6445 && !gfc_expr_attr (expr1).codimension
6446 && !gfc_is_coindexed (expr1)
6447 && !(expr2->value.function.esym
6448 && expr2->value.function.esym->result->attr.allocatable))
6450 if (!expr2->value.function.isym)
6452 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
6453 ss->is_alloc_lhs = 1;
6456 fcncall_realloc_result (&se, expr1->rank);
6459 gfc_conv_function_expr (&se, expr2);
6460 gfc_add_block_to_block (&se.pre, &se.post);
6462 return gfc_finish_block (&se.pre);
6466 /* Try to efficiently translate array(:) = 0. Return NULL if this
6470 gfc_trans_zero_assign (gfc_expr * expr)
6472 tree dest, len, type;
6476 sym = expr->symtree->n.sym;
6477 dest = gfc_get_symbol_decl (sym);
6479 type = TREE_TYPE (dest);
6480 if (POINTER_TYPE_P (type))
6481 type = TREE_TYPE (type);
6482 if (!GFC_ARRAY_TYPE_P (type))
6485 /* Determine the length of the array. */
6486 len = GFC_TYPE_ARRAY_SIZE (type);
6487 if (!len || TREE_CODE (len) != INTEGER_CST)
6490 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6491 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
6492 fold_convert (gfc_array_index_type, tmp));
6494 /* If we are zeroing a local array avoid taking its address by emitting
6496 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
6497 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
6498 dest, build_constructor (TREE_TYPE (dest), NULL));
6500 /* Convert arguments to the correct types. */
6501 dest = fold_convert (pvoid_type_node, dest);
6502 len = fold_convert (size_type_node, len);
6504 /* Construct call to __builtin_memset. */
6505 tmp = build_call_expr_loc (input_location,
6506 builtin_decl_explicit (BUILT_IN_MEMSET),
6507 3, dest, integer_zero_node, len);
6508 return fold_convert (void_type_node, tmp);
6512 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
6513 that constructs the call to __builtin_memcpy. */
6516 gfc_build_memcpy_call (tree dst, tree src, tree len)
6520 /* Convert arguments to the correct types. */
6521 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
6522 dst = gfc_build_addr_expr (pvoid_type_node, dst);
6524 dst = fold_convert (pvoid_type_node, dst);
6526 if (!POINTER_TYPE_P (TREE_TYPE (src)))
6527 src = gfc_build_addr_expr (pvoid_type_node, src);
6529 src = fold_convert (pvoid_type_node, src);
6531 len = fold_convert (size_type_node, len);
6533 /* Construct call to __builtin_memcpy. */
6534 tmp = build_call_expr_loc (input_location,
6535 builtin_decl_explicit (BUILT_IN_MEMCPY),
6537 return fold_convert (void_type_node, tmp);
6541 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
6542 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
6543 source/rhs, both are gfc_full_array_ref_p which have been checked for
6547 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
6549 tree dst, dlen, dtype;
6550 tree src, slen, stype;
6553 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
6554 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
6556 dtype = TREE_TYPE (dst);
6557 if (POINTER_TYPE_P (dtype))
6558 dtype = TREE_TYPE (dtype);
6559 stype = TREE_TYPE (src);
6560 if (POINTER_TYPE_P (stype))
6561 stype = TREE_TYPE (stype);
6563 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
6566 /* Determine the lengths of the arrays. */
6567 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
6568 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
6570 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
6571 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6572 dlen, fold_convert (gfc_array_index_type, tmp));
6574 slen = GFC_TYPE_ARRAY_SIZE (stype);
6575 if (!slen || TREE_CODE (slen) != INTEGER_CST)
6577 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
6578 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6579 slen, fold_convert (gfc_array_index_type, tmp));
6581 /* Sanity check that they are the same. This should always be
6582 the case, as we should already have checked for conformance. */
6583 if (!tree_int_cst_equal (slen, dlen))
6586 return gfc_build_memcpy_call (dst, src, dlen);
6590 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
6591 this can't be done. EXPR1 is the destination/lhs for which
6592 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
6595 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
6597 unsigned HOST_WIDE_INT nelem;
6603 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
6607 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
6608 dtype = TREE_TYPE (dst);
6609 if (POINTER_TYPE_P (dtype))
6610 dtype = TREE_TYPE (dtype);
6611 if (!GFC_ARRAY_TYPE_P (dtype))
6614 /* Determine the lengths of the array. */
6615 len = GFC_TYPE_ARRAY_SIZE (dtype);
6616 if (!len || TREE_CODE (len) != INTEGER_CST)
6619 /* Confirm that the constructor is the same size. */
6620 if (compare_tree_int (len, nelem) != 0)
6623 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
6624 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
6625 fold_convert (gfc_array_index_type, tmp));
6627 stype = gfc_typenode_for_spec (&expr2->ts);
6628 src = gfc_build_constant_array_constructor (expr2, stype);
6630 stype = TREE_TYPE (src);
6631 if (POINTER_TYPE_P (stype))
6632 stype = TREE_TYPE (stype);
6634 return gfc_build_memcpy_call (dst, src, len);
6638 /* Tells whether the expression is to be treated as a variable reference. */
6641 expr_is_variable (gfc_expr *expr)
6645 if (expr->expr_type == EXPR_VARIABLE)
6648 arg = gfc_get_noncopying_intrinsic_argument (expr);
6651 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6652 return expr_is_variable (arg);
6659 /* Is the lhs OK for automatic reallocation? */
6662 is_scalar_reallocatable_lhs (gfc_expr *expr)
6666 /* An allocatable variable with no reference. */
6667 if (expr->symtree->n.sym->attr.allocatable
6671 /* All that can be left are allocatable components. */
6672 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6673 && expr->symtree->n.sym->ts.type != BT_CLASS)
6674 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6677 /* Find an allocatable component ref last. */
6678 for (ref = expr->ref; ref; ref = ref->next)
6679 if (ref->type == REF_COMPONENT
6681 && ref->u.c.component->attr.allocatable)
6688 /* Allocate or reallocate scalar lhs, as necessary. */
6691 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
6705 if (!expr1 || expr1->rank)
6708 if (!expr2 || expr2->rank)
6711 /* Since this is a scalar lhs, we can afford to do this. That is,
6712 there is no risk of side effects being repeated. */
6713 gfc_init_se (&lse, NULL);
6714 lse.want_pointer = 1;
6715 gfc_conv_expr (&lse, expr1);
6717 jump_label1 = gfc_build_label_decl (NULL_TREE);
6718 jump_label2 = gfc_build_label_decl (NULL_TREE);
6720 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6721 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
6722 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6724 tmp = build3_v (COND_EXPR, cond,
6725 build1_v (GOTO_EXPR, jump_label1),
6726 build_empty_stmt (input_location));
6727 gfc_add_expr_to_block (block, tmp);
6729 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6731 /* Use the rhs string length and the lhs element size. */
6732 size = string_length;
6733 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
6734 tmp = TYPE_SIZE_UNIT (tmp);
6735 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
6736 TREE_TYPE (tmp), tmp,
6737 fold_convert (TREE_TYPE (tmp), size));
6741 /* Otherwise use the length in bytes of the rhs. */
6742 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6743 size_in_bytes = size;
6746 if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
6748 tmp = build_call_expr_loc (input_location,
6749 builtin_decl_explicit (BUILT_IN_CALLOC),
6750 2, build_one_cst (size_type_node),
6752 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6753 gfc_add_modify (block, lse.expr, tmp);
6757 tmp = build_call_expr_loc (input_location,
6758 builtin_decl_explicit (BUILT_IN_MALLOC),
6760 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6761 gfc_add_modify (block, lse.expr, tmp);
6764 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6766 /* Deferred characters need checking for lhs and rhs string
6767 length. Other deferred parameter variables will have to
6769 tmp = build1_v (GOTO_EXPR, jump_label2);
6770 gfc_add_expr_to_block (block, tmp);
6772 tmp = build1_v (LABEL_EXPR, jump_label1);
6773 gfc_add_expr_to_block (block, tmp);
6775 /* For a deferred length character, reallocate if lengths of lhs and
6776 rhs are different. */
6777 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6779 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6780 expr1->ts.u.cl->backend_decl, size);
6781 /* Jump past the realloc if the lengths are the same. */
6782 tmp = build3_v (COND_EXPR, cond,
6783 build1_v (GOTO_EXPR, jump_label2),
6784 build_empty_stmt (input_location));
6785 gfc_add_expr_to_block (block, tmp);
6786 tmp = build_call_expr_loc (input_location,
6787 builtin_decl_explicit (BUILT_IN_REALLOC),
6788 2, fold_convert (pvoid_type_node, lse.expr),
6790 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
6791 gfc_add_modify (block, lse.expr, tmp);
6792 tmp = build1_v (LABEL_EXPR, jump_label2);
6793 gfc_add_expr_to_block (block, tmp);
6795 /* Update the lhs character length. */
6796 size = string_length;
6797 gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
6802 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6803 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6804 init_flag indicates initialization expressions and dealloc that no
6805 deallocate prior assignment is needed (if in doubt, set true). */
6808 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6814 gfc_ss *lss_section;
6821 bool scalar_to_array;
6826 /* Assignment of the form lhs = rhs. */
6827 gfc_start_block (&block);
6829 gfc_init_se (&lse, NULL);
6830 gfc_init_se (&rse, NULL);
6833 lss = gfc_walk_expr (expr1);
6834 if (gfc_is_reallocatable_lhs (expr1)
6835 && !(expr2->expr_type == EXPR_FUNCTION
6836 && expr2->value.function.isym != NULL))
6837 lss->is_alloc_lhs = 1;
6839 if (lss != gfc_ss_terminator)
6841 /* The assignment needs scalarization. */
6844 /* Find a non-scalar SS from the lhs. */
6845 while (lss_section != gfc_ss_terminator
6846 && lss_section->info->type != GFC_SS_SECTION)
6847 lss_section = lss_section->next;
6849 gcc_assert (lss_section != gfc_ss_terminator);
6851 /* Initialize the scalarizer. */
6852 gfc_init_loopinfo (&loop);
6855 rss = gfc_walk_expr (expr2);
6856 if (rss == gfc_ss_terminator)
6857 /* The rhs is scalar. Add a ss for the expression. */
6858 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6860 /* Associate the SS with the loop. */
6861 gfc_add_ss_to_loop (&loop, lss);
6862 gfc_add_ss_to_loop (&loop, rss);
6864 /* Calculate the bounds of the scalarization. */
6865 gfc_conv_ss_startstride (&loop);
6866 /* Enable loop reversal. */
6867 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
6868 loop.reverse[n] = GFC_ENABLE_REVERSE;
6869 /* Resolve any data dependencies in the statement. */
6870 gfc_conv_resolve_dependencies (&loop, lss, rss);
6871 /* Setup the scalarizing loops. */
6872 gfc_conv_loop_setup (&loop, &expr2->where);
6874 /* Setup the gfc_se structures. */
6875 gfc_copy_loopinfo_to_se (&lse, &loop);
6876 gfc_copy_loopinfo_to_se (&rse, &loop);
6879 gfc_mark_ss_chain_used (rss, 1);
6880 if (loop.temp_ss == NULL)
6883 gfc_mark_ss_chain_used (lss, 1);
6887 lse.ss = loop.temp_ss;
6888 gfc_mark_ss_chain_used (lss, 3);
6889 gfc_mark_ss_chain_used (loop.temp_ss, 3);
6892 /* Allow the scalarizer to workshare array assignments. */
6893 if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
6894 ompws_flags |= OMPWS_SCALARIZER_WS;
6896 /* Start the scalarized loop body. */
6897 gfc_start_scalarized_body (&loop, &body);
6900 gfc_init_block (&body);
6902 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
6904 /* Translate the expression. */
6905 gfc_conv_expr (&rse, expr2);
6907 /* Stabilize a string length for temporaries. */
6908 if (expr2->ts.type == BT_CHARACTER)
6909 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
6911 string_length = NULL_TREE;
6915 gfc_conv_tmp_array_ref (&lse);
6916 if (expr2->ts.type == BT_CHARACTER)
6917 lse.string_length = string_length;
6920 gfc_conv_expr (&lse, expr1);
6922 /* Assignments of scalar derived types with allocatable components
6923 to arrays must be done with a deep copy and the rhs temporary
6924 must have its components deallocated afterwards. */
6925 scalar_to_array = (expr2->ts.type == BT_DERIVED
6926 && expr2->ts.u.derived->attr.alloc_comp
6927 && !expr_is_variable (expr2)
6928 && !gfc_is_constant_expr (expr2)
6929 && expr1->rank && !expr2->rank);
6930 if (scalar_to_array && dealloc)
6932 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
6933 gfc_add_expr_to_block (&loop.post, tmp);
6936 /* For a deferred character length function, the function call must
6937 happen before the (re)allocation of the lhs, otherwise the character
6938 length of the result is not known. */
6939 def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
6940 || (expr2->expr_type == EXPR_COMPCALL)
6941 || (expr2->expr_type == EXPR_PPC))
6942 && expr2->ts.deferred);
6943 if (gfc_option.flag_realloc_lhs
6944 && expr2->ts.type == BT_CHARACTER
6945 && (def_clen_func || expr2->expr_type == EXPR_OP)
6946 && expr1->ts.deferred)
6947 gfc_add_block_to_block (&block, &rse.pre);
6949 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6950 l_is_temp || init_flag,
6951 expr_is_variable (expr2) || scalar_to_array
6952 || expr2->expr_type == EXPR_ARRAY, dealloc);
6953 gfc_add_expr_to_block (&body, tmp);
6955 if (lss == gfc_ss_terminator)
6957 /* F2003: Add the code for reallocation on assignment. */
6958 if (gfc_option.flag_realloc_lhs
6959 && is_scalar_reallocatable_lhs (expr1))
6960 alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
6963 /* Use the scalar assignment as is. */
6964 gfc_add_block_to_block (&block, &body);
6968 gcc_assert (lse.ss == gfc_ss_terminator
6969 && rse.ss == gfc_ss_terminator);
6973 gfc_trans_scalarized_loop_boundary (&loop, &body);
6975 /* We need to copy the temporary to the actual lhs. */
6976 gfc_init_se (&lse, NULL);
6977 gfc_init_se (&rse, NULL);
6978 gfc_copy_loopinfo_to_se (&lse, &loop);
6979 gfc_copy_loopinfo_to_se (&rse, &loop);
6981 rse.ss = loop.temp_ss;
6984 gfc_conv_tmp_array_ref (&rse);
6985 gfc_conv_expr (&lse, expr1);
6987 gcc_assert (lse.ss == gfc_ss_terminator
6988 && rse.ss == gfc_ss_terminator);
6990 if (expr2->ts.type == BT_CHARACTER)
6991 rse.string_length = string_length;
6993 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6994 false, false, dealloc);
6995 gfc_add_expr_to_block (&body, tmp);
6998 /* F2003: Allocate or reallocate lhs of allocatable array. */
6999 if (gfc_option.flag_realloc_lhs
7000 && gfc_is_reallocatable_lhs (expr1)
7001 && !gfc_expr_attr (expr1).codimension
7002 && !gfc_is_coindexed (expr1))
7004 ompws_flags &= ~OMPWS_SCALARIZER_WS;
7005 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
7006 if (tmp != NULL_TREE)
7007 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
7010 /* Generate the copying loops. */
7011 gfc_trans_scalarizing_loops (&loop, &body);
7013 /* Wrap the whole thing up. */
7014 gfc_add_block_to_block (&block, &loop.pre);
7015 gfc_add_block_to_block (&block, &loop.post);
7017 gfc_cleanup_loop (&loop);
7020 return gfc_finish_block (&block);
7024 /* Check whether EXPR is a copyable array. */
7027 copyable_array_p (gfc_expr * expr)
7029 if (expr->expr_type != EXPR_VARIABLE)
7032 /* First check it's an array. */
7033 if (expr->rank < 1 || !expr->ref || expr->ref->next)
7036 if (!gfc_full_array_ref_p (expr->ref, NULL))
7039 /* Next check that it's of a simple enough type. */
7040 switch (expr->ts.type)
7052 return !expr->ts.u.derived->attr.alloc_comp;
7061 /* Translate an assignment. */
7064 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
7069 /* Special case a single function returning an array. */
7070 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
7072 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
7077 /* Special case assigning an array to zero. */
7078 if (copyable_array_p (expr1)
7079 && is_zero_initializer_p (expr2))
7081 tmp = gfc_trans_zero_assign (expr1);
7086 /* Special case copying one array to another. */
7087 if (copyable_array_p (expr1)
7088 && copyable_array_p (expr2)
7089 && gfc_compare_types (&expr1->ts, &expr2->ts)
7090 && !gfc_check_dependency (expr1, expr2, 0))
7092 tmp = gfc_trans_array_copy (expr1, expr2);
7097 /* Special case initializing an array from a constant array constructor. */
7098 if (copyable_array_p (expr1)
7099 && expr2->expr_type == EXPR_ARRAY
7100 && gfc_compare_types (&expr1->ts, &expr2->ts))
7102 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
7107 /* Fallback to the scalarizer to generate explicit loops. */
7108 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
7112 gfc_trans_init_assign (gfc_code * code)
7114 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
7118 gfc_trans_assign (gfc_code * code)
7120 return gfc_trans_assignment (code->expr1, code->expr2, false, true);