1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se * se, gfc_se * parent)
66 memset (se, 0, sizeof (gfc_se));
67 gfc_init_block (&se->pre);
68 gfc_init_block (&se->post);
73 gfc_copy_se_loopvars (se, parent);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se * se)
110 if (CONSTANT_CLASS_P (se->expr))
113 /* We need a temporary for this result. */
114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115 gfc_add_modify (&se->pre, var, se->expr);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol * sym)
128 gcc_assert (sym->attr.dummy);
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
140 cond = fold_build2 (NE_EXPR, boolean_type_node, decl,
141 fold_convert (TREE_TYPE (decl), null_pointer_node));
143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
144 as actual argument to denote absent dummies. For array descriptors,
145 we thus also need to check the array descriptor. */
146 if (!sym->attr.pointer && !sym->attr.allocatable
147 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
148 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
151 tmp = build_fold_indirect_ref_loc (input_location, decl);
152 tmp = gfc_conv_array_data (tmp);
153 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
154 fold_convert (TREE_TYPE (tmp), null_pointer_node));
155 cond = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, tmp);
162 /* Converts a missing, dummy argument into a null or zero. */
165 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
170 present = gfc_conv_expr_present (arg->symtree->n.sym);
174 /* Create a temporary and convert it to the correct type. */
175 tmp = gfc_get_int_type (kind);
176 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
179 /* Test for a NULL value. */
180 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
181 fold_convert (TREE_TYPE (tmp), integer_one_node));
182 tmp = gfc_evaluate_now (tmp, &se->pre);
183 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
187 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
188 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
189 tmp = gfc_evaluate_now (tmp, &se->pre);
193 if (ts.type == BT_CHARACTER)
195 tmp = build_int_cst (gfc_charlen_type_node, 0);
196 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
197 present, se->string_length, tmp);
198 tmp = gfc_evaluate_now (tmp, &se->pre);
199 se->string_length = tmp;
205 /* Get the character length of an expression, looking through gfc_refs
209 gfc_get_expr_charlen (gfc_expr *e)
214 gcc_assert (e->expr_type == EXPR_VARIABLE
215 && e->ts.type == BT_CHARACTER);
217 length = NULL; /* To silence compiler warning. */
219 if (is_subref_array (e) && e->ts.u.cl->length)
222 gfc_init_se (&tmpse, NULL);
223 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
224 e->ts.u.cl->backend_decl = tmpse.expr;
228 /* First candidate: if the variable is of type CHARACTER, the
229 expression's length could be the length of the character
231 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
232 length = e->symtree->n.sym->ts.u.cl->backend_decl;
234 /* Look through the reference chain for component references. */
235 for (r = e->ref; r; r = r->next)
240 if (r->u.c.component->ts.type == BT_CHARACTER)
241 length = r->u.c.component->ts.u.cl->backend_decl;
249 /* We should never got substring references here. These will be
250 broken down by the scalarizer. */
256 gcc_assert (length != NULL);
261 /* For each character array constructor subexpression without a ts.u.cl->length,
262 replace it by its first element (if there aren't any elements, the length
263 should already be set to zero). */
266 flatten_array_ctors_without_strlen (gfc_expr* e)
268 gfc_actual_arglist* arg;
274 switch (e->expr_type)
278 flatten_array_ctors_without_strlen (e->value.op.op1);
279 flatten_array_ctors_without_strlen (e->value.op.op2);
283 /* TODO: Implement as with EXPR_FUNCTION when needed. */
287 for (arg = e->value.function.actual; arg; arg = arg->next)
288 flatten_array_ctors_without_strlen (arg->expr);
293 /* We've found what we're looking for. */
294 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
299 gcc_assert (e->value.constructor);
301 c = gfc_constructor_first (e->value.constructor);
305 flatten_array_ctors_without_strlen (new_expr);
306 gfc_replace_expr (e, new_expr);
310 /* Otherwise, fall through to handle constructor elements. */
312 for (c = gfc_constructor_first (e->value.constructor);
313 c; c = gfc_constructor_next (c))
314 flatten_array_ctors_without_strlen (c->expr);
324 /* Generate code to initialize a string length variable. Returns the
325 value. For array constructors, cl->length might be NULL and in this case,
326 the first element of the constructor is needed. expr is the original
327 expression so we can access it but can be NULL if this is not needed. */
330 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
334 gfc_init_se (&se, NULL);
336 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
337 "flatten" array constructors by taking their first element; all elements
338 should be the same length or a cl->length should be present. */
344 expr_flat = gfc_copy_expr (expr);
345 flatten_array_ctors_without_strlen (expr_flat);
346 gfc_resolve_expr (expr_flat);
348 gfc_conv_expr (&se, expr_flat);
349 gfc_add_block_to_block (pblock, &se.pre);
350 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
352 gfc_free_expr (expr_flat);
356 /* Convert cl->length. */
358 gcc_assert (cl->length);
360 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
361 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
362 build_int_cst (gfc_charlen_type_node, 0));
363 gfc_add_block_to_block (pblock, &se.pre);
365 if (cl->backend_decl)
366 gfc_add_modify (pblock, cl->backend_decl, se.expr);
368 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
373 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
374 const char *name, locus *where)
383 type = gfc_get_character_type (kind, ref->u.ss.length);
384 type = build_pointer_type (type);
386 gfc_init_se (&start, se);
387 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
388 gfc_add_block_to_block (&se->pre, &start.pre);
390 if (integer_onep (start.expr))
391 gfc_conv_string_parameter (se);
396 /* Avoid multiple evaluation of substring start. */
397 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
398 start.expr = gfc_evaluate_now (start.expr, &se->pre);
400 /* Change the start of the string. */
401 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
404 tmp = build_fold_indirect_ref_loc (input_location,
406 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
407 se->expr = gfc_build_addr_expr (type, tmp);
410 /* Length = end + 1 - start. */
411 gfc_init_se (&end, se);
412 if (ref->u.ss.end == NULL)
413 end.expr = se->string_length;
416 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
417 gfc_add_block_to_block (&se->pre, &end.pre);
421 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
422 end.expr = gfc_evaluate_now (end.expr, &se->pre);
424 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
426 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
427 start.expr, end.expr);
429 /* Check lower bound. */
430 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
431 build_int_cst (gfc_charlen_type_node, 1));
432 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
435 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
436 "is less than one", name);
438 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
440 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
441 fold_convert (long_integer_type_node,
445 /* Check upper bound. */
446 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
448 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
451 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
452 "exceeds string length (%%ld)", name);
454 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
455 "exceeds string length (%%ld)");
456 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
457 fold_convert (long_integer_type_node, end.expr),
458 fold_convert (long_integer_type_node,
463 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
464 end.expr, start.expr);
465 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
466 build_int_cst (gfc_charlen_type_node, 1), tmp);
467 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
468 build_int_cst (gfc_charlen_type_node, 0));
469 se->string_length = tmp;
473 /* Convert a derived type component reference. */
476 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
483 c = ref->u.c.component;
485 gcc_assert (c->backend_decl);
487 field = c->backend_decl;
488 gcc_assert (TREE_CODE (field) == FIELD_DECL);
490 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
494 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
496 tmp = c->ts.u.cl->backend_decl;
497 /* Components must always be constant length. */
498 gcc_assert (tmp && INTEGER_CST_P (tmp));
499 se->string_length = tmp;
502 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
503 && c->ts.type != BT_CHARACTER)
504 || c->attr.proc_pointer)
505 se->expr = build_fold_indirect_ref_loc (input_location,
510 /* This function deals with component references to components of the
511 parent type for derived type extensons. */
513 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
521 c = ref->u.c.component;
523 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
524 parent.type = REF_COMPONENT;
527 parent.u.c.component = dt->components;
529 if (dt->backend_decl == NULL)
530 gfc_get_derived_type (dt);
532 if (dt->attr.extension && dt->components)
534 if (dt->attr.is_class)
535 cmp = dt->components;
537 cmp = dt->components->next;
538 /* Return if the component is not in the parent type. */
539 for (; cmp; cmp = cmp->next)
540 if (strcmp (c->name, cmp->name) == 0)
543 /* Otherwise build the reference and call self. */
544 gfc_conv_component_ref (se, &parent);
545 parent.u.c.sym = dt->components->ts.u.derived;
546 parent.u.c.component = c;
547 conv_parent_component_references (se, &parent);
551 /* Return the contents of a variable. Also handles reference/pointer
552 variables (all Fortran pointer references are implicit). */
555 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
559 tree parent_decl = NULL_TREE;
562 bool alternate_entry;
565 sym = expr->symtree->n.sym;
568 /* Check that something hasn't gone horribly wrong. */
569 gcc_assert (se->ss != gfc_ss_terminator);
570 gcc_assert (se->ss->expr == expr);
572 /* A scalarized term. We already know the descriptor. */
573 se->expr = se->ss->data.info.descriptor;
574 se->string_length = se->ss->string_length;
575 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
576 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
581 tree se_expr = NULL_TREE;
583 se->expr = gfc_get_symbol_decl (sym);
585 /* Deal with references to a parent results or entries by storing
586 the current_function_decl and moving to the parent_decl. */
587 return_value = sym->attr.function && sym->result == sym;
588 alternate_entry = sym->attr.function && sym->attr.entry
589 && sym->result == sym;
590 entry_master = sym->attr.result
591 && sym->ns->proc_name->attr.entry_master
592 && !gfc_return_by_reference (sym->ns->proc_name);
593 if (current_function_decl)
594 parent_decl = DECL_CONTEXT (current_function_decl);
596 if ((se->expr == parent_decl && return_value)
597 || (sym->ns && sym->ns->proc_name
599 && sym->ns->proc_name->backend_decl == parent_decl
600 && (alternate_entry || entry_master)))
605 /* Special case for assigning the return value of a function.
606 Self recursive functions must have an explicit return value. */
607 if (return_value && (se->expr == current_function_decl || parent_flag))
608 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
610 /* Similarly for alternate entry points. */
611 else if (alternate_entry
612 && (sym->ns->proc_name->backend_decl == current_function_decl
615 gfc_entry_list *el = NULL;
617 for (el = sym->ns->entries; el; el = el->next)
620 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
625 else if (entry_master
626 && (sym->ns->proc_name->backend_decl == current_function_decl
628 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
633 /* Procedure actual arguments. */
634 else if (sym->attr.flavor == FL_PROCEDURE
635 && se->expr != current_function_decl)
637 if (!sym->attr.dummy && !sym->attr.proc_pointer)
639 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
640 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
646 /* Dereference the expression, where needed. Since characters
647 are entirely different from other types, they are treated
649 if (sym->ts.type == BT_CHARACTER)
651 /* Dereference character pointer dummy arguments
653 if ((sym->attr.pointer || sym->attr.allocatable)
655 || sym->attr.function
656 || sym->attr.result))
657 se->expr = build_fold_indirect_ref_loc (input_location,
661 else if (!sym->attr.value)
663 /* Dereference non-character scalar dummy arguments. */
664 if (sym->attr.dummy && !sym->attr.dimension)
665 se->expr = build_fold_indirect_ref_loc (input_location,
668 /* Dereference scalar hidden result. */
669 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
670 && (sym->attr.function || sym->attr.result)
671 && !sym->attr.dimension && !sym->attr.pointer
672 && !sym->attr.always_explicit)
673 se->expr = build_fold_indirect_ref_loc (input_location,
676 /* Dereference non-character pointer variables.
677 These must be dummies, results, or scalars. */
678 if ((sym->attr.pointer || sym->attr.allocatable
679 || gfc_is_associate_pointer (sym))
681 || sym->attr.function
683 || !sym->attr.dimension))
684 se->expr = build_fold_indirect_ref_loc (input_location,
691 /* For character variables, also get the length. */
692 if (sym->ts.type == BT_CHARACTER)
694 /* If the character length of an entry isn't set, get the length from
695 the master function instead. */
696 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
697 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
699 se->string_length = sym->ts.u.cl->backend_decl;
700 gcc_assert (se->string_length);
708 /* Return the descriptor if that's what we want and this is an array
709 section reference. */
710 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
712 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
713 /* Return the descriptor for array pointers and allocations. */
715 && ref->next == NULL && (se->descriptor_only))
718 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
719 /* Return a pointer to an element. */
723 if (ref->u.c.sym->attr.extension)
724 conv_parent_component_references (se, ref);
726 gfc_conv_component_ref (se, ref);
730 gfc_conv_substring (se, ref, expr->ts.kind,
731 expr->symtree->name, &expr->where);
740 /* Pointer assignment, allocation or pass by reference. Arrays are handled
742 if (se->want_pointer)
744 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
745 gfc_conv_string_parameter (se);
747 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
752 /* Unary ops are easy... Or they would be if ! was a valid op. */
755 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
760 gcc_assert (expr->ts.type != BT_CHARACTER);
761 /* Initialize the operand. */
762 gfc_init_se (&operand, se);
763 gfc_conv_expr_val (&operand, expr->value.op.op1);
764 gfc_add_block_to_block (&se->pre, &operand.pre);
766 type = gfc_typenode_for_spec (&expr->ts);
768 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
769 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
770 All other unary operators have an equivalent GIMPLE unary operator. */
771 if (code == TRUTH_NOT_EXPR)
772 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
773 build_int_cst (type, 0));
775 se->expr = fold_build1 (code, type, operand.expr);
779 /* Expand power operator to optimal multiplications when a value is raised
780 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
781 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
782 Programming", 3rd Edition, 1998. */
784 /* This code is mostly duplicated from expand_powi in the backend.
785 We establish the "optimal power tree" lookup table with the defined size.
786 The items in the table are the exponents used to calculate the index
787 exponents. Any integer n less than the value can get an "addition chain",
788 with the first node being one. */
789 #define POWI_TABLE_SIZE 256
791 /* The table is from builtins.c. */
792 static const unsigned char powi_table[POWI_TABLE_SIZE] =
794 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
795 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
796 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
797 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
798 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
799 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
800 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
801 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
802 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
803 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
804 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
805 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
806 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
807 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
808 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
809 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
810 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
811 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
812 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
813 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
814 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
815 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
816 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
817 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
818 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
819 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
820 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
821 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
822 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
823 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
824 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
825 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
828 /* If n is larger than lookup table's max index, we use the "window
830 #define POWI_WINDOW_SIZE 3
832 /* Recursive function to expand the power operator. The temporary
833 values are put in tmpvar. The function returns tmpvar[1] ** n. */
835 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
842 if (n < POWI_TABLE_SIZE)
847 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
848 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
852 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
853 op0 = gfc_conv_powi (se, n - digit, tmpvar);
854 op1 = gfc_conv_powi (se, digit, tmpvar);
858 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
862 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
863 tmp = gfc_evaluate_now (tmp, &se->pre);
865 if (n < POWI_TABLE_SIZE)
872 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
873 return 1. Else return 0 and a call to runtime library functions
874 will have to be built. */
876 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
881 tree vartmp[POWI_TABLE_SIZE];
883 unsigned HOST_WIDE_INT n;
886 /* If exponent is too large, we won't expand it anyway, so don't bother
887 with large integer values. */
888 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
891 m = double_int_to_shwi (TREE_INT_CST (rhs));
892 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
893 of the asymmetric range of the integer type. */
894 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
896 type = TREE_TYPE (lhs);
897 sgn = tree_int_cst_sgn (rhs);
899 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
900 || optimize_size) && (m > 2 || m < -1))
906 se->expr = gfc_build_const (type, integer_one_node);
910 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
911 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
913 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
914 lhs, build_int_cst (TREE_TYPE (lhs), -1));
915 cond = fold_build2 (EQ_EXPR, boolean_type_node,
916 lhs, build_int_cst (TREE_TYPE (lhs), 1));
919 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
922 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
923 se->expr = fold_build3 (COND_EXPR, type,
924 tmp, build_int_cst (type, 1),
925 build_int_cst (type, 0));
929 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
930 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
931 build_int_cst (type, 0));
932 se->expr = fold_build3 (COND_EXPR, type,
933 cond, build_int_cst (type, 1), tmp);
937 memset (vartmp, 0, sizeof (vartmp));
941 tmp = gfc_build_const (type, integer_one_node);
942 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
945 se->expr = gfc_conv_powi (se, n, vartmp);
951 /* Power op (**). Constant integer exponent has special handling. */
954 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
956 tree gfc_int4_type_node;
963 gfc_init_se (&lse, se);
964 gfc_conv_expr_val (&lse, expr->value.op.op1);
965 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
966 gfc_add_block_to_block (&se->pre, &lse.pre);
968 gfc_init_se (&rse, se);
969 gfc_conv_expr_val (&rse, expr->value.op.op2);
970 gfc_add_block_to_block (&se->pre, &rse.pre);
972 if (expr->value.op.op2->ts.type == BT_INTEGER
973 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
974 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
977 gfc_int4_type_node = gfc_get_int_type (4);
979 kind = expr->value.op.op1->ts.kind;
980 switch (expr->value.op.op2->ts.type)
983 ikind = expr->value.op.op2->ts.kind;
988 rse.expr = convert (gfc_int4_type_node, rse.expr);
1010 if (expr->value.op.op1->ts.type == BT_INTEGER)
1011 lse.expr = convert (gfc_int4_type_node, lse.expr);
1036 switch (expr->value.op.op1->ts.type)
1039 if (kind == 3) /* Case 16 was not handled properly above. */
1041 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1045 /* Use builtins for real ** int4. */
1051 fndecl = built_in_decls[BUILT_IN_POWIF];
1055 fndecl = built_in_decls[BUILT_IN_POWI];
1060 fndecl = built_in_decls[BUILT_IN_POWIL];
1068 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1072 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1084 fndecl = built_in_decls[BUILT_IN_POWF];
1087 fndecl = built_in_decls[BUILT_IN_POW];
1091 fndecl = built_in_decls[BUILT_IN_POWL];
1102 fndecl = built_in_decls[BUILT_IN_CPOWF];
1105 fndecl = built_in_decls[BUILT_IN_CPOW];
1109 fndecl = built_in_decls[BUILT_IN_CPOWL];
1121 se->expr = build_call_expr_loc (input_location,
1122 fndecl, 2, lse.expr, rse.expr);
1126 /* Generate code to allocate a string temporary. */
1129 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1134 if (gfc_can_put_var_on_stack (len))
1136 /* Create a temporary variable to hold the result. */
1137 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1138 build_int_cst (gfc_charlen_type_node, 1));
1139 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1141 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1142 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1144 tmp = build_array_type (TREE_TYPE (type), tmp);
1146 var = gfc_create_var (tmp, "str");
1147 var = gfc_build_addr_expr (type, var);
1151 /* Allocate a temporary to hold the result. */
1152 var = gfc_create_var (type, "pstr");
1153 tmp = gfc_call_malloc (&se->pre, type,
1154 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1155 fold_convert (TREE_TYPE (len),
1156 TYPE_SIZE (type))));
1157 gfc_add_modify (&se->pre, var, tmp);
1159 /* Free the temporary afterwards. */
1160 tmp = gfc_call_free (convert (pvoid_type_node, var));
1161 gfc_add_expr_to_block (&se->post, tmp);
1168 /* Handle a string concatenation operation. A temporary will be allocated to
1172 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1175 tree len, type, var, tmp, fndecl;
1177 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1178 && expr->value.op.op2->ts.type == BT_CHARACTER);
1179 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1181 gfc_init_se (&lse, se);
1182 gfc_conv_expr (&lse, expr->value.op.op1);
1183 gfc_conv_string_parameter (&lse);
1184 gfc_init_se (&rse, se);
1185 gfc_conv_expr (&rse, expr->value.op.op2);
1186 gfc_conv_string_parameter (&rse);
1188 gfc_add_block_to_block (&se->pre, &lse.pre);
1189 gfc_add_block_to_block (&se->pre, &rse.pre);
1191 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1192 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1193 if (len == NULL_TREE)
1195 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1196 lse.string_length, rse.string_length);
1199 type = build_pointer_type (type);
1201 var = gfc_conv_string_tmp (se, type, len);
1203 /* Do the actual concatenation. */
1204 if (expr->ts.kind == 1)
1205 fndecl = gfor_fndecl_concat_string;
1206 else if (expr->ts.kind == 4)
1207 fndecl = gfor_fndecl_concat_string_char4;
1211 tmp = build_call_expr_loc (input_location,
1212 fndecl, 6, len, var, lse.string_length, lse.expr,
1213 rse.string_length, rse.expr);
1214 gfc_add_expr_to_block (&se->pre, tmp);
1216 /* Add the cleanup for the operands. */
1217 gfc_add_block_to_block (&se->pre, &rse.post);
1218 gfc_add_block_to_block (&se->pre, &lse.post);
1221 se->string_length = len;
1224 /* Translates an op expression. Common (binary) cases are handled by this
1225 function, others are passed on. Recursion is used in either case.
1226 We use the fact that (op1.ts == op2.ts) (except for the power
1228 Operators need no special handling for scalarized expressions as long as
1229 they call gfc_conv_simple_val to get their operands.
1230 Character strings get special handling. */
1233 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1235 enum tree_code code;
1244 switch (expr->value.op.op)
1246 case INTRINSIC_PARENTHESES:
1247 if ((expr->ts.type == BT_REAL
1248 || expr->ts.type == BT_COMPLEX)
1249 && gfc_option.flag_protect_parens)
1251 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1252 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1257 case INTRINSIC_UPLUS:
1258 gfc_conv_expr (se, expr->value.op.op1);
1261 case INTRINSIC_UMINUS:
1262 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1266 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1269 case INTRINSIC_PLUS:
1273 case INTRINSIC_MINUS:
1277 case INTRINSIC_TIMES:
1281 case INTRINSIC_DIVIDE:
1282 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1283 an integer, we must round towards zero, so we use a
1285 if (expr->ts.type == BT_INTEGER)
1286 code = TRUNC_DIV_EXPR;
1291 case INTRINSIC_POWER:
1292 gfc_conv_power_op (se, expr);
1295 case INTRINSIC_CONCAT:
1296 gfc_conv_concat_op (se, expr);
1300 code = TRUTH_ANDIF_EXPR;
1305 code = TRUTH_ORIF_EXPR;
1309 /* EQV and NEQV only work on logicals, but since we represent them
1310 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1312 case INTRINSIC_EQ_OS:
1320 case INTRINSIC_NE_OS:
1321 case INTRINSIC_NEQV:
1328 case INTRINSIC_GT_OS:
1335 case INTRINSIC_GE_OS:
1342 case INTRINSIC_LT_OS:
1349 case INTRINSIC_LE_OS:
1355 case INTRINSIC_USER:
1356 case INTRINSIC_ASSIGN:
1357 /* These should be converted into function calls by the frontend. */
1361 fatal_error ("Unknown intrinsic op");
1365 /* The only exception to this is **, which is handled separately anyway. */
1366 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1368 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1372 gfc_init_se (&lse, se);
1373 gfc_conv_expr (&lse, expr->value.op.op1);
1374 gfc_add_block_to_block (&se->pre, &lse.pre);
1377 gfc_init_se (&rse, se);
1378 gfc_conv_expr (&rse, expr->value.op.op2);
1379 gfc_add_block_to_block (&se->pre, &rse.pre);
1383 gfc_conv_string_parameter (&lse);
1384 gfc_conv_string_parameter (&rse);
1386 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1387 rse.string_length, rse.expr,
1388 expr->value.op.op1->ts.kind,
1390 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1391 gfc_add_block_to_block (&lse.post, &rse.post);
1394 type = gfc_typenode_for_spec (&expr->ts);
1398 /* The result of logical ops is always boolean_type_node. */
1399 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1400 se->expr = convert (type, tmp);
1403 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1405 /* Add the post blocks. */
1406 gfc_add_block_to_block (&se->post, &rse.post);
1407 gfc_add_block_to_block (&se->post, &lse.post);
1410 /* If a string's length is one, we convert it to a single character. */
1413 gfc_string_to_single_character (tree len, tree str, int kind)
1415 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1417 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1420 if (TREE_INT_CST_LOW (len) == 1)
1422 str = fold_convert (gfc_get_pchar_type (kind), str);
1423 return build_fold_indirect_ref_loc (input_location, str);
1427 && TREE_CODE (str) == ADDR_EXPR
1428 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1429 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1430 && array_ref_low_bound (TREE_OPERAND (str, 0))
1431 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1432 && TREE_INT_CST_LOW (len) > 1
1433 && TREE_INT_CST_LOW (len)
1434 == (unsigned HOST_WIDE_INT)
1435 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1437 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1438 ret = build_fold_indirect_ref_loc (input_location, ret);
1439 if (TREE_CODE (ret) == INTEGER_CST)
1441 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1442 int i, length = TREE_STRING_LENGTH (string_cst);
1443 const char *ptr = TREE_STRING_POINTER (string_cst);
1445 for (i = 1; i < length; i++)
1458 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1461 if (sym->backend_decl)
1463 /* This becomes the nominal_type in
1464 function.c:assign_parm_find_data_types. */
1465 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1466 /* This becomes the passed_type in
1467 function.c:assign_parm_find_data_types. C promotes char to
1468 integer for argument passing. */
1469 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1471 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1476 /* If we have a constant character expression, make it into an
1478 if ((*expr)->expr_type == EXPR_CONSTANT)
1483 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1484 (int)(*expr)->value.character.string[0]);
1485 if ((*expr)->ts.kind != gfc_c_int_kind)
1487 /* The expr needs to be compatible with a C int. If the
1488 conversion fails, then the 2 causes an ICE. */
1489 ts.type = BT_INTEGER;
1490 ts.kind = gfc_c_int_kind;
1491 gfc_convert_type (*expr, &ts, 2);
1494 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1496 if ((*expr)->ref == NULL)
1498 se->expr = gfc_string_to_single_character
1499 (build_int_cst (integer_type_node, 1),
1500 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1502 ((*expr)->symtree->n.sym)),
1507 gfc_conv_variable (se, *expr);
1508 se->expr = gfc_string_to_single_character
1509 (build_int_cst (integer_type_node, 1),
1510 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1518 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1519 if STR is a string literal, otherwise return -1. */
1522 gfc_optimize_len_trim (tree len, tree str, int kind)
1525 && TREE_CODE (str) == ADDR_EXPR
1526 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1527 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1528 && array_ref_low_bound (TREE_OPERAND (str, 0))
1529 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1530 && TREE_INT_CST_LOW (len) >= 1
1531 && TREE_INT_CST_LOW (len)
1532 == (unsigned HOST_WIDE_INT)
1533 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1535 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1536 folded = build_fold_indirect_ref_loc (input_location, folded);
1537 if (TREE_CODE (folded) == INTEGER_CST)
1539 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1540 int length = TREE_STRING_LENGTH (string_cst);
1541 const char *ptr = TREE_STRING_POINTER (string_cst);
1543 for (; length > 0; length--)
1544 if (ptr[length - 1] != ' ')
1553 /* Compare two strings. If they are all single characters, the result is the
1554 subtraction of them. Otherwise, we build a library call. */
1557 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1558 enum tree_code code)
1564 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1565 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1567 sc1 = gfc_string_to_single_character (len1, str1, kind);
1568 sc2 = gfc_string_to_single_character (len2, str2, kind);
1570 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1572 /* Deal with single character specially. */
1573 sc1 = fold_convert (integer_type_node, sc1);
1574 sc2 = fold_convert (integer_type_node, sc2);
1575 return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1578 if ((code == EQ_EXPR || code == NE_EXPR)
1580 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1582 /* If one string is a string literal with LEN_TRIM longer
1583 than the length of the second string, the strings
1585 int len = gfc_optimize_len_trim (len1, str1, kind);
1586 if (len > 0 && compare_tree_int (len2, len) < 0)
1587 return integer_one_node;
1588 len = gfc_optimize_len_trim (len2, str2, kind);
1589 if (len > 0 && compare_tree_int (len1, len) < 0)
1590 return integer_one_node;
1593 /* Build a call for the comparison. */
1595 fndecl = gfor_fndecl_compare_string;
1597 fndecl = gfor_fndecl_compare_string_char4;
1601 return build_call_expr_loc (input_location, fndecl, 4,
1602 len1, str1, len2, str2);
1606 /* Return the backend_decl for a procedure pointer component. */
1609 get_proc_ptr_comp (gfc_expr *e)
1613 gfc_init_se (&comp_se, NULL);
1614 e2 = gfc_copy_expr (e);
1615 e2->expr_type = EXPR_VARIABLE;
1616 gfc_conv_expr (&comp_se, e2);
1618 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1623 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1627 if (gfc_is_proc_ptr_comp (expr, NULL))
1628 tmp = get_proc_ptr_comp (expr);
1629 else if (sym->attr.dummy)
1631 tmp = gfc_get_symbol_decl (sym);
1632 if (sym->attr.proc_pointer)
1633 tmp = build_fold_indirect_ref_loc (input_location,
1635 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1636 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1640 if (!sym->backend_decl)
1641 sym->backend_decl = gfc_get_extern_function_decl (sym);
1643 tmp = sym->backend_decl;
1645 if (sym->attr.cray_pointee)
1647 /* TODO - make the cray pointee a pointer to a procedure,
1648 assign the pointer to it and use it for the call. This
1650 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1651 gfc_get_symbol_decl (sym->cp_pointer));
1652 tmp = gfc_evaluate_now (tmp, &se->pre);
1655 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1657 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1658 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1665 /* Initialize MAPPING. */
1668 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1670 mapping->syms = NULL;
1671 mapping->charlens = NULL;
1675 /* Free all memory held by MAPPING (but not MAPPING itself). */
1678 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1680 gfc_interface_sym_mapping *sym;
1681 gfc_interface_sym_mapping *nextsym;
1683 gfc_charlen *nextcl;
1685 for (sym = mapping->syms; sym; sym = nextsym)
1687 nextsym = sym->next;
1688 sym->new_sym->n.sym->formal = NULL;
1689 gfc_free_symbol (sym->new_sym->n.sym);
1690 gfc_free_expr (sym->expr);
1691 gfc_free (sym->new_sym);
1694 for (cl = mapping->charlens; cl; cl = nextcl)
1697 gfc_free_expr (cl->length);
1703 /* Return a copy of gfc_charlen CL. Add the returned structure to
1704 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1706 static gfc_charlen *
1707 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1710 gfc_charlen *new_charlen;
1712 new_charlen = gfc_get_charlen ();
1713 new_charlen->next = mapping->charlens;
1714 new_charlen->length = gfc_copy_expr (cl->length);
1716 mapping->charlens = new_charlen;
1721 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1722 array variable that can be used as the actual argument for dummy
1723 argument SYM. Add any initialization code to BLOCK. PACKED is as
1724 for gfc_get_nodesc_array_type and DATA points to the first element
1725 in the passed array. */
1728 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1729 gfc_packed packed, tree data)
1734 type = gfc_typenode_for_spec (&sym->ts);
1735 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1736 !sym->attr.target && !sym->attr.pointer
1737 && !sym->attr.proc_pointer);
1739 var = gfc_create_var (type, "ifm");
1740 gfc_add_modify (block, var, fold_convert (type, data));
1746 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1747 and offset of descriptorless array type TYPE given that it has the same
1748 size as DESC. Add any set-up code to BLOCK. */
1751 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1758 offset = gfc_index_zero_node;
1759 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1761 dim = gfc_rank_cst[n];
1762 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1763 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1765 GFC_TYPE_ARRAY_LBOUND (type, n)
1766 = gfc_conv_descriptor_lbound_get (desc, dim);
1767 GFC_TYPE_ARRAY_UBOUND (type, n)
1768 = gfc_conv_descriptor_ubound_get (desc, dim);
1770 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1772 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1773 gfc_conv_descriptor_ubound_get (desc, dim),
1774 gfc_conv_descriptor_lbound_get (desc, dim));
1775 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1776 GFC_TYPE_ARRAY_LBOUND (type, n),
1778 tmp = gfc_evaluate_now (tmp, block);
1779 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1781 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1782 GFC_TYPE_ARRAY_LBOUND (type, n),
1783 GFC_TYPE_ARRAY_STRIDE (type, n));
1784 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1786 offset = gfc_evaluate_now (offset, block);
1787 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1791 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1792 in SE. The caller may still use se->expr and se->string_length after
1793 calling this function. */
1796 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1797 gfc_symbol * sym, gfc_se * se,
1800 gfc_interface_sym_mapping *sm;
1804 gfc_symbol *new_sym;
1806 gfc_symtree *new_symtree;
1808 /* Create a new symbol to represent the actual argument. */
1809 new_sym = gfc_new_symbol (sym->name, NULL);
1810 new_sym->ts = sym->ts;
1811 new_sym->as = gfc_copy_array_spec (sym->as);
1812 new_sym->attr.referenced = 1;
1813 new_sym->attr.dimension = sym->attr.dimension;
1814 new_sym->attr.contiguous = sym->attr.contiguous;
1815 new_sym->attr.codimension = sym->attr.codimension;
1816 new_sym->attr.pointer = sym->attr.pointer;
1817 new_sym->attr.allocatable = sym->attr.allocatable;
1818 new_sym->attr.flavor = sym->attr.flavor;
1819 new_sym->attr.function = sym->attr.function;
1821 /* Ensure that the interface is available and that
1822 descriptors are passed for array actual arguments. */
1823 if (sym->attr.flavor == FL_PROCEDURE)
1825 new_sym->formal = expr->symtree->n.sym->formal;
1826 new_sym->attr.always_explicit
1827 = expr->symtree->n.sym->attr.always_explicit;
1830 /* Create a fake symtree for it. */
1832 new_symtree = gfc_new_symtree (&root, sym->name);
1833 new_symtree->n.sym = new_sym;
1834 gcc_assert (new_symtree == root);
1836 /* Create a dummy->actual mapping. */
1837 sm = XCNEW (gfc_interface_sym_mapping);
1838 sm->next = mapping->syms;
1840 sm->new_sym = new_symtree;
1841 sm->expr = gfc_copy_expr (expr);
1844 /* Stabilize the argument's value. */
1845 if (!sym->attr.function && se)
1846 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1848 if (sym->ts.type == BT_CHARACTER)
1850 /* Create a copy of the dummy argument's length. */
1851 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1852 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1854 /* If the length is specified as "*", record the length that
1855 the caller is passing. We should use the callee's length
1856 in all other cases. */
1857 if (!new_sym->ts.u.cl->length && se)
1859 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1860 new_sym->ts.u.cl->backend_decl = se->string_length;
1867 /* Use the passed value as-is if the argument is a function. */
1868 if (sym->attr.flavor == FL_PROCEDURE)
1871 /* If the argument is either a string or a pointer to a string,
1872 convert it to a boundless character type. */
1873 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1875 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1876 tmp = build_pointer_type (tmp);
1877 if (sym->attr.pointer)
1878 value = build_fold_indirect_ref_loc (input_location,
1882 value = fold_convert (tmp, value);
1885 /* If the argument is a scalar, a pointer to an array or an allocatable,
1887 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1888 value = build_fold_indirect_ref_loc (input_location,
1891 /* For character(*), use the actual argument's descriptor. */
1892 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1893 value = build_fold_indirect_ref_loc (input_location,
1896 /* If the argument is an array descriptor, use it to determine
1897 information about the actual argument's shape. */
1898 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1899 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1901 /* Get the actual argument's descriptor. */
1902 desc = build_fold_indirect_ref_loc (input_location,
1905 /* Create the replacement variable. */
1906 tmp = gfc_conv_descriptor_data_get (desc);
1907 value = gfc_get_interface_mapping_array (&se->pre, sym,
1910 /* Use DESC to work out the upper bounds, strides and offset. */
1911 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1914 /* Otherwise we have a packed array. */
1915 value = gfc_get_interface_mapping_array (&se->pre, sym,
1916 PACKED_FULL, se->expr);
1918 new_sym->backend_decl = value;
1922 /* Called once all dummy argument mappings have been added to MAPPING,
1923 but before the mapping is used to evaluate expressions. Pre-evaluate
1924 the length of each argument, adding any initialization code to PRE and
1925 any finalization code to POST. */
1928 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1929 stmtblock_t * pre, stmtblock_t * post)
1931 gfc_interface_sym_mapping *sym;
1935 for (sym = mapping->syms; sym; sym = sym->next)
1936 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1937 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1939 expr = sym->new_sym->n.sym->ts.u.cl->length;
1940 gfc_apply_interface_mapping_to_expr (mapping, expr);
1941 gfc_init_se (&se, NULL);
1942 gfc_conv_expr (&se, expr);
1943 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1944 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1945 gfc_add_block_to_block (pre, &se.pre);
1946 gfc_add_block_to_block (post, &se.post);
1948 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1953 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1957 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1958 gfc_constructor_base base)
1961 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1963 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1966 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1967 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1968 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1974 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1978 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1983 for (; ref; ref = ref->next)
1987 for (n = 0; n < ref->u.ar.dimen; n++)
1989 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1990 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1991 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1993 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2000 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2001 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2007 /* Convert intrinsic function calls into result expressions. */
2010 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2018 arg1 = expr->value.function.actual->expr;
2019 if (expr->value.function.actual->next)
2020 arg2 = expr->value.function.actual->next->expr;
2024 sym = arg1->symtree->n.sym;
2026 if (sym->attr.dummy)
2031 switch (expr->value.function.isym->id)
2034 /* TODO figure out why this condition is necessary. */
2035 if (sym->attr.function
2036 && (arg1->ts.u.cl->length == NULL
2037 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2038 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2041 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2045 if (!sym->as || sym->as->rank == 0)
2048 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2050 dup = mpz_get_si (arg2->value.integer);
2055 dup = sym->as->rank;
2059 for (; d < dup; d++)
2063 if (!sym->as->upper[d] || !sym->as->lower[d])
2065 gfc_free_expr (new_expr);
2069 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2070 gfc_get_int_expr (gfc_default_integer_kind,
2072 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2074 new_expr = gfc_multiply (new_expr, tmp);
2080 case GFC_ISYM_LBOUND:
2081 case GFC_ISYM_UBOUND:
2082 /* TODO These implementations of lbound and ubound do not limit if
2083 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2085 if (!sym->as || sym->as->rank == 0)
2088 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2089 d = mpz_get_si (arg2->value.integer) - 1;
2091 /* TODO: If the need arises, this could produce an array of
2095 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2097 if (sym->as->lower[d])
2098 new_expr = gfc_copy_expr (sym->as->lower[d]);
2102 if (sym->as->upper[d])
2103 new_expr = gfc_copy_expr (sym->as->upper[d]);
2111 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2115 gfc_replace_expr (expr, new_expr);
2121 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2122 gfc_interface_mapping * mapping)
2124 gfc_formal_arglist *f;
2125 gfc_actual_arglist *actual;
2127 actual = expr->value.function.actual;
2128 f = map_expr->symtree->n.sym->formal;
2130 for (; f && actual; f = f->next, actual = actual->next)
2135 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2138 if (map_expr->symtree->n.sym->attr.dimension)
2143 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2145 for (d = 0; d < as->rank; d++)
2147 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2148 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2151 expr->value.function.esym->as = as;
2154 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2156 expr->value.function.esym->ts.u.cl->length
2157 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2159 gfc_apply_interface_mapping_to_expr (mapping,
2160 expr->value.function.esym->ts.u.cl->length);
2165 /* EXPR is a copy of an expression that appeared in the interface
2166 associated with MAPPING. Walk it recursively looking for references to
2167 dummy arguments that MAPPING maps to actual arguments. Replace each such
2168 reference with a reference to the associated actual argument. */
2171 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2174 gfc_interface_sym_mapping *sym;
2175 gfc_actual_arglist *actual;
2180 /* Copying an expression does not copy its length, so do that here. */
2181 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2183 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2184 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2187 /* Apply the mapping to any references. */
2188 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2190 /* ...and to the expression's symbol, if it has one. */
2191 /* TODO Find out why the condition on expr->symtree had to be moved into
2192 the loop rather than being outside it, as originally. */
2193 for (sym = mapping->syms; sym; sym = sym->next)
2194 if (expr->symtree && sym->old == expr->symtree->n.sym)
2196 if (sym->new_sym->n.sym->backend_decl)
2197 expr->symtree = sym->new_sym;
2199 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2202 /* ...and to subexpressions in expr->value. */
2203 switch (expr->expr_type)
2208 case EXPR_SUBSTRING:
2212 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2213 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2217 for (actual = expr->value.function.actual; actual; actual = actual->next)
2218 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2220 if (expr->value.function.esym == NULL
2221 && expr->value.function.isym != NULL
2222 && expr->value.function.actual->expr->symtree
2223 && gfc_map_intrinsic_function (expr, mapping))
2226 for (sym = mapping->syms; sym; sym = sym->next)
2227 if (sym->old == expr->value.function.esym)
2229 expr->value.function.esym = sym->new_sym->n.sym;
2230 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2231 expr->value.function.esym->result = sym->new_sym->n.sym;
2236 case EXPR_STRUCTURE:
2237 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2250 /* Evaluate interface expression EXPR using MAPPING. Store the result
2254 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2255 gfc_se * se, gfc_expr * expr)
2257 expr = gfc_copy_expr (expr);
2258 gfc_apply_interface_mapping_to_expr (mapping, expr);
2259 gfc_conv_expr (se, expr);
2260 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2261 gfc_free_expr (expr);
2265 /* Returns a reference to a temporary array into which a component of
2266 an actual argument derived type array is copied and then returned
2267 after the function call. */
2269 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2270 sym_intent intent, bool formal_ptr)
2288 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2290 gfc_init_se (&lse, NULL);
2291 gfc_init_se (&rse, NULL);
2293 /* Walk the argument expression. */
2294 rss = gfc_walk_expr (expr);
2296 gcc_assert (rss != gfc_ss_terminator);
2298 /* Initialize the scalarizer. */
2299 gfc_init_loopinfo (&loop);
2300 gfc_add_ss_to_loop (&loop, rss);
2302 /* Calculate the bounds of the scalarization. */
2303 gfc_conv_ss_startstride (&loop);
2305 /* Build an ss for the temporary. */
2306 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2307 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2309 base_type = gfc_typenode_for_spec (&expr->ts);
2310 if (GFC_ARRAY_TYPE_P (base_type)
2311 || GFC_DESCRIPTOR_TYPE_P (base_type))
2312 base_type = gfc_get_element_type (base_type);
2314 loop.temp_ss = gfc_get_ss ();;
2315 loop.temp_ss->type = GFC_SS_TEMP;
2316 loop.temp_ss->data.temp.type = base_type;
2318 if (expr->ts.type == BT_CHARACTER)
2319 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2321 loop.temp_ss->string_length = NULL;
2323 parmse->string_length = loop.temp_ss->string_length;
2324 loop.temp_ss->data.temp.dimen = loop.dimen;
2325 loop.temp_ss->next = gfc_ss_terminator;
2327 /* Associate the SS with the loop. */
2328 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2330 /* Setup the scalarizing loops. */
2331 gfc_conv_loop_setup (&loop, &expr->where);
2333 /* Pass the temporary descriptor back to the caller. */
2334 info = &loop.temp_ss->data.info;
2335 parmse->expr = info->descriptor;
2337 /* Setup the gfc_se structures. */
2338 gfc_copy_loopinfo_to_se (&lse, &loop);
2339 gfc_copy_loopinfo_to_se (&rse, &loop);
2342 lse.ss = loop.temp_ss;
2343 gfc_mark_ss_chain_used (rss, 1);
2344 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2346 /* Start the scalarized loop body. */
2347 gfc_start_scalarized_body (&loop, &body);
2349 /* Translate the expression. */
2350 gfc_conv_expr (&rse, expr);
2352 gfc_conv_tmp_array_ref (&lse);
2353 gfc_advance_se_ss_chain (&lse);
2355 if (intent != INTENT_OUT)
2357 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2358 gfc_add_expr_to_block (&body, tmp);
2359 gcc_assert (rse.ss == gfc_ss_terminator);
2360 gfc_trans_scalarizing_loops (&loop, &body);
2364 /* Make sure that the temporary declaration survives by merging
2365 all the loop declarations into the current context. */
2366 for (n = 0; n < loop.dimen; n++)
2368 gfc_merge_block_scope (&body);
2369 body = loop.code[loop.order[n]];
2371 gfc_merge_block_scope (&body);
2374 /* Add the post block after the second loop, so that any
2375 freeing of allocated memory is done at the right time. */
2376 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2378 /**********Copy the temporary back again.*********/
2380 gfc_init_se (&lse, NULL);
2381 gfc_init_se (&rse, NULL);
2383 /* Walk the argument expression. */
2384 lss = gfc_walk_expr (expr);
2385 rse.ss = loop.temp_ss;
2388 /* Initialize the scalarizer. */
2389 gfc_init_loopinfo (&loop2);
2390 gfc_add_ss_to_loop (&loop2, lss);
2392 /* Calculate the bounds of the scalarization. */
2393 gfc_conv_ss_startstride (&loop2);
2395 /* Setup the scalarizing loops. */
2396 gfc_conv_loop_setup (&loop2, &expr->where);
2398 gfc_copy_loopinfo_to_se (&lse, &loop2);
2399 gfc_copy_loopinfo_to_se (&rse, &loop2);
2401 gfc_mark_ss_chain_used (lss, 1);
2402 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2404 /* Declare the variable to hold the temporary offset and start the
2405 scalarized loop body. */
2406 offset = gfc_create_var (gfc_array_index_type, NULL);
2407 gfc_start_scalarized_body (&loop2, &body);
2409 /* Build the offsets for the temporary from the loop variables. The
2410 temporary array has lbounds of zero and strides of one in all
2411 dimensions, so this is very simple. The offset is only computed
2412 outside the innermost loop, so the overall transfer could be
2413 optimized further. */
2414 info = &rse.ss->data.info;
2415 dimen = info->dimen;
2417 tmp_index = gfc_index_zero_node;
2418 for (n = dimen - 1; n > 0; n--)
2421 tmp = rse.loop->loopvar[n];
2422 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2423 tmp, rse.loop->from[n]);
2424 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2427 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2428 rse.loop->to[n-1], rse.loop->from[n-1]);
2429 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2430 tmp_str, gfc_index_one_node);
2432 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2436 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2437 tmp_index, rse.loop->from[0]);
2438 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2440 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2441 rse.loop->loopvar[0], offset);
2443 /* Now use the offset for the reference. */
2444 tmp = build_fold_indirect_ref_loc (input_location,
2446 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2448 if (expr->ts.type == BT_CHARACTER)
2449 rse.string_length = expr->ts.u.cl->backend_decl;
2451 gfc_conv_expr (&lse, expr);
2453 gcc_assert (lse.ss == gfc_ss_terminator);
2455 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2456 gfc_add_expr_to_block (&body, tmp);
2458 /* Generate the copying loops. */
2459 gfc_trans_scalarizing_loops (&loop2, &body);
2461 /* Wrap the whole thing up by adding the second loop to the post-block
2462 and following it by the post-block of the first loop. In this way,
2463 if the temporary needs freeing, it is done after use! */
2464 if (intent != INTENT_IN)
2466 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2467 gfc_add_block_to_block (&parmse->post, &loop2.post);
2470 gfc_add_block_to_block (&parmse->post, &loop.post);
2472 gfc_cleanup_loop (&loop);
2473 gfc_cleanup_loop (&loop2);
2475 /* Pass the string length to the argument expression. */
2476 if (expr->ts.type == BT_CHARACTER)
2477 parmse->string_length = expr->ts.u.cl->backend_decl;
2479 /* Determine the offset for pointer formal arguments and set the
2483 size = gfc_index_one_node;
2484 offset = gfc_index_zero_node;
2485 for (n = 0; n < dimen; n++)
2487 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2489 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2490 tmp, gfc_index_one_node);
2491 gfc_conv_descriptor_ubound_set (&parmse->pre,
2495 gfc_conv_descriptor_lbound_set (&parmse->pre,
2498 gfc_index_one_node);
2499 size = gfc_evaluate_now (size, &parmse->pre);
2500 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2502 offset = gfc_evaluate_now (offset, &parmse->pre);
2503 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2504 rse.loop->to[n], rse.loop->from[n]);
2505 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2506 tmp, gfc_index_one_node);
2507 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2511 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2515 /* We want either the address for the data or the address of the descriptor,
2516 depending on the mode of passing array arguments. */
2518 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2520 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2526 /* Generate the code for argument list functions. */
2529 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2531 /* Pass by value for g77 %VAL(arg), pass the address
2532 indirectly for %LOC, else by reference. Thus %REF
2533 is a "do-nothing" and %LOC is the same as an F95
2535 if (strncmp (name, "%VAL", 4) == 0)
2536 gfc_conv_expr (se, expr);
2537 else if (strncmp (name, "%LOC", 4) == 0)
2539 gfc_conv_expr_reference (se, expr);
2540 se->expr = gfc_build_addr_expr (NULL, se->expr);
2542 else if (strncmp (name, "%REF", 4) == 0)
2543 gfc_conv_expr_reference (se, expr);
2545 gfc_error ("Unknown argument list function at %L", &expr->where);
2549 /* Takes a derived type expression and returns the address of a temporary
2550 class object of the 'declared' type. */
2552 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2553 gfc_typespec class_ts)
2557 gfc_symbol *declared = class_ts.u.derived;
2563 /* The derived type needs to be converted to a temporary
2565 tmp = gfc_typenode_for_spec (&class_ts);
2566 var = gfc_create_var (tmp, "class");
2569 cmp = gfc_find_component (declared, "$vptr", true, true);
2570 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2571 var, cmp->backend_decl, NULL_TREE);
2573 /* Remember the vtab corresponds to the derived type
2574 not to the class declared type. */
2575 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2577 gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
2578 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2579 gfc_add_modify (&parmse->pre, ctree,
2580 fold_convert (TREE_TYPE (ctree), tmp));
2582 /* Now set the data field. */
2583 cmp = gfc_find_component (declared, "$data", true, true);
2584 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2585 var, cmp->backend_decl, NULL_TREE);
2586 ss = gfc_walk_expr (e);
2587 if (ss == gfc_ss_terminator)
2590 gfc_conv_expr_reference (parmse, e);
2591 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2592 gfc_add_modify (&parmse->pre, ctree, tmp);
2597 gfc_conv_expr (parmse, e);
2598 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2601 /* Pass the address of the class object. */
2602 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2606 /* The following routine generates code for the intrinsic
2607 procedures from the ISO_C_BINDING module:
2609 * C_FUNLOC (function)
2610 * C_F_POINTER (subroutine)
2611 * C_F_PROCPOINTER (subroutine)
2612 * C_ASSOCIATED (function)
2613 One exception which is not handled here is C_F_POINTER with non-scalar
2614 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2617 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2618 gfc_actual_arglist * arg)
2623 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2625 if (arg->expr->rank == 0)
2626 gfc_conv_expr_reference (se, arg->expr);
2630 /* This is really the actual arg because no formal arglist is
2631 created for C_LOC. */
2632 fsym = arg->expr->symtree->n.sym;
2634 /* We should want it to do g77 calling convention. */
2636 && !(fsym->attr.pointer || fsym->attr.allocatable)
2637 && fsym->as->type != AS_ASSUMED_SHAPE;
2638 f = f || !sym->attr.always_explicit;
2640 argss = gfc_walk_expr (arg->expr);
2641 gfc_conv_array_parameter (se, arg->expr, argss, f,
2645 /* TODO -- the following two lines shouldn't be necessary, but if
2646 they're removed, a bug is exposed later in the code path.
2647 This workaround was thus introduced, but will have to be
2648 removed; please see PR 35150 for details about the issue. */
2649 se->expr = convert (pvoid_type_node, se->expr);
2650 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2654 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2656 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2657 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2658 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2659 gfc_conv_expr_reference (se, arg->expr);
2663 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2664 && arg->next->expr->rank == 0)
2665 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2667 /* Convert c_f_pointer if fptr is a scalar
2668 and convert c_f_procpointer. */
2672 gfc_init_se (&cptrse, NULL);
2673 gfc_conv_expr (&cptrse, arg->expr);
2674 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2675 gfc_add_block_to_block (&se->post, &cptrse.post);
2677 gfc_init_se (&fptrse, NULL);
2678 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2679 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2680 fptrse.want_pointer = 1;
2682 gfc_conv_expr (&fptrse, arg->next->expr);
2683 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2684 gfc_add_block_to_block (&se->post, &fptrse.post);
2686 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2687 && arg->next->expr->symtree->n.sym->attr.dummy)
2688 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2691 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2693 fold_convert (TREE_TYPE (fptrse.expr),
2698 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2703 /* Build the addr_expr for the first argument. The argument is
2704 already an *address* so we don't need to set want_pointer in
2706 gfc_init_se (&arg1se, NULL);
2707 gfc_conv_expr (&arg1se, arg->expr);
2708 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2709 gfc_add_block_to_block (&se->post, &arg1se.post);
2711 /* See if we were given two arguments. */
2712 if (arg->next == NULL)
2713 /* Only given one arg so generate a null and do a
2714 not-equal comparison against the first arg. */
2715 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2716 fold_convert (TREE_TYPE (arg1se.expr),
2717 null_pointer_node));
2723 /* Given two arguments so build the arg2se from second arg. */
2724 gfc_init_se (&arg2se, NULL);
2725 gfc_conv_expr (&arg2se, arg->next->expr);
2726 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2727 gfc_add_block_to_block (&se->post, &arg2se.post);
2729 /* Generate test to compare that the two args are equal. */
2730 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2731 arg1se.expr, arg2se.expr);
2732 /* Generate test to ensure that the first arg is not null. */
2733 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2734 arg1se.expr, null_pointer_node);
2736 /* Finally, the generated test must check that both arg1 is not
2737 NULL and that it is equal to the second arg. */
2738 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2739 not_null_expr, eq_expr);
2745 /* Nothing was done. */
2749 /* Generate code for a procedure call. Note can return se->post != NULL.
2750 If se->direct_byref is set then se->expr contains the return parameter.
2751 Return nonzero, if the call has alternate specifiers.
2752 'expr' is only needed for procedure pointer components. */
2755 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2756 gfc_actual_arglist * arg, gfc_expr * expr,
2757 VEC(tree,gc) *append_args)
2759 gfc_interface_mapping mapping;
2760 VEC(tree,gc) *arglist;
2761 VEC(tree,gc) *retargs;
2772 VEC(tree,gc) *stringargs;
2774 gfc_formal_arglist *formal;
2775 int has_alternate_specifier = 0;
2776 bool need_interface_mapping;
2783 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2784 gfc_component *comp = NULL;
2794 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2795 && conv_isocbinding_procedure (se, sym, arg))
2798 gfc_is_proc_ptr_comp (expr, &comp);
2802 if (!sym->attr.elemental)
2804 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2805 if (se->ss->useflags)
2807 gcc_assert ((!comp && gfc_return_by_reference (sym)
2808 && sym->result->attr.dimension)
2809 || (comp && comp->attr.dimension));
2810 gcc_assert (se->loop != NULL);
2812 /* Access the previously obtained result. */
2813 gfc_conv_tmp_array_ref (se);
2814 gfc_advance_se_ss_chain (se);
2818 info = &se->ss->data.info;
2823 gfc_init_block (&post);
2824 gfc_init_interface_mapping (&mapping);
2827 formal = sym->formal;
2828 need_interface_mapping = sym->attr.dimension ||
2829 (sym->ts.type == BT_CHARACTER
2830 && sym->ts.u.cl->length
2831 && sym->ts.u.cl->length->expr_type
2836 formal = comp->formal;
2837 need_interface_mapping = comp->attr.dimension ||
2838 (comp->ts.type == BT_CHARACTER
2839 && comp->ts.u.cl->length
2840 && comp->ts.u.cl->length->expr_type
2844 /* Evaluate the arguments. */
2845 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2848 fsym = formal ? formal->sym : NULL;
2849 parm_kind = MISSING;
2853 if (se->ignore_optional)
2855 /* Some intrinsics have already been resolved to the correct
2859 else if (arg->label)
2861 has_alternate_specifier = 1;
2866 /* Pass a NULL pointer for an absent arg. */
2867 gfc_init_se (&parmse, NULL);
2868 parmse.expr = null_pointer_node;
2869 if (arg->missing_arg_type == BT_CHARACTER)
2870 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2873 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2875 /* Pass a NULL pointer to denote an absent arg. */
2876 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2877 gfc_init_se (&parmse, NULL);
2878 parmse.expr = null_pointer_node;
2879 if (arg->missing_arg_type == BT_CHARACTER)
2880 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2882 else if (fsym && fsym->ts.type == BT_CLASS
2883 && e->ts.type == BT_DERIVED)
2885 /* The derived type needs to be converted to a temporary
2887 gfc_init_se (&parmse, se);
2888 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2890 else if (se->ss && se->ss->useflags)
2892 /* An elemental function inside a scalarized loop. */
2893 gfc_init_se (&parmse, se);
2894 gfc_conv_expr_reference (&parmse, e);
2895 parm_kind = ELEMENTAL;
2899 /* A scalar or transformational function. */
2900 gfc_init_se (&parmse, NULL);
2901 argss = gfc_walk_expr (e);
2903 if (argss == gfc_ss_terminator)
2905 if (e->expr_type == EXPR_VARIABLE
2906 && e->symtree->n.sym->attr.cray_pointee
2907 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2909 /* The Cray pointer needs to be converted to a pointer to
2910 a type given by the expression. */
2911 gfc_conv_expr (&parmse, e);
2912 type = build_pointer_type (TREE_TYPE (parmse.expr));
2913 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2914 parmse.expr = convert (type, tmp);
2916 else if (fsym && fsym->attr.value)
2918 if (fsym->ts.type == BT_CHARACTER
2919 && fsym->ts.is_c_interop
2920 && fsym->ns->proc_name != NULL
2921 && fsym->ns->proc_name->attr.is_bind_c)
2924 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2925 if (parmse.expr == NULL)
2926 gfc_conv_expr (&parmse, e);
2929 gfc_conv_expr (&parmse, e);
2931 else if (arg->name && arg->name[0] == '%')
2932 /* Argument list functions %VAL, %LOC and %REF are signalled
2933 through arg->name. */
2934 conv_arglist_function (&parmse, arg->expr, arg->name);
2935 else if ((e->expr_type == EXPR_FUNCTION)
2936 && ((e->value.function.esym
2937 && e->value.function.esym->result->attr.pointer)
2938 || (!e->value.function.esym
2939 && e->symtree->n.sym->attr.pointer))
2940 && fsym && fsym->attr.target)
2942 gfc_conv_expr (&parmse, e);
2943 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2945 else if (e->expr_type == EXPR_FUNCTION
2946 && e->symtree->n.sym->result
2947 && e->symtree->n.sym->result != e->symtree->n.sym
2948 && e->symtree->n.sym->result->attr.proc_pointer)
2950 /* Functions returning procedure pointers. */
2951 gfc_conv_expr (&parmse, e);
2952 if (fsym && fsym->attr.proc_pointer)
2953 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2957 gfc_conv_expr_reference (&parmse, e);
2959 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2960 allocated on entry, it must be deallocated. */
2961 if (fsym && fsym->attr.allocatable
2962 && fsym->attr.intent == INTENT_OUT)
2966 gfc_init_block (&block);
2967 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2969 gfc_add_expr_to_block (&block, tmp);
2970 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2971 parmse.expr, null_pointer_node);
2972 gfc_add_expr_to_block (&block, tmp);
2974 if (fsym->attr.optional
2975 && e->expr_type == EXPR_VARIABLE
2976 && e->symtree->n.sym->attr.optional)
2978 tmp = fold_build3 (COND_EXPR, void_type_node,
2979 gfc_conv_expr_present (e->symtree->n.sym),
2980 gfc_finish_block (&block),
2981 build_empty_stmt (input_location));
2984 tmp = gfc_finish_block (&block);
2986 gfc_add_expr_to_block (&se->pre, tmp);
2989 if (fsym && e->expr_type != EXPR_NULL
2990 && ((fsym->attr.pointer
2991 && fsym->attr.flavor != FL_PROCEDURE)
2992 || (fsym->attr.proc_pointer
2993 && !(e->expr_type == EXPR_VARIABLE
2994 && e->symtree->n.sym->attr.dummy))
2995 || (e->expr_type == EXPR_VARIABLE
2996 && gfc_is_proc_ptr_comp (e, NULL))
2997 || fsym->attr.allocatable))
2999 /* Scalar pointer dummy args require an extra level of
3000 indirection. The null pointer already contains
3001 this level of indirection. */
3002 parm_kind = SCALAR_POINTER;
3003 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3009 /* If the procedure requires an explicit interface, the actual
3010 argument is passed according to the corresponding formal
3011 argument. If the corresponding formal argument is a POINTER,
3012 ALLOCATABLE or assumed shape, we do not use g77's calling
3013 convention, and pass the address of the array descriptor
3014 instead. Otherwise we use g77's calling convention. */
3017 && !(fsym->attr.pointer || fsym->attr.allocatable)
3018 && fsym->as->type != AS_ASSUMED_SHAPE;
3020 f = f || !comp->attr.always_explicit;
3022 f = f || !sym->attr.always_explicit;
3024 if (e->expr_type == EXPR_VARIABLE
3025 && is_subref_array (e))
3026 /* The actual argument is a component reference to an
3027 array of derived types. In this case, the argument
3028 is converted to a temporary, which is passed and then
3029 written back after the procedure call. */
3030 gfc_conv_subref_array_arg (&parmse, e, f,
3031 fsym ? fsym->attr.intent : INTENT_INOUT,
3032 fsym && fsym->attr.pointer);
3034 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3037 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3038 allocated on entry, it must be deallocated. */
3039 if (fsym && fsym->attr.allocatable
3040 && fsym->attr.intent == INTENT_OUT)
3042 tmp = build_fold_indirect_ref_loc (input_location,
3044 tmp = gfc_trans_dealloc_allocated (tmp);
3045 if (fsym->attr.optional
3046 && e->expr_type == EXPR_VARIABLE
3047 && e->symtree->n.sym->attr.optional)
3048 tmp = fold_build3 (COND_EXPR, void_type_node,
3049 gfc_conv_expr_present (e->symtree->n.sym),
3050 tmp, build_empty_stmt (input_location));
3051 gfc_add_expr_to_block (&se->pre, tmp);
3056 /* The case with fsym->attr.optional is that of a user subroutine
3057 with an interface indicating an optional argument. When we call
3058 an intrinsic subroutine, however, fsym is NULL, but we might still
3059 have an optional argument, so we proceed to the substitution
3061 if (e && (fsym == NULL || fsym->attr.optional))
3063 /* If an optional argument is itself an optional dummy argument,
3064 check its presence and substitute a null if absent. This is
3065 only needed when passing an array to an elemental procedure
3066 as then array elements are accessed - or no NULL pointer is
3067 allowed and a "1" or "0" should be passed if not present.
3068 When passing a non-array-descriptor full array to a
3069 non-array-descriptor dummy, no check is needed. For
3070 array-descriptor actual to array-descriptor dummy, see
3071 PR 41911 for why a check has to be inserted.
3072 fsym == NULL is checked as intrinsics required the descriptor
3073 but do not always set fsym. */
3074 if (e->expr_type == EXPR_VARIABLE
3075 && e->symtree->n.sym->attr.optional
3076 && ((e->rank > 0 && sym->attr.elemental)
3077 || e->representation.length || e->ts.type == BT_CHARACTER
3079 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3080 || fsym->as->type == AS_DEFERRED))))
3081 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3082 e->representation.length);
3087 /* Obtain the character length of an assumed character length
3088 length procedure from the typespec. */
3089 if (fsym->ts.type == BT_CHARACTER
3090 && parmse.string_length == NULL_TREE
3091 && e->ts.type == BT_PROCEDURE
3092 && e->symtree->n.sym->ts.type == BT_CHARACTER
3093 && e->symtree->n.sym->ts.u.cl->length != NULL
3094 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3096 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3097 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3101 if (fsym && need_interface_mapping && e)
3102 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3104 gfc_add_block_to_block (&se->pre, &parmse.pre);
3105 gfc_add_block_to_block (&post, &parmse.post);
3107 /* Allocated allocatable components of derived types must be
3108 deallocated for non-variable scalars. Non-variable arrays are
3109 dealt with in trans-array.c(gfc_conv_array_parameter). */
3110 if (e && e->ts.type == BT_DERIVED
3111 && e->ts.u.derived->attr.alloc_comp
3112 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3113 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3116 tmp = build_fold_indirect_ref_loc (input_location,
3118 parm_rank = e->rank;
3126 case (SCALAR_POINTER):
3127 tmp = build_fold_indirect_ref_loc (input_location,
3132 if (e->expr_type == EXPR_OP
3133 && e->value.op.op == INTRINSIC_PARENTHESES
3134 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3137 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3138 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3139 gfc_add_expr_to_block (&se->post, local_tmp);
3142 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3144 gfc_add_expr_to_block (&se->post, tmp);
3147 /* Add argument checking of passing an unallocated/NULL actual to
3148 a nonallocatable/nonpointer dummy. */
3150 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3152 symbol_attribute *attr;
3156 if (e->expr_type == EXPR_VARIABLE)
3157 attr = &e->symtree->n.sym->attr;
3158 else if (e->expr_type == EXPR_FUNCTION)
3160 /* For intrinsic functions, the gfc_attr are not available. */
3161 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3162 goto end_pointer_check;
3164 if (e->symtree->n.sym->attr.generic)
3165 attr = &e->value.function.esym->attr;
3167 attr = &e->symtree->n.sym->result->attr;
3170 goto end_pointer_check;
3174 /* If the actual argument is an optional pointer/allocatable and
3175 the formal argument takes an nonpointer optional value,
3176 it is invalid to pass a non-present argument on, even
3177 though there is no technical reason for this in gfortran.
3178 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3179 tree present, null_ptr, type;
3181 if (attr->allocatable
3182 && (fsym == NULL || !fsym->attr.allocatable))
3183 asprintf (&msg, "Allocatable actual argument '%s' is not "
3184 "allocated or not present", e->symtree->n.sym->name);
3185 else if (attr->pointer
3186 && (fsym == NULL || !fsym->attr.pointer))
3187 asprintf (&msg, "Pointer actual argument '%s' is not "
3188 "associated or not present",
3189 e->symtree->n.sym->name);
3190 else if (attr->proc_pointer
3191 && (fsym == NULL || !fsym->attr.proc_pointer))
3192 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3193 "associated or not present",
3194 e->symtree->n.sym->name);
3196 goto end_pointer_check;
3198 present = gfc_conv_expr_present (e->symtree->n.sym);
3199 type = TREE_TYPE (present);
3200 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3201 fold_convert (type, null_pointer_node));
3202 type = TREE_TYPE (parmse.expr);
3203 null_ptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3204 fold_convert (type, null_pointer_node));
3205 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3210 if (attr->allocatable
3211 && (fsym == NULL || !fsym->attr.allocatable))
3212 asprintf (&msg, "Allocatable actual argument '%s' is not "
3213 "allocated", e->symtree->n.sym->name);
3214 else if (attr->pointer
3215 && (fsym == NULL || !fsym->attr.pointer))
3216 asprintf (&msg, "Pointer actual argument '%s' is not "
3217 "associated", e->symtree->n.sym->name);
3218 else if (attr->proc_pointer
3219 && (fsym == NULL || !fsym->attr.proc_pointer))
3220 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3221 "associated", e->symtree->n.sym->name);
3223 goto end_pointer_check;
3226 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3227 fold_convert (TREE_TYPE (parmse.expr),
3228 null_pointer_node));
3231 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3238 /* Character strings are passed as two parameters, a length and a
3239 pointer - except for Bind(c) which only passes the pointer. */
3240 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3241 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3243 VEC_safe_push (tree, gc, arglist, parmse.expr);
3245 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3252 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3253 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3254 else if (ts.type == BT_CHARACTER)
3256 if (ts.u.cl->length == NULL)
3258 /* Assumed character length results are not allowed by 5.1.1.5 of the
3259 standard and are trapped in resolve.c; except in the case of SPREAD
3260 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3261 we take the character length of the first argument for the result.
3262 For dummies, we have to look through the formal argument list for
3263 this function and use the character length found there.*/
3264 if (!sym->attr.dummy)
3265 cl.backend_decl = VEC_index (tree, stringargs, 0);
3268 formal = sym->ns->proc_name->formal;
3269 for (; formal; formal = formal->next)
3270 if (strcmp (formal->sym->name, sym->name) == 0)
3271 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3278 /* Calculate the length of the returned string. */
3279 gfc_init_se (&parmse, NULL);
3280 if (need_interface_mapping)
3281 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3283 gfc_conv_expr (&parmse, ts.u.cl->length);
3284 gfc_add_block_to_block (&se->pre, &parmse.pre);
3285 gfc_add_block_to_block (&se->post, &parmse.post);
3287 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3288 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3289 build_int_cst (gfc_charlen_type_node, 0));
3290 cl.backend_decl = tmp;
3293 /* Set up a charlen structure for it. */
3298 len = cl.backend_decl;
3301 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3302 || (!comp && gfc_return_by_reference (sym));
3305 if (se->direct_byref)
3307 /* Sometimes, too much indirection can be applied; e.g. for
3308 function_result = array_valued_recursive_function. */
3309 if (TREE_TYPE (TREE_TYPE (se->expr))
3310 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3311 && GFC_DESCRIPTOR_TYPE_P
3312 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3313 se->expr = build_fold_indirect_ref_loc (input_location,
3316 result = build_fold_indirect_ref_loc (input_location,
3318 VEC_safe_push (tree, gc, retargs, se->expr);
3320 else if (comp && comp->attr.dimension)
3322 gcc_assert (se->loop && info);
3324 /* Set the type of the array. */
3325 tmp = gfc_typenode_for_spec (&comp->ts);
3326 info->dimen = se->loop->dimen;
3328 /* Evaluate the bounds of the result, if known. */
3329 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3331 /* Create a temporary to store the result. In case the function
3332 returns a pointer, the temporary will be a shallow copy and
3333 mustn't be deallocated. */
3334 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3335 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3336 NULL_TREE, false, !comp->attr.pointer,
3337 callee_alloc, &se->ss->expr->where);
3339 /* Pass the temporary as the first argument. */
3340 result = info->descriptor;
3341 tmp = gfc_build_addr_expr (NULL_TREE, result);
3342 VEC_safe_push (tree, gc, retargs, tmp);
3344 else if (!comp && sym->result->attr.dimension)
3346 gcc_assert (se->loop && info);
3348 /* Set the type of the array. */
3349 tmp = gfc_typenode_for_spec (&ts);
3350 info->dimen = se->loop->dimen;
3352 /* Evaluate the bounds of the result, if known. */
3353 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3355 /* Create a temporary to store the result. In case the function
3356 returns a pointer, the temporary will be a shallow copy and
3357 mustn't be deallocated. */
3358 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3359 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3360 NULL_TREE, false, !sym->attr.pointer,
3361 callee_alloc, &se->ss->expr->where);
3363 /* Pass the temporary as the first argument. */
3364 result = info->descriptor;
3365 tmp = gfc_build_addr_expr (NULL_TREE, result);
3366 VEC_safe_push (tree, gc, retargs, tmp);
3368 else if (ts.type == BT_CHARACTER)
3370 /* Pass the string length. */
3371 type = gfc_get_character_type (ts.kind, ts.u.cl);
3372 type = build_pointer_type (type);
3374 /* Return an address to a char[0:len-1]* temporary for
3375 character pointers. */
3376 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3377 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3379 var = gfc_create_var (type, "pstr");
3381 if ((!comp && sym->attr.allocatable)
3382 || (comp && comp->attr.allocatable))
3383 gfc_add_modify (&se->pre, var,
3384 fold_convert (TREE_TYPE (var),
3385 null_pointer_node));
3387 /* Provide an address expression for the function arguments. */
3388 var = gfc_build_addr_expr (NULL_TREE, var);
3391 var = gfc_conv_string_tmp (se, type, len);
3393 VEC_safe_push (tree, gc, retargs, var);
3397 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3399 type = gfc_get_complex_type (ts.kind);
3400 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3401 VEC_safe_push (tree, gc, retargs, var);
3404 /* Add the string length to the argument list. */
3405 if (ts.type == BT_CHARACTER)
3406 VEC_safe_push (tree, gc, retargs, len);
3408 gfc_free_interface_mapping (&mapping);
3410 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3411 arglen = (VEC_length (tree, arglist)
3412 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3413 VEC_reserve_exact (tree, gc, retargs, arglen);
3415 /* Add the return arguments. */
3416 VEC_splice (tree, retargs, arglist);
3418 /* Add the hidden string length parameters to the arguments. */
3419 VEC_splice (tree, retargs, stringargs);
3421 /* We may want to append extra arguments here. This is used e.g. for
3422 calls to libgfortran_matmul_??, which need extra information. */
3423 if (!VEC_empty (tree, append_args))
3424 VEC_splice (tree, retargs, append_args);
3427 /* Generate the actual call. */
3428 conv_function_val (se, sym, expr);
3430 /* If there are alternate return labels, function type should be
3431 integer. Can't modify the type in place though, since it can be shared
3432 with other functions. For dummy arguments, the typing is done to
3433 to this result, even if it has to be repeated for each call. */
3434 if (has_alternate_specifier
3435 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3437 if (!sym->attr.dummy)
3439 TREE_TYPE (sym->backend_decl)
3440 = build_function_type (integer_type_node,
3441 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3442 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3445 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3448 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3449 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3451 /* If we have a pointer function, but we don't want a pointer, e.g.
3454 where f is pointer valued, we have to dereference the result. */
3455 if (!se->want_pointer && !byref
3456 && (sym->attr.pointer || sym->attr.allocatable)
3457 && !gfc_is_proc_ptr_comp (expr, NULL))
3458 se->expr = build_fold_indirect_ref_loc (input_location,
3461 /* f2c calling conventions require a scalar default real function to
3462 return a double precision result. Convert this back to default
3463 real. We only care about the cases that can happen in Fortran 77.
3465 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3466 && sym->ts.kind == gfc_default_real_kind
3467 && !sym->attr.always_explicit)
3468 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3470 /* A pure function may still have side-effects - it may modify its
3472 TREE_SIDE_EFFECTS (se->expr) = 1;
3474 if (!sym->attr.pure)
3475 TREE_SIDE_EFFECTS (se->expr) = 1;
3480 /* Add the function call to the pre chain. There is no expression. */
3481 gfc_add_expr_to_block (&se->pre, se->expr);
3482 se->expr = NULL_TREE;
3484 if (!se->direct_byref)
3486 if (sym->attr.dimension || (comp && comp->attr.dimension))
3488 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3490 /* Check the data pointer hasn't been modified. This would
3491 happen in a function returning a pointer. */
3492 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3493 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3495 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3498 se->expr = info->descriptor;
3499 /* Bundle in the string length. */
3500 se->string_length = len;
3502 else if (ts.type == BT_CHARACTER)
3504 /* Dereference for character pointer results. */
3505 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3506 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3507 se->expr = build_fold_indirect_ref_loc (input_location, var);
3511 se->string_length = len;
3515 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3516 se->expr = build_fold_indirect_ref_loc (input_location, var);
3521 /* Follow the function call with the argument post block. */
3524 gfc_add_block_to_block (&se->pre, &post);
3526 /* Transformational functions of derived types with allocatable
3527 components must have the result allocatable components copied. */
3528 arg = expr->value.function.actual;
3529 if (result && arg && expr->rank
3530 && expr->value.function.isym
3531 && expr->value.function.isym->transformational
3532 && arg->expr->ts.type == BT_DERIVED
3533 && arg->expr->ts.u.derived->attr.alloc_comp)
3536 /* Copy the allocatable components. We have to use a
3537 temporary here to prevent source allocatable components
3538 from being corrupted. */
3539 tmp2 = gfc_evaluate_now (result, &se->pre);
3540 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3541 result, tmp2, expr->rank);
3542 gfc_add_expr_to_block (&se->pre, tmp);
3543 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3545 gfc_add_expr_to_block (&se->pre, tmp);
3547 /* Finally free the temporary's data field. */
3548 tmp = gfc_conv_descriptor_data_get (tmp2);
3549 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3550 gfc_add_expr_to_block (&se->pre, tmp);
3554 gfc_add_block_to_block (&se->post, &post);
3556 return has_alternate_specifier;
3560 /* Fill a character string with spaces. */
3563 fill_with_spaces (tree start, tree type, tree size)
3565 stmtblock_t block, loop;
3566 tree i, el, exit_label, cond, tmp;
3568 /* For a simple char type, we can call memset(). */
3569 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3570 return build_call_expr_loc (input_location,
3571 built_in_decls[BUILT_IN_MEMSET], 3, start,
3572 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3573 lang_hooks.to_target_charset (' ')),
3576 /* Otherwise, we use a loop:
3577 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3581 /* Initialize variables. */
3582 gfc_init_block (&block);
3583 i = gfc_create_var (sizetype, "i");
3584 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3585 el = gfc_create_var (build_pointer_type (type), "el");
3586 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3587 exit_label = gfc_build_label_decl (NULL_TREE);
3588 TREE_USED (exit_label) = 1;
3592 gfc_init_block (&loop);
3594 /* Exit condition. */
3595 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3596 fold_convert (sizetype, integer_zero_node));
3597 tmp = build1_v (GOTO_EXPR, exit_label);
3598 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3599 build_empty_stmt (input_location));
3600 gfc_add_expr_to_block (&loop, tmp);
3603 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3604 build_int_cst (type,
3605 lang_hooks.to_target_charset (' ')));
3607 /* Increment loop variables. */
3608 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3609 TYPE_SIZE_UNIT (type)));
3610 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3612 TYPE_SIZE_UNIT (type)));
3614 /* Making the loop... actually loop! */
3615 tmp = gfc_finish_block (&loop);
3616 tmp = build1_v (LOOP_EXPR, tmp);
3617 gfc_add_expr_to_block (&block, tmp);
3619 /* The exit label. */
3620 tmp = build1_v (LABEL_EXPR, exit_label);
3621 gfc_add_expr_to_block (&block, tmp);
3624 return gfc_finish_block (&block);
3628 /* Generate code to copy a string. */
3631 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3632 int dkind, tree slength, tree src, int skind)
3634 tree tmp, dlen, slen;
3643 stmtblock_t tempblock;
3645 gcc_assert (dkind == skind);
3647 if (slength != NULL_TREE)
3649 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3650 ssc = gfc_string_to_single_character (slen, src, skind);
3654 slen = build_int_cst (size_type_node, 1);
3658 if (dlength != NULL_TREE)
3660 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3661 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3665 dlen = build_int_cst (size_type_node, 1);
3669 /* Assign directly if the types are compatible. */
3670 if (dsc != NULL_TREE && ssc != NULL_TREE
3671 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3673 gfc_add_modify (block, dsc, ssc);
3677 /* Do nothing if the destination length is zero. */
3678 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3679 build_int_cst (size_type_node, 0));
3681 /* The following code was previously in _gfortran_copy_string:
3683 // The two strings may overlap so we use memmove.
3685 copy_string (GFC_INTEGER_4 destlen, char * dest,
3686 GFC_INTEGER_4 srclen, const char * src)
3688 if (srclen >= destlen)
3690 // This will truncate if too long.
3691 memmove (dest, src, destlen);
3695 memmove (dest, src, srclen);
3697 memset (&dest[srclen], ' ', destlen - srclen);
3701 We're now doing it here for better optimization, but the logic
3704 /* For non-default character kinds, we have to multiply the string
3705 length by the base type size. */
3706 chartype = gfc_get_char_type (dkind);
3707 slen = fold_build2 (MULT_EXPR, size_type_node,
3708 fold_convert (size_type_node, slen),
3709 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3710 dlen = fold_build2 (MULT_EXPR, size_type_node,
3711 fold_convert (size_type_node, dlen),
3712 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3715 dest = fold_convert (pvoid_type_node, dest);
3717 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3720 src = fold_convert (pvoid_type_node, src);
3722 src = gfc_build_addr_expr (pvoid_type_node, src);
3724 /* Truncate string if source is too long. */
3725 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3726 tmp2 = build_call_expr_loc (input_location,
3727 built_in_decls[BUILT_IN_MEMMOVE],
3728 3, dest, src, dlen);
3730 /* Else copy and pad with spaces. */
3731 tmp3 = build_call_expr_loc (input_location,
3732 built_in_decls[BUILT_IN_MEMMOVE],
3733 3, dest, src, slen);
3735 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3736 fold_convert (sizetype, slen));
3737 tmp4 = fill_with_spaces (tmp4, chartype,
3738 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3741 gfc_init_block (&tempblock);
3742 gfc_add_expr_to_block (&tempblock, tmp3);
3743 gfc_add_expr_to_block (&tempblock, tmp4);
3744 tmp3 = gfc_finish_block (&tempblock);
3746 /* The whole copy_string function is there. */
3747 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3748 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3749 build_empty_stmt (input_location));
3750 gfc_add_expr_to_block (block, tmp);
3754 /* Translate a statement function.
3755 The value of a statement function reference is obtained by evaluating the
3756 expression using the values of the actual arguments for the values of the
3757 corresponding dummy arguments. */
3760 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3764 gfc_formal_arglist *fargs;
3765 gfc_actual_arglist *args;
3768 gfc_saved_var *saved_vars;
3774 sym = expr->symtree->n.sym;
3775 args = expr->value.function.actual;
3776 gfc_init_se (&lse, NULL);
3777 gfc_init_se (&rse, NULL);
3780 for (fargs = sym->formal; fargs; fargs = fargs->next)
3782 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3783 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3785 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3787 /* Each dummy shall be specified, explicitly or implicitly, to be
3789 gcc_assert (fargs->sym->attr.dimension == 0);
3792 /* Create a temporary to hold the value. */
3793 type = gfc_typenode_for_spec (&fsym->ts);
3794 temp_vars[n] = gfc_create_var (type, fsym->name);
3796 if (fsym->ts.type == BT_CHARACTER)
3798 /* Copy string arguments. */
3801 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3802 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3804 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3805 tmp = gfc_build_addr_expr (build_pointer_type (type),
3808 gfc_conv_expr (&rse, args->expr);
3809 gfc_conv_string_parameter (&rse);
3810 gfc_add_block_to_block (&se->pre, &lse.pre);
3811 gfc_add_block_to_block (&se->pre, &rse.pre);
3813 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3814 rse.string_length, rse.expr, fsym->ts.kind);
3815 gfc_add_block_to_block (&se->pre, &lse.post);
3816 gfc_add_block_to_block (&se->pre, &rse.post);
3820 /* For everything else, just evaluate the expression. */
3821 gfc_conv_expr (&lse, args->expr);
3823 gfc_add_block_to_block (&se->pre, &lse.pre);
3824 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3825 gfc_add_block_to_block (&se->pre, &lse.post);
3831 /* Use the temporary variables in place of the real ones. */
3832 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3833 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3835 gfc_conv_expr (se, sym->value);
3837 if (sym->ts.type == BT_CHARACTER)
3839 gfc_conv_const_charlen (sym->ts.u.cl);
3841 /* Force the expression to the correct length. */
3842 if (!INTEGER_CST_P (se->string_length)
3843 || tree_int_cst_lt (se->string_length,
3844 sym->ts.u.cl->backend_decl))
3846 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3847 tmp = gfc_create_var (type, sym->name);
3848 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3849 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3850 sym->ts.kind, se->string_length, se->expr,
3854 se->string_length = sym->ts.u.cl->backend_decl;
3857 /* Restore the original variables. */
3858 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3859 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3860 gfc_free (saved_vars);
3864 /* Translate a function expression. */
3867 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3871 if (expr->value.function.isym)
3873 gfc_conv_intrinsic_function (se, expr);
3877 /* We distinguish statement functions from general functions to improve
3878 runtime performance. */
3879 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3881 gfc_conv_statement_function (se, expr);
3885 /* expr.value.function.esym is the resolved (specific) function symbol for
3886 most functions. However this isn't set for dummy procedures. */
3887 sym = expr->value.function.esym;
3889 sym = expr->symtree->n.sym;
3891 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3895 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3898 is_zero_initializer_p (gfc_expr * expr)
3900 if (expr->expr_type != EXPR_CONSTANT)
3903 /* We ignore constants with prescribed memory representations for now. */
3904 if (expr->representation.string)
3907 switch (expr->ts.type)
3910 return mpz_cmp_si (expr->value.integer, 0) == 0;
3913 return mpfr_zero_p (expr->value.real)
3914 && MPFR_SIGN (expr->value.real) >= 0;
3917 return expr->value.logical == 0;
3920 return mpfr_zero_p (mpc_realref (expr->value.complex))
3921 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3922 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3923 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3933 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3935 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3936 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3938 gfc_conv_tmp_array_ref (se);
3939 gfc_advance_se_ss_chain (se);
3943 /* Build a static initializer. EXPR is the expression for the initial value.
3944 The other parameters describe the variable of the component being
3945 initialized. EXPR may be null. */
3948 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3949 bool array, bool pointer)
3953 if (!(expr || pointer))
3956 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3957 (these are the only two iso_c_binding derived types that can be
3958 used as initialization expressions). If so, we need to modify
3959 the 'expr' to be that for a (void *). */
3960 if (expr != NULL && expr->ts.type == BT_DERIVED
3961 && expr->ts.is_iso_c && expr->ts.u.derived)
3963 gfc_symbol *derived = expr->ts.u.derived;
3965 /* The derived symbol has already been converted to a (void *). Use
3967 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
3968 expr->ts.f90_type = derived->ts.f90_type;
3970 gfc_init_se (&se, NULL);
3971 gfc_conv_constant (&se, expr);
3977 /* Arrays need special handling. */
3979 return gfc_build_null_descriptor (type);
3980 /* Special case assigning an array to zero. */
3981 else if (is_zero_initializer_p (expr))
3982 return build_constructor (type, NULL);
3984 return gfc_conv_array_initializer (type, expr);
3988 if (!expr || expr->expr_type == EXPR_NULL)
3989 return fold_convert (type, null_pointer_node);
3992 gfc_init_se (&se, NULL);
3993 se.want_pointer = 1;
3994 gfc_conv_expr (&se, expr);
4004 gfc_init_se (&se, NULL);
4005 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4006 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4008 gfc_conv_structure (&se, expr, 1);
4012 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4015 gfc_init_se (&se, NULL);
4016 gfc_conv_constant (&se, expr);
4023 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4035 gfc_start_block (&block);
4037 /* Initialize the scalarizer. */
4038 gfc_init_loopinfo (&loop);
4040 gfc_init_se (&lse, NULL);
4041 gfc_init_se (&rse, NULL);
4044 rss = gfc_walk_expr (expr);
4045 if (rss == gfc_ss_terminator)
4047 /* The rhs is scalar. Add a ss for the expression. */
4048 rss = gfc_get_ss ();
4049 rss->next = gfc_ss_terminator;
4050 rss->type = GFC_SS_SCALAR;
4054 /* Create a SS for the destination. */
4055 lss = gfc_get_ss ();
4056 lss->type = GFC_SS_COMPONENT;
4058 lss->shape = gfc_get_shape (cm->as->rank);
4059 lss->next = gfc_ss_terminator;
4060 lss->data.info.dimen = cm->as->rank;
4061 lss->data.info.descriptor = dest;
4062 lss->data.info.data = gfc_conv_array_data (dest);
4063 lss->data.info.offset = gfc_conv_array_offset (dest);
4064 for (n = 0; n < cm->as->rank; n++)
4066 lss->data.info.dim[n] = n;
4067 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4068 lss->data.info.stride[n] = gfc_index_one_node;
4070 mpz_init (lss->shape[n]);
4071 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4072 cm->as->lower[n]->value.integer);
4073 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4076 /* Associate the SS with the loop. */
4077 gfc_add_ss_to_loop (&loop, lss);
4078 gfc_add_ss_to_loop (&loop, rss);
4080 /* Calculate the bounds of the scalarization. */
4081 gfc_conv_ss_startstride (&loop);
4083 /* Setup the scalarizing loops. */
4084 gfc_conv_loop_setup (&loop, &expr->where);
4086 /* Setup the gfc_se structures. */
4087 gfc_copy_loopinfo_to_se (&lse, &loop);
4088 gfc_copy_loopinfo_to_se (&rse, &loop);
4091 gfc_mark_ss_chain_used (rss, 1);
4093 gfc_mark_ss_chain_used (lss, 1);
4095 /* Start the scalarized loop body. */
4096 gfc_start_scalarized_body (&loop, &body);
4098 gfc_conv_tmp_array_ref (&lse);
4099 if (cm->ts.type == BT_CHARACTER)
4100 lse.string_length = cm->ts.u.cl->backend_decl;
4102 gfc_conv_expr (&rse, expr);
4104 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4105 gfc_add_expr_to_block (&body, tmp);
4107 gcc_assert (rse.ss == gfc_ss_terminator);
4109 /* Generate the copying loops. */
4110 gfc_trans_scalarizing_loops (&loop, &body);
4112 /* Wrap the whole thing up. */
4113 gfc_add_block_to_block (&block, &loop.pre);
4114 gfc_add_block_to_block (&block, &loop.post);
4116 for (n = 0; n < cm->as->rank; n++)
4117 mpz_clear (lss->shape[n]);
4118 gfc_free (lss->shape);
4120 gfc_cleanup_loop (&loop);
4122 return gfc_finish_block (&block);
4127 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4138 gfc_expr *arg = NULL;
4140 gfc_start_block (&block);
4141 gfc_init_se (&se, NULL);
4143 /* Get the descriptor for the expressions. */
4144 rss = gfc_walk_expr (expr);
4145 se.want_pointer = 0;
4146 gfc_conv_expr_descriptor (&se, expr, rss);
4147 gfc_add_block_to_block (&block, &se.pre);
4148 gfc_add_modify (&block, dest, se.expr);
4150 /* Deal with arrays of derived types with allocatable components. */
4151 if (cm->ts.type == BT_DERIVED
4152 && cm->ts.u.derived->attr.alloc_comp)
4153 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4157 tmp = gfc_duplicate_allocatable (dest, se.expr,
4158 TREE_TYPE(cm->backend_decl),
4161 gfc_add_expr_to_block (&block, tmp);
4162 gfc_add_block_to_block (&block, &se.post);
4164 if (expr->expr_type != EXPR_VARIABLE)
4165 gfc_conv_descriptor_data_set (&block, se.expr,
4168 /* We need to know if the argument of a conversion function is a
4169 variable, so that the correct lower bound can be used. */
4170 if (expr->expr_type == EXPR_FUNCTION
4171 && expr->value.function.isym
4172 && expr->value.function.isym->conversion
4173 && expr->value.function.actual->expr
4174 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4175 arg = expr->value.function.actual->expr;
4177 /* Obtain the array spec of full array references. */
4179 as = gfc_get_full_arrayspec_from_expr (arg);
4181 as = gfc_get_full_arrayspec_from_expr (expr);
4183 /* Shift the lbound and ubound of temporaries to being unity,
4184 rather than zero, based. Always calculate the offset. */
4185 offset = gfc_conv_descriptor_offset_get (dest);
4186 gfc_add_modify (&block, offset, gfc_index_zero_node);
4187 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4189 for (n = 0; n < expr->rank; n++)
4194 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4195 TODO It looks as if gfc_conv_expr_descriptor should return
4196 the correct bounds and that the following should not be
4197 necessary. This would simplify gfc_conv_intrinsic_bound
4199 if (as && as->lower[n])
4202 gfc_init_se (&lbse, NULL);
4203 gfc_conv_expr (&lbse, as->lower[n]);
4204 gfc_add_block_to_block (&block, &lbse.pre);
4205 lbound = gfc_evaluate_now (lbse.expr, &block);
4209 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4210 lbound = gfc_conv_descriptor_lbound_get (tmp,
4214 lbound = gfc_conv_descriptor_lbound_get (dest,
4217 lbound = gfc_index_one_node;
4219 lbound = fold_convert (gfc_array_index_type, lbound);
4221 /* Shift the bounds and set the offset accordingly. */
4222 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4223 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4224 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4225 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4226 gfc_conv_descriptor_ubound_set (&block, dest,
4227 gfc_rank_cst[n], tmp);
4228 gfc_conv_descriptor_lbound_set (&block, dest,
4229 gfc_rank_cst[n], lbound);
4231 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4232 gfc_conv_descriptor_lbound_get (dest,
4234 gfc_conv_descriptor_stride_get (dest,
4236 gfc_add_modify (&block, tmp2, tmp);
4237 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4238 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4243 /* If a conversion expression has a null data pointer
4244 argument, nullify the allocatable component. */
4248 if (arg->symtree->n.sym->attr.allocatable
4249 || arg->symtree->n.sym->attr.pointer)
4251 non_null_expr = gfc_finish_block (&block);
4252 gfc_start_block (&block);
4253 gfc_conv_descriptor_data_set (&block, dest,
4255 null_expr = gfc_finish_block (&block);
4256 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4257 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4258 fold_convert (TREE_TYPE (tmp),
4259 null_pointer_node));
4260 return build3_v (COND_EXPR, tmp,
4261 null_expr, non_null_expr);
4265 return gfc_finish_block (&block);
4269 /* Assign a single component of a derived type constructor. */
4272 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4280 gfc_start_block (&block);
4282 if (cm->attr.pointer)
4284 gfc_init_se (&se, NULL);
4285 /* Pointer component. */
4286 if (cm->attr.dimension)
4288 /* Array pointer. */
4289 if (expr->expr_type == EXPR_NULL)
4290 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4293 rss = gfc_walk_expr (expr);
4294 se.direct_byref = 1;
4296 gfc_conv_expr_descriptor (&se, expr, rss);
4297 gfc_add_block_to_block (&block, &se.pre);
4298 gfc_add_block_to_block (&block, &se.post);
4303 /* Scalar pointers. */
4304 se.want_pointer = 1;
4305 gfc_conv_expr (&se, expr);
4306 gfc_add_block_to_block (&block, &se.pre);
4307 gfc_add_modify (&block, dest,
4308 fold_convert (TREE_TYPE (dest), se.expr));
4309 gfc_add_block_to_block (&block, &se.post);
4312 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4314 /* NULL initialization for CLASS components. */
4315 tmp = gfc_trans_structure_assign (dest,
4316 gfc_class_null_initializer (&cm->ts));
4317 gfc_add_expr_to_block (&block, tmp);
4319 else if (cm->attr.dimension)
4321 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4322 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4323 else if (cm->attr.allocatable)
4325 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4326 gfc_add_expr_to_block (&block, tmp);
4330 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4331 gfc_add_expr_to_block (&block, tmp);
4334 else if (expr->ts.type == BT_DERIVED)
4336 if (expr->expr_type != EXPR_STRUCTURE)
4338 gfc_init_se (&se, NULL);
4339 gfc_conv_expr (&se, expr);
4340 gfc_add_block_to_block (&block, &se.pre);
4341 gfc_add_modify (&block, dest,
4342 fold_convert (TREE_TYPE (dest), se.expr));
4343 gfc_add_block_to_block (&block, &se.post);
4347 /* Nested constructors. */
4348 tmp = gfc_trans_structure_assign (dest, expr);
4349 gfc_add_expr_to_block (&block, tmp);
4354 /* Scalar component. */
4355 gfc_init_se (&se, NULL);
4356 gfc_init_se (&lse, NULL);
4358 gfc_conv_expr (&se, expr);
4359 if (cm->ts.type == BT_CHARACTER)
4360 lse.string_length = cm->ts.u.cl->backend_decl;
4362 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4363 gfc_add_expr_to_block (&block, tmp);
4365 return gfc_finish_block (&block);
4368 /* Assign a derived type constructor to a variable. */
4371 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4379 gfc_start_block (&block);
4380 cm = expr->ts.u.derived->components;
4381 for (c = gfc_constructor_first (expr->value.constructor);
4382 c; c = gfc_constructor_next (c), cm = cm->next)
4384 /* Skip absent members in default initializers. */
4388 /* Handle c_null_(fun)ptr. */
4389 if (c && c->expr && c->expr->ts.is_iso_c)
4391 field = cm->backend_decl;
4392 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4393 dest, field, NULL_TREE);
4394 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4395 fold_convert (TREE_TYPE (tmp),
4396 null_pointer_node));
4397 gfc_add_expr_to_block (&block, tmp);
4401 field = cm->backend_decl;
4402 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4403 dest, field, NULL_TREE);
4404 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4405 gfc_add_expr_to_block (&block, tmp);
4407 return gfc_finish_block (&block);
4410 /* Build an expression for a constructor. If init is nonzero then
4411 this is part of a static variable initializer. */
4414 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4421 VEC(constructor_elt,gc) *v = NULL;
4423 gcc_assert (se->ss == NULL);
4424 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4425 type = gfc_typenode_for_spec (&expr->ts);
4429 /* Create a temporary variable and fill it in. */
4430 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4431 tmp = gfc_trans_structure_assign (se->expr, expr);
4432 gfc_add_expr_to_block (&se->pre, tmp);
4436 cm = expr->ts.u.derived->components;
4438 for (c = gfc_constructor_first (expr->value.constructor);
4439 c; c = gfc_constructor_next (c), cm = cm->next)
4441 /* Skip absent members in default initializers and allocatable
4442 components. Although the latter have a default initializer
4443 of EXPR_NULL,... by default, the static nullify is not needed
4444 since this is done every time we come into scope. */
4445 if (!c->expr || cm->attr.allocatable)
4448 if (strcmp (cm->name, "$size") == 0)
4450 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4451 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4453 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4454 && strcmp (cm->name, "$extends") == 0)
4458 vtabs = cm->initializer->symtree->n.sym;
4459 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4460 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4464 val = gfc_conv_initializer (c->expr, &cm->ts,
4465 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4466 cm->attr.pointer || cm->attr.proc_pointer);
4468 /* Append it to the constructor list. */
4469 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4472 se->expr = build_constructor (type, v);
4474 TREE_CONSTANT (se->expr) = 1;
4478 /* Translate a substring expression. */
4481 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4487 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4489 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4490 expr->value.character.length,
4491 expr->value.character.string);
4493 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4494 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4497 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4501 /* Entry point for expression translation. Evaluates a scalar quantity.
4502 EXPR is the expression to be translated, and SE is the state structure if
4503 called from within the scalarized. */
4506 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4508 if (se->ss && se->ss->expr == expr
4509 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4511 /* Substitute a scalar expression evaluated outside the scalarization
4513 se->expr = se->ss->data.scalar.expr;
4514 if (se->ss->type == GFC_SS_REFERENCE)
4515 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4516 se->string_length = se->ss->string_length;
4517 gfc_advance_se_ss_chain (se);
4521 /* We need to convert the expressions for the iso_c_binding derived types.
4522 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4523 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4524 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4525 updated to be an integer with a kind equal to the size of a (void *). */
4526 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4527 && expr->ts.u.derived->attr.is_iso_c)
4529 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4530 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4532 /* Set expr_type to EXPR_NULL, which will result in
4533 null_pointer_node being used below. */
4534 expr->expr_type = EXPR_NULL;
4538 /* Update the type/kind of the expression to be what the new
4539 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4540 expr->ts.type = expr->ts.u.derived->ts.type;
4541 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4542 expr->ts.kind = expr->ts.u.derived->ts.kind;
4546 switch (expr->expr_type)
4549 gfc_conv_expr_op (se, expr);
4553 gfc_conv_function_expr (se, expr);
4557 gfc_conv_constant (se, expr);
4561 gfc_conv_variable (se, expr);
4565 se->expr = null_pointer_node;
4568 case EXPR_SUBSTRING:
4569 gfc_conv_substring_expr (se, expr);
4572 case EXPR_STRUCTURE:
4573 gfc_conv_structure (se, expr, 0);
4577 gfc_conv_array_constructor_expr (se, expr);
4586 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4587 of an assignment. */
4589 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4591 gfc_conv_expr (se, expr);
4592 /* All numeric lvalues should have empty post chains. If not we need to
4593 figure out a way of rewriting an lvalue so that it has no post chain. */
4594 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4597 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4598 numeric expressions. Used for scalar values where inserting cleanup code
4601 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4605 gcc_assert (expr->ts.type != BT_CHARACTER);
4606 gfc_conv_expr (se, expr);
4609 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4610 gfc_add_modify (&se->pre, val, se->expr);
4612 gfc_add_block_to_block (&se->pre, &se->post);
4616 /* Helper to translate an expression and convert it to a particular type. */
4618 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4620 gfc_conv_expr_val (se, expr);
4621 se->expr = convert (type, se->expr);
4625 /* Converts an expression so that it can be passed by reference. Scalar
4629 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4633 if (se->ss && se->ss->expr == expr
4634 && se->ss->type == GFC_SS_REFERENCE)
4636 /* Returns a reference to the scalar evaluated outside the loop
4638 gfc_conv_expr (se, expr);
4642 if (expr->ts.type == BT_CHARACTER)
4644 gfc_conv_expr (se, expr);
4645 gfc_conv_string_parameter (se);
4649 if (expr->expr_type == EXPR_VARIABLE)
4651 se->want_pointer = 1;
4652 gfc_conv_expr (se, expr);
4655 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4656 gfc_add_modify (&se->pre, var, se->expr);
4657 gfc_add_block_to_block (&se->pre, &se->post);
4663 if (expr->expr_type == EXPR_FUNCTION
4664 && ((expr->value.function.esym
4665 && expr->value.function.esym->result->attr.pointer
4666 && !expr->value.function.esym->result->attr.dimension)
4667 || (!expr->value.function.esym
4668 && expr->symtree->n.sym->attr.pointer
4669 && !expr->symtree->n.sym->attr.dimension)))
4671 se->want_pointer = 1;
4672 gfc_conv_expr (se, expr);
4673 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4674 gfc_add_modify (&se->pre, var, se->expr);
4680 gfc_conv_expr (se, expr);
4682 /* Create a temporary var to hold the value. */
4683 if (TREE_CONSTANT (se->expr))
4685 tree tmp = se->expr;
4686 STRIP_TYPE_NOPS (tmp);
4687 var = build_decl (input_location,
4688 CONST_DECL, NULL, TREE_TYPE (tmp));
4689 DECL_INITIAL (var) = tmp;
4690 TREE_STATIC (var) = 1;
4695 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4696 gfc_add_modify (&se->pre, var, se->expr);
4698 gfc_add_block_to_block (&se->pre, &se->post);
4700 /* Take the address of that value. */
4701 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4706 gfc_trans_pointer_assign (gfc_code * code)
4708 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4712 /* Generate code for a pointer assignment. */
4715 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4726 gfc_start_block (&block);
4728 gfc_init_se (&lse, NULL);
4730 lss = gfc_walk_expr (expr1);
4731 rss = gfc_walk_expr (expr2);
4732 if (lss == gfc_ss_terminator)
4734 /* Scalar pointers. */
4735 lse.want_pointer = 1;
4736 gfc_conv_expr (&lse, expr1);
4737 gcc_assert (rss == gfc_ss_terminator);
4738 gfc_init_se (&rse, NULL);
4739 rse.want_pointer = 1;
4740 gfc_conv_expr (&rse, expr2);
4742 if (expr1->symtree->n.sym->attr.proc_pointer
4743 && expr1->symtree->n.sym->attr.dummy)
4744 lse.expr = build_fold_indirect_ref_loc (input_location,
4747 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4748 && expr2->symtree->n.sym->attr.dummy)
4749 rse.expr = build_fold_indirect_ref_loc (input_location,
4752 gfc_add_block_to_block (&block, &lse.pre);
4753 gfc_add_block_to_block (&block, &rse.pre);
4755 /* Check character lengths if character expression. The test is only
4756 really added if -fbounds-check is enabled. */
4757 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4758 && !expr1->symtree->n.sym->attr.proc_pointer
4759 && !gfc_is_proc_ptr_comp (expr1, NULL))
4761 gcc_assert (expr2->ts.type == BT_CHARACTER);
4762 gcc_assert (lse.string_length && rse.string_length);
4763 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4764 lse.string_length, rse.string_length,
4768 gfc_add_modify (&block, lse.expr,
4769 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4771 gfc_add_block_to_block (&block, &rse.post);
4772 gfc_add_block_to_block (&block, &lse.post);
4779 tree strlen_rhs = NULL_TREE;
4781 /* Array pointer. Find the last reference on the LHS and if it is an
4782 array section ref, we're dealing with bounds remapping. In this case,
4783 set it to AR_FULL so that gfc_conv_expr_descriptor does
4784 not see it and process the bounds remapping afterwards explicitely. */
4785 for (remap = expr1->ref; remap; remap = remap->next)
4786 if (!remap->next && remap->type == REF_ARRAY
4787 && remap->u.ar.type == AR_SECTION)
4789 remap->u.ar.type = AR_FULL;
4792 rank_remap = (remap && remap->u.ar.end[0]);
4794 gfc_conv_expr_descriptor (&lse, expr1, lss);
4795 strlen_lhs = lse.string_length;
4798 if (expr2->expr_type == EXPR_NULL)
4800 /* Just set the data pointer to null. */
4801 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4803 else if (rank_remap)
4805 /* If we are rank-remapping, just get the RHS's descriptor and
4806 process this later on. */
4807 gfc_init_se (&rse, NULL);
4808 rse.direct_byref = 1;
4809 rse.byref_noassign = 1;
4810 gfc_conv_expr_descriptor (&rse, expr2, rss);
4811 strlen_rhs = rse.string_length;
4813 else if (expr2->expr_type == EXPR_VARIABLE)
4815 /* Assign directly to the LHS's descriptor. */
4816 lse.direct_byref = 1;
4817 gfc_conv_expr_descriptor (&lse, expr2, rss);
4818 strlen_rhs = lse.string_length;
4820 /* If this is a subreference array pointer assignment, use the rhs
4821 descriptor element size for the lhs span. */
4822 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4824 decl = expr1->symtree->n.sym->backend_decl;
4825 gfc_init_se (&rse, NULL);
4826 rse.descriptor_only = 1;
4827 gfc_conv_expr (&rse, expr2);
4828 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4829 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4830 if (!INTEGER_CST_P (tmp))
4831 gfc_add_block_to_block (&lse.post, &rse.pre);
4832 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4837 /* Assign to a temporary descriptor and then copy that
4838 temporary to the pointer. */
4839 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4842 lse.direct_byref = 1;
4843 gfc_conv_expr_descriptor (&lse, expr2, rss);
4844 strlen_rhs = lse.string_length;
4845 gfc_add_modify (&lse.pre, desc, tmp);
4848 gfc_add_block_to_block (&block, &lse.pre);
4850 gfc_add_block_to_block (&block, &rse.pre);
4852 /* If we do bounds remapping, update LHS descriptor accordingly. */
4856 gcc_assert (remap->u.ar.dimen == expr1->rank);
4860 /* Do rank remapping. We already have the RHS's descriptor
4861 converted in rse and now have to build the correct LHS
4862 descriptor for it. */
4866 tree lbound, ubound;
4869 dtype = gfc_conv_descriptor_dtype (desc);
4870 tmp = gfc_get_dtype (TREE_TYPE (desc));
4871 gfc_add_modify (&block, dtype, tmp);
4873 /* Copy data pointer. */
4874 data = gfc_conv_descriptor_data_get (rse.expr);
4875 gfc_conv_descriptor_data_set (&block, desc, data);
4877 /* Copy offset but adjust it such that it would correspond
4878 to a lbound of zero. */
4879 offs = gfc_conv_descriptor_offset_get (rse.expr);
4880 for (dim = 0; dim < expr2->rank; ++dim)
4882 stride = gfc_conv_descriptor_stride_get (rse.expr,
4884 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
4886 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4888 offs = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4891 gfc_conv_descriptor_offset_set (&block, desc, offs);
4893 /* Set the bounds as declared for the LHS and calculate strides as
4894 well as another offset update accordingly. */
4895 stride = gfc_conv_descriptor_stride_get (rse.expr,
4897 for (dim = 0; dim < expr1->rank; ++dim)
4902 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
4904 /* Convert declared bounds. */
4905 gfc_init_se (&lower_se, NULL);
4906 gfc_init_se (&upper_se, NULL);
4907 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
4908 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
4910 gfc_add_block_to_block (&block, &lower_se.pre);
4911 gfc_add_block_to_block (&block, &upper_se.pre);
4913 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
4914 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
4916 lbound = gfc_evaluate_now (lbound, &block);
4917 ubound = gfc_evaluate_now (ubound, &block);
4919 gfc_add_block_to_block (&block, &lower_se.post);
4920 gfc_add_block_to_block (&block, &upper_se.post);
4922 /* Set bounds in descriptor. */
4923 gfc_conv_descriptor_lbound_set (&block, desc,
4924 gfc_rank_cst[dim], lbound);
4925 gfc_conv_descriptor_ubound_set (&block, desc,
4926 gfc_rank_cst[dim], ubound);
4929 stride = gfc_evaluate_now (stride, &block);
4930 gfc_conv_descriptor_stride_set (&block, desc,
4931 gfc_rank_cst[dim], stride);
4933 /* Update offset. */
4934 offs = gfc_conv_descriptor_offset_get (desc);
4935 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4937 offs = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4939 offs = gfc_evaluate_now (offs, &block);
4940 gfc_conv_descriptor_offset_set (&block, desc, offs);
4942 /* Update stride. */
4943 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4944 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4950 /* Bounds remapping. Just shift the lower bounds. */
4952 gcc_assert (expr1->rank == expr2->rank);
4954 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
4958 gcc_assert (remap->u.ar.start[dim]);
4959 gcc_assert (!remap->u.ar.end[dim]);
4960 gfc_init_se (&lbound_se, NULL);
4961 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
4963 gfc_add_block_to_block (&block, &lbound_se.pre);
4964 gfc_conv_shift_descriptor_lbound (&block, desc,
4965 dim, lbound_se.expr);
4966 gfc_add_block_to_block (&block, &lbound_se.post);
4971 /* Check string lengths if applicable. The check is only really added
4972 to the output code if -fbounds-check is enabled. */
4973 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4975 gcc_assert (expr2->ts.type == BT_CHARACTER);
4976 gcc_assert (strlen_lhs && strlen_rhs);
4977 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4978 strlen_lhs, strlen_rhs, &block);
4981 /* If rank remapping was done, check with -fcheck=bounds that
4982 the target is at least as large as the pointer. */
4983 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
4989 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
4990 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
4992 lsize = gfc_evaluate_now (lsize, &block);
4993 rsize = gfc_evaluate_now (rsize, &block);
4994 fault = fold_build2 (LT_EXPR, boolean_type_node, rsize, lsize);
4996 msg = _("Target of rank remapping is too small (%ld < %ld)");
4997 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5001 gfc_add_block_to_block (&block, &lse.post);
5003 gfc_add_block_to_block (&block, &rse.post);
5006 return gfc_finish_block (&block);
5010 /* Makes sure se is suitable for passing as a function string parameter. */
5011 /* TODO: Need to check all callers of this function. It may be abused. */
5014 gfc_conv_string_parameter (gfc_se * se)
5018 if (TREE_CODE (se->expr) == STRING_CST)
5020 type = TREE_TYPE (TREE_TYPE (se->expr));
5021 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5025 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5027 if (TREE_CODE (se->expr) != INDIRECT_REF)
5029 type = TREE_TYPE (se->expr);
5030 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5034 type = gfc_get_character_type_len (gfc_default_character_kind,
5036 type = build_pointer_type (type);
5037 se->expr = gfc_build_addr_expr (type, se->expr);
5041 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5042 gcc_assert (se->string_length
5043 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
5047 /* Generate code for assignment of scalar variables. Includes character
5048 strings and derived types with allocatable components.
5049 If you know that the LHS has no allocations, set dealloc to false. */
5052 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5053 bool l_is_temp, bool r_is_var, bool dealloc)
5059 gfc_init_block (&block);
5061 if (ts.type == BT_CHARACTER)
5066 if (lse->string_length != NULL_TREE)
5068 gfc_conv_string_parameter (lse);
5069 gfc_add_block_to_block (&block, &lse->pre);
5070 llen = lse->string_length;
5073 if (rse->string_length != NULL_TREE)
5075 gcc_assert (rse->string_length != NULL_TREE);
5076 gfc_conv_string_parameter (rse);
5077 gfc_add_block_to_block (&block, &rse->pre);
5078 rlen = rse->string_length;
5081 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5082 rse->expr, ts.kind);
5084 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5088 /* Are the rhs and the lhs the same? */
5091 cond = fold_build2 (EQ_EXPR, boolean_type_node,
5092 gfc_build_addr_expr (NULL_TREE, lse->expr),
5093 gfc_build_addr_expr (NULL_TREE, rse->expr));
5094 cond = gfc_evaluate_now (cond, &lse->pre);
5097 /* Deallocate the lhs allocated components as long as it is not
5098 the same as the rhs. This must be done following the assignment
5099 to prevent deallocating data that could be used in the rhs
5101 if (!l_is_temp && dealloc)
5103 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5104 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5106 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5108 gfc_add_expr_to_block (&lse->post, tmp);
5111 gfc_add_block_to_block (&block, &rse->pre);
5112 gfc_add_block_to_block (&block, &lse->pre);
5114 gfc_add_modify (&block, lse->expr,
5115 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5117 /* Do a deep copy if the rhs is a variable, if it is not the
5121 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5122 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5124 gfc_add_expr_to_block (&block, tmp);
5127 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5129 gfc_add_block_to_block (&block, &lse->pre);
5130 gfc_add_block_to_block (&block, &rse->pre);
5131 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
5132 gfc_add_modify (&block, lse->expr, tmp);
5136 gfc_add_block_to_block (&block, &lse->pre);
5137 gfc_add_block_to_block (&block, &rse->pre);
5139 gfc_add_modify (&block, lse->expr,
5140 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5143 gfc_add_block_to_block (&block, &lse->post);
5144 gfc_add_block_to_block (&block, &rse->post);
5146 return gfc_finish_block (&block);
5150 /* There are quite a lot of restrictions on the optimisation in using an
5151 array function assign without a temporary. */
5154 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5157 bool seen_array_ref;
5159 gfc_symbol *sym = expr1->symtree->n.sym;
5161 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5162 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5165 /* Elemental functions are scalarized so that they don't need a
5166 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5167 they would need special treatment in gfc_trans_arrayfunc_assign. */
5168 if (expr2->value.function.esym != NULL
5169 && expr2->value.function.esym->attr.elemental)
5172 /* Need a temporary if rhs is not FULL or a contiguous section. */
5173 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5176 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5177 if (gfc_ref_needs_temporary_p (expr1->ref))
5180 /* Functions returning pointers need temporaries. */
5181 if (expr2->symtree->n.sym->attr.pointer
5182 || expr2->symtree->n.sym->attr.allocatable)
5185 /* Character array functions need temporaries unless the
5186 character lengths are the same. */
5187 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5189 if (expr1->ts.u.cl->length == NULL
5190 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5193 if (expr2->ts.u.cl->length == NULL
5194 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5197 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5198 expr2->ts.u.cl->length->value.integer) != 0)
5202 /* Check that no LHS component references appear during an array
5203 reference. This is needed because we do not have the means to
5204 span any arbitrary stride with an array descriptor. This check
5205 is not needed for the rhs because the function result has to be
5207 seen_array_ref = false;
5208 for (ref = expr1->ref; ref; ref = ref->next)
5210 if (ref->type == REF_ARRAY)
5211 seen_array_ref= true;
5212 else if (ref->type == REF_COMPONENT && seen_array_ref)
5216 /* Check for a dependency. */
5217 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5218 expr2->value.function.esym,
5219 expr2->value.function.actual,
5223 /* If we have reached here with an intrinsic function, we do not
5224 need a temporary. */
5225 if (expr2->value.function.isym)
5228 /* If the LHS is a dummy, we need a temporary if it is not
5230 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5233 /* A PURE function can unconditionally be called without a temporary. */
5234 if (expr2->value.function.esym != NULL
5235 && expr2->value.function.esym->attr.pure)
5238 /* TODO a function that could correctly be declared PURE but is not
5239 could do with returning false as well. */
5241 if (!sym->attr.use_assoc
5242 && !sym->attr.in_common
5243 && !sym->attr.pointer
5244 && !sym->attr.target
5245 && expr2->value.function.esym)
5247 /* A temporary is not needed if the function is not contained and
5248 the variable is local or host associated and not a pointer or
5250 if (!expr2->value.function.esym->attr.contained)
5253 /* A temporary is not needed if the lhs has never been host
5254 associated and the procedure is contained. */
5255 else if (!sym->attr.host_assoc)
5258 /* A temporary is not needed if the variable is local and not
5259 a pointer, a target or a result. */
5261 && expr2->value.function.esym->ns == sym->ns->parent)
5265 /* Default to temporary use. */
5270 /* Try to translate array(:) = func (...), where func is a transformational
5271 array function, without using a temporary. Returns NULL if this isn't the
5275 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5279 gfc_component *comp = NULL;
5281 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5284 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5286 gcc_assert (expr2->value.function.isym
5287 || (gfc_is_proc_ptr_comp (expr2, &comp)
5288 && comp && comp->attr.dimension)
5289 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5290 && expr2->value.function.esym->result->attr.dimension));
5292 ss = gfc_walk_expr (expr1);
5293 gcc_assert (ss != gfc_ss_terminator);
5294 gfc_init_se (&se, NULL);
5295 gfc_start_block (&se.pre);
5296 se.want_pointer = 1;
5298 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5300 if (expr1->ts.type == BT_DERIVED
5301 && expr1->ts.u.derived->attr.alloc_comp)
5304 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5306 gfc_add_expr_to_block (&se.pre, tmp);
5309 se.direct_byref = 1;
5310 se.ss = gfc_walk_expr (expr2);
5311 gcc_assert (se.ss != gfc_ss_terminator);
5312 gfc_conv_function_expr (&se, expr2);
5313 gfc_add_block_to_block (&se.pre, &se.post);
5315 return gfc_finish_block (&se.pre);
5319 /* Try to efficiently translate array(:) = 0. Return NULL if this
5323 gfc_trans_zero_assign (gfc_expr * expr)
5325 tree dest, len, type;
5329 sym = expr->symtree->n.sym;
5330 dest = gfc_get_symbol_decl (sym);
5332 type = TREE_TYPE (dest);
5333 if (POINTER_TYPE_P (type))
5334 type = TREE_TYPE (type);
5335 if (!GFC_ARRAY_TYPE_P (type))
5338 /* Determine the length of the array. */
5339 len = GFC_TYPE_ARRAY_SIZE (type);
5340 if (!len || TREE_CODE (len) != INTEGER_CST)
5343 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5344 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5345 fold_convert (gfc_array_index_type, tmp));
5347 /* If we are zeroing a local array avoid taking its address by emitting
5349 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5350 return build2 (MODIFY_EXPR, void_type_node,
5351 dest, build_constructor (TREE_TYPE (dest), NULL));
5353 /* Convert arguments to the correct types. */
5354 dest = fold_convert (pvoid_type_node, dest);
5355 len = fold_convert (size_type_node, len);
5357 /* Construct call to __builtin_memset. */
5358 tmp = build_call_expr_loc (input_location,
5359 built_in_decls[BUILT_IN_MEMSET],
5360 3, dest, integer_zero_node, len);
5361 return fold_convert (void_type_node, tmp);
5365 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5366 that constructs the call to __builtin_memcpy. */
5369 gfc_build_memcpy_call (tree dst, tree src, tree len)
5373 /* Convert arguments to the correct types. */
5374 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5375 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5377 dst = fold_convert (pvoid_type_node, dst);
5379 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5380 src = gfc_build_addr_expr (pvoid_type_node, src);
5382 src = fold_convert (pvoid_type_node, src);
5384 len = fold_convert (size_type_node, len);
5386 /* Construct call to __builtin_memcpy. */
5387 tmp = build_call_expr_loc (input_location,
5388 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5389 return fold_convert (void_type_node, tmp);
5393 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5394 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5395 source/rhs, both are gfc_full_array_ref_p which have been checked for
5399 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5401 tree dst, dlen, dtype;
5402 tree src, slen, stype;
5405 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5406 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5408 dtype = TREE_TYPE (dst);
5409 if (POINTER_TYPE_P (dtype))
5410 dtype = TREE_TYPE (dtype);
5411 stype = TREE_TYPE (src);
5412 if (POINTER_TYPE_P (stype))
5413 stype = TREE_TYPE (stype);
5415 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5418 /* Determine the lengths of the arrays. */
5419 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5420 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5422 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5423 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5424 fold_convert (gfc_array_index_type, tmp));
5426 slen = GFC_TYPE_ARRAY_SIZE (stype);
5427 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5429 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5430 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5431 fold_convert (gfc_array_index_type, tmp));
5433 /* Sanity check that they are the same. This should always be
5434 the case, as we should already have checked for conformance. */
5435 if (!tree_int_cst_equal (slen, dlen))
5438 return gfc_build_memcpy_call (dst, src, dlen);
5442 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5443 this can't be done. EXPR1 is the destination/lhs for which
5444 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5447 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5449 unsigned HOST_WIDE_INT nelem;
5455 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5459 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5460 dtype = TREE_TYPE (dst);
5461 if (POINTER_TYPE_P (dtype))
5462 dtype = TREE_TYPE (dtype);
5463 if (!GFC_ARRAY_TYPE_P (dtype))
5466 /* Determine the lengths of the array. */
5467 len = GFC_TYPE_ARRAY_SIZE (dtype);
5468 if (!len || TREE_CODE (len) != INTEGER_CST)
5471 /* Confirm that the constructor is the same size. */
5472 if (compare_tree_int (len, nelem) != 0)
5475 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5476 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5477 fold_convert (gfc_array_index_type, tmp));
5479 stype = gfc_typenode_for_spec (&expr2->ts);
5480 src = gfc_build_constant_array_constructor (expr2, stype);
5482 stype = TREE_TYPE (src);
5483 if (POINTER_TYPE_P (stype))
5484 stype = TREE_TYPE (stype);
5486 return gfc_build_memcpy_call (dst, src, len);
5490 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5491 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5492 init_flag indicates initialization expressions and dealloc that no
5493 deallocate prior assignment is needed (if in doubt, set true). */
5496 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5502 gfc_ss *lss_section;
5509 bool scalar_to_array;
5513 /* Assignment of the form lhs = rhs. */
5514 gfc_start_block (&block);
5516 gfc_init_se (&lse, NULL);
5517 gfc_init_se (&rse, NULL);
5520 lss = gfc_walk_expr (expr1);
5522 if (lss != gfc_ss_terminator)
5524 /* Allow the scalarizer to workshare array assignments. */
5525 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5526 ompws_flags |= OMPWS_SCALARIZER_WS;
5528 /* The assignment needs scalarization. */
5531 /* Find a non-scalar SS from the lhs. */
5532 while (lss_section != gfc_ss_terminator
5533 && lss_section->type != GFC_SS_SECTION)
5534 lss_section = lss_section->next;
5536 gcc_assert (lss_section != gfc_ss_terminator);
5538 /* Initialize the scalarizer. */
5539 gfc_init_loopinfo (&loop);
5542 rss = gfc_walk_expr (expr2);
5543 if (rss == gfc_ss_terminator)
5545 /* The rhs is scalar. Add a ss for the expression. */
5546 rss = gfc_get_ss ();
5547 rss->next = gfc_ss_terminator;
5548 rss->type = GFC_SS_SCALAR;
5551 /* Associate the SS with the loop. */
5552 gfc_add_ss_to_loop (&loop, lss);
5553 gfc_add_ss_to_loop (&loop, rss);
5555 /* Calculate the bounds of the scalarization. */
5556 gfc_conv_ss_startstride (&loop);
5557 /* Enable loop reversal. */
5558 for (n = 0; n < loop.dimen; n++)
5559 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5560 /* Resolve any data dependencies in the statement. */
5561 gfc_conv_resolve_dependencies (&loop, lss, rss);
5562 /* Setup the scalarizing loops. */
5563 gfc_conv_loop_setup (&loop, &expr2->where);
5565 /* Setup the gfc_se structures. */
5566 gfc_copy_loopinfo_to_se (&lse, &loop);
5567 gfc_copy_loopinfo_to_se (&rse, &loop);
5570 gfc_mark_ss_chain_used (rss, 1);
5571 if (loop.temp_ss == NULL)
5574 gfc_mark_ss_chain_used (lss, 1);
5578 lse.ss = loop.temp_ss;
5579 gfc_mark_ss_chain_used (lss, 3);
5580 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5583 /* Start the scalarized loop body. */
5584 gfc_start_scalarized_body (&loop, &body);
5587 gfc_init_block (&body);
5589 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5591 /* Translate the expression. */
5592 gfc_conv_expr (&rse, expr2);
5594 /* Stabilize a string length for temporaries. */
5595 if (expr2->ts.type == BT_CHARACTER)
5596 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5598 string_length = NULL_TREE;
5602 gfc_conv_tmp_array_ref (&lse);
5603 gfc_advance_se_ss_chain (&lse);
5604 if (expr2->ts.type == BT_CHARACTER)
5605 lse.string_length = string_length;
5608 gfc_conv_expr (&lse, expr1);
5610 /* Assignments of scalar derived types with allocatable components
5611 to arrays must be done with a deep copy and the rhs temporary
5612 must have its components deallocated afterwards. */
5613 scalar_to_array = (expr2->ts.type == BT_DERIVED
5614 && expr2->ts.u.derived->attr.alloc_comp
5615 && expr2->expr_type != EXPR_VARIABLE
5616 && !gfc_is_constant_expr (expr2)
5617 && expr1->rank && !expr2->rank);
5618 if (scalar_to_array && dealloc)
5620 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5621 gfc_add_expr_to_block (&loop.post, tmp);
5624 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5625 l_is_temp || init_flag,
5626 (expr2->expr_type == EXPR_VARIABLE)
5627 || scalar_to_array, dealloc);
5628 gfc_add_expr_to_block (&body, tmp);
5630 if (lss == gfc_ss_terminator)
5632 /* Use the scalar assignment as is. */
5633 gfc_add_block_to_block (&block, &body);
5637 gcc_assert (lse.ss == gfc_ss_terminator
5638 && rse.ss == gfc_ss_terminator);
5642 gfc_trans_scalarized_loop_boundary (&loop, &body);
5644 /* We need to copy the temporary to the actual lhs. */
5645 gfc_init_se (&lse, NULL);
5646 gfc_init_se (&rse, NULL);
5647 gfc_copy_loopinfo_to_se (&lse, &loop);
5648 gfc_copy_loopinfo_to_se (&rse, &loop);
5650 rse.ss = loop.temp_ss;
5653 gfc_conv_tmp_array_ref (&rse);
5654 gfc_advance_se_ss_chain (&rse);
5655 gfc_conv_expr (&lse, expr1);
5657 gcc_assert (lse.ss == gfc_ss_terminator
5658 && rse.ss == gfc_ss_terminator);
5660 if (expr2->ts.type == BT_CHARACTER)
5661 rse.string_length = string_length;
5663 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5664 false, false, dealloc);
5665 gfc_add_expr_to_block (&body, tmp);
5668 /* Generate the copying loops. */
5669 gfc_trans_scalarizing_loops (&loop, &body);
5671 /* Wrap the whole thing up. */
5672 gfc_add_block_to_block (&block, &loop.pre);
5673 gfc_add_block_to_block (&block, &loop.post);
5675 gfc_cleanup_loop (&loop);
5678 return gfc_finish_block (&block);
5682 /* Check whether EXPR is a copyable array. */
5685 copyable_array_p (gfc_expr * expr)
5687 if (expr->expr_type != EXPR_VARIABLE)
5690 /* First check it's an array. */
5691 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5694 if (!gfc_full_array_ref_p (expr->ref, NULL))
5697 /* Next check that it's of a simple enough type. */
5698 switch (expr->ts.type)
5710 return !expr->ts.u.derived->attr.alloc_comp;
5719 /* Translate an assignment. */
5722 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5727 /* Special case a single function returning an array. */
5728 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5730 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5735 /* Special case assigning an array to zero. */
5736 if (copyable_array_p (expr1)
5737 && is_zero_initializer_p (expr2))
5739 tmp = gfc_trans_zero_assign (expr1);
5744 /* Special case copying one array to another. */
5745 if (copyable_array_p (expr1)
5746 && copyable_array_p (expr2)
5747 && gfc_compare_types (&expr1->ts, &expr2->ts)
5748 && !gfc_check_dependency (expr1, expr2, 0))
5750 tmp = gfc_trans_array_copy (expr1, expr2);
5755 /* Special case initializing an array from a constant array constructor. */
5756 if (copyable_array_p (expr1)
5757 && expr2->expr_type == EXPR_ARRAY
5758 && gfc_compare_types (&expr1->ts, &expr2->ts))
5760 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5765 /* Fallback to the scalarizer to generate explicit loops. */
5766 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5770 gfc_trans_init_assign (gfc_code * code)
5772 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5776 gfc_trans_assign (gfc_code * code)
5778 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5782 /* Generate code to assign typebound procedures to a derived vtab. */
5783 void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
5787 tree vtb, ctree, proc, cond = NULL_TREE;
5790 /* Point to the first procedure pointer. */
5791 cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
5796 vtb = gfc_get_symbol_decl (vtab);
5798 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), vtb,
5799 cmp->backend_decl, NULL_TREE);
5800 cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
5801 build_int_cst (TREE_TYPE (ctree), 0));
5803 gfc_init_block (&body);
5804 for (; cmp; cmp = cmp->next)
5806 gfc_symbol *target = NULL;
5808 /* This is required when typebound generic procedures are called
5809 with derived type targets. The specific procedures do not get
5810 added to the vtype, which remains "empty". */
5811 if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
5812 target = cmp->tb->u.specific->n.sym;
5816 st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
5817 if (st->n.tb && st->n.tb->u.specific)
5818 target = st->n.tb->u.specific->n.sym;
5824 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5825 vtb, cmp->backend_decl, NULL_TREE);
5826 proc = gfc_get_symbol_decl (target);
5827 proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
5828 gfc_add_modify (&body, ctree, proc);
5831 proc = gfc_finish_block (&body);
5833 proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
5835 gfc_add_expr_to_block (block, proc);
5839 /* Special case for initializing a CLASS variable on allocation.
5840 A MEMCPY is needed to copy the full data of the dynamic type,
5841 which may be different from the declared type. */
5844 gfc_trans_class_init_assign (gfc_code *code)
5850 gfc_start_block (&block);
5852 gfc_init_se (&dst, NULL);
5853 gfc_init_se (&src, NULL);
5854 gfc_add_component_ref (code->expr1, "$data");
5855 gfc_conv_expr (&dst, code->expr1);
5856 gfc_conv_expr (&src, code->expr2);
5857 gfc_add_block_to_block (&block, &src.pre);
5858 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5859 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5860 gfc_add_expr_to_block (&block, tmp);
5862 return gfc_finish_block (&block);
5866 /* Translate an assignment to a CLASS object
5867 (pointer or ordinary assignment). */
5870 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5877 gfc_start_block (&block);
5879 if (expr2->ts.type != BT_CLASS)
5881 /* Insert an additional assignment which sets the '$vptr' field. */
5882 lhs = gfc_copy_expr (expr1);
5883 gfc_add_component_ref (lhs, "$vptr");
5884 if (expr2->ts.type == BT_DERIVED)
5888 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
5890 gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
5891 rhs = gfc_get_expr ();
5892 rhs->expr_type = EXPR_VARIABLE;
5893 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5897 else if (expr2->expr_type == EXPR_NULL)
5898 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5902 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5903 gfc_add_expr_to_block (&block, tmp);
5905 gfc_free_expr (lhs);
5906 gfc_free_expr (rhs);
5909 /* Do the actual CLASS assignment. */
5910 if (expr2->ts.type == BT_CLASS)
5913 gfc_add_component_ref (expr1, "$data");
5915 if (op == EXEC_ASSIGN)
5916 tmp = gfc_trans_assignment (expr1, expr2, false, true);
5917 else if (op == EXEC_POINTER_ASSIGN)
5918 tmp = gfc_trans_pointer_assignment (expr1, expr2);
5922 gfc_add_expr_to_block (&block, tmp);
5924 return gfc_finish_block (&block);