1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
56 dest->loop = src->loop;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se * se, gfc_se * parent)
69 memset (se, 0, sizeof (gfc_se));
70 gfc_init_block (&se->pre);
71 gfc_init_block (&se->post);
76 gfc_copy_se_loopvars (se, parent);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se * se)
89 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se * se)
113 if (CONSTANT_CLASS_P (se->expr))
116 /* We need a temporary for this result. */
117 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118 gfc_add_modify (&se->pre, var, se->expr);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol * sym)
131 gcc_assert (sym->attr.dummy);
133 decl = gfc_get_symbol_decl (sym);
134 if (TREE_CODE (decl) != PARM_DECL)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
142 return fold_build2 (NE_EXPR, boolean_type_node, decl,
143 fold_convert (TREE_TYPE (decl), null_pointer_node));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
159 /* Create a temporary and convert it to the correct type. */
160 tmp = gfc_get_int_type (kind);
161 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
164 /* Test for a NULL value. */
165 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
166 fold_convert (TREE_TYPE (tmp), integer_one_node));
167 tmp = gfc_evaluate_now (tmp, &se->pre);
168 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
172 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
173 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
174 tmp = gfc_evaluate_now (tmp, &se->pre);
178 if (ts.type == BT_CHARACTER)
180 tmp = build_int_cst (gfc_charlen_type_node, 0);
181 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
182 present, se->string_length, tmp);
183 tmp = gfc_evaluate_now (tmp, &se->pre);
184 se->string_length = tmp;
190 /* Get the character length of an expression, looking through gfc_refs
194 gfc_get_expr_charlen (gfc_expr *e)
199 gcc_assert (e->expr_type == EXPR_VARIABLE
200 && e->ts.type == BT_CHARACTER);
202 length = NULL; /* To silence compiler warning. */
204 if (is_subref_array (e) && e->ts.u.cl->length)
207 gfc_init_se (&tmpse, NULL);
208 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
209 e->ts.u.cl->backend_decl = tmpse.expr;
213 /* First candidate: if the variable is of type CHARACTER, the
214 expression's length could be the length of the character
216 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
217 length = e->symtree->n.sym->ts.u.cl->backend_decl;
219 /* Look through the reference chain for component references. */
220 for (r = e->ref; r; r = r->next)
225 if (r->u.c.component->ts.type == BT_CHARACTER)
226 length = r->u.c.component->ts.u.cl->backend_decl;
234 /* We should never got substring references here. These will be
235 broken down by the scalarizer. */
241 gcc_assert (length != NULL);
246 /* For each character array constructor subexpression without a ts.u.cl->length,
247 replace it by its first element (if there aren't any elements, the length
248 should already be set to zero). */
251 flatten_array_ctors_without_strlen (gfc_expr* e)
253 gfc_actual_arglist* arg;
259 switch (e->expr_type)
263 flatten_array_ctors_without_strlen (e->value.op.op1);
264 flatten_array_ctors_without_strlen (e->value.op.op2);
268 /* TODO: Implement as with EXPR_FUNCTION when needed. */
272 for (arg = e->value.function.actual; arg; arg = arg->next)
273 flatten_array_ctors_without_strlen (arg->expr);
278 /* We've found what we're looking for. */
279 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
282 gcc_assert (e->value.constructor);
284 new_expr = e->value.constructor->expr;
285 e->value.constructor->expr = NULL;
287 flatten_array_ctors_without_strlen (new_expr);
288 gfc_replace_expr (e, new_expr);
292 /* Otherwise, fall through to handle constructor elements. */
294 for (c = e->value.constructor; c; c = c->next)
295 flatten_array_ctors_without_strlen (c->expr);
305 /* Generate code to initialize a string length variable. Returns the
306 value. For array constructors, cl->length might be NULL and in this case,
307 the first element of the constructor is needed. expr is the original
308 expression so we can access it but can be NULL if this is not needed. */
311 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
315 gfc_init_se (&se, NULL);
317 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
318 "flatten" array constructors by taking their first element; all elements
319 should be the same length or a cl->length should be present. */
325 expr_flat = gfc_copy_expr (expr);
326 flatten_array_ctors_without_strlen (expr_flat);
327 gfc_resolve_expr (expr_flat);
329 gfc_conv_expr (&se, expr_flat);
330 gfc_add_block_to_block (pblock, &se.pre);
331 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
333 gfc_free_expr (expr_flat);
337 /* Convert cl->length. */
339 gcc_assert (cl->length);
341 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
342 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
343 build_int_cst (gfc_charlen_type_node, 0));
344 gfc_add_block_to_block (pblock, &se.pre);
346 if (cl->backend_decl)
347 gfc_add_modify (pblock, cl->backend_decl, se.expr);
349 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
354 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
355 const char *name, locus *where)
365 type = gfc_get_character_type (kind, ref->u.ss.length);
366 type = build_pointer_type (type);
369 gfc_init_se (&start, se);
370 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
371 gfc_add_block_to_block (&se->pre, &start.pre);
373 if (integer_onep (start.expr))
374 gfc_conv_string_parameter (se);
379 /* Avoid multiple evaluation of substring start. */
380 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
381 start.expr = gfc_evaluate_now (start.expr, &se->pre);
383 /* Change the start of the string. */
384 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
387 tmp = build_fold_indirect_ref_loc (input_location,
389 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
390 se->expr = gfc_build_addr_expr (type, tmp);
393 /* Length = end + 1 - start. */
394 gfc_init_se (&end, se);
395 if (ref->u.ss.end == NULL)
396 end.expr = se->string_length;
399 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
400 gfc_add_block_to_block (&se->pre, &end.pre);
404 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
405 end.expr = gfc_evaluate_now (end.expr, &se->pre);
407 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
409 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
410 start.expr, end.expr);
412 /* Check lower bound. */
413 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
414 build_int_cst (gfc_charlen_type_node, 1));
415 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
418 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
419 "is less than one", name);
421 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
423 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
424 fold_convert (long_integer_type_node,
428 /* Check upper bound. */
429 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
431 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
434 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
435 "exceeds string length (%%ld)", name);
437 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
438 "exceeds string length (%%ld)");
439 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
440 fold_convert (long_integer_type_node, end.expr),
441 fold_convert (long_integer_type_node,
446 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
447 end.expr, start.expr);
448 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
449 build_int_cst (gfc_charlen_type_node, 1), tmp);
450 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
451 build_int_cst (gfc_charlen_type_node, 0));
452 se->string_length = tmp;
456 /* Convert a derived type component reference. */
459 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
466 c = ref->u.c.component;
468 gcc_assert (c->backend_decl);
470 field = c->backend_decl;
471 gcc_assert (TREE_CODE (field) == FIELD_DECL);
473 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
477 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
479 tmp = c->ts.u.cl->backend_decl;
480 /* Components must always be constant length. */
481 gcc_assert (tmp && INTEGER_CST_P (tmp));
482 se->string_length = tmp;
485 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
486 && c->ts.type != BT_CHARACTER)
487 || c->attr.proc_pointer)
488 se->expr = build_fold_indirect_ref_loc (input_location,
493 /* This function deals with component references to components of the
494 parent type for derived type extensons. */
496 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
504 c = ref->u.c.component;
506 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
507 parent.type = REF_COMPONENT;
510 parent.u.c.component = dt->components;
512 if (dt->attr.extension && dt->components)
514 if (dt->attr.is_class)
515 cmp = dt->components;
517 cmp = dt->components->next;
518 /* Return if the component is not in the parent type. */
519 for (; cmp; cmp = cmp->next)
520 if (strcmp (c->name, cmp->name) == 0)
523 /* Otherwise build the reference and call self. */
524 gfc_conv_component_ref (se, &parent);
525 parent.u.c.sym = dt->components->ts.u.derived;
526 parent.u.c.component = c;
527 conv_parent_component_references (se, &parent);
531 /* Return the contents of a variable. Also handles reference/pointer
532 variables (all Fortran pointer references are implicit). */
535 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
542 bool alternate_entry;
545 sym = expr->symtree->n.sym;
548 /* Check that something hasn't gone horribly wrong. */
549 gcc_assert (se->ss != gfc_ss_terminator);
550 gcc_assert (se->ss->expr == expr);
552 /* A scalarized term. We already know the descriptor. */
553 se->expr = se->ss->data.info.descriptor;
554 se->string_length = se->ss->string_length;
555 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
556 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
561 tree se_expr = NULL_TREE;
563 se->expr = gfc_get_symbol_decl (sym);
565 /* Deal with references to a parent results or entries by storing
566 the current_function_decl and moving to the parent_decl. */
567 return_value = sym->attr.function && sym->result == sym;
568 alternate_entry = sym->attr.function && sym->attr.entry
569 && sym->result == sym;
570 entry_master = sym->attr.result
571 && sym->ns->proc_name->attr.entry_master
572 && !gfc_return_by_reference (sym->ns->proc_name);
573 parent_decl = DECL_CONTEXT (current_function_decl);
575 if ((se->expr == parent_decl && return_value)
576 || (sym->ns && sym->ns->proc_name
578 && sym->ns->proc_name->backend_decl == parent_decl
579 && (alternate_entry || entry_master)))
584 /* Special case for assigning the return value of a function.
585 Self recursive functions must have an explicit return value. */
586 if (return_value && (se->expr == current_function_decl || parent_flag))
587 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
589 /* Similarly for alternate entry points. */
590 else if (alternate_entry
591 && (sym->ns->proc_name->backend_decl == current_function_decl
594 gfc_entry_list *el = NULL;
596 for (el = sym->ns->entries; el; el = el->next)
599 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
604 else if (entry_master
605 && (sym->ns->proc_name->backend_decl == current_function_decl
607 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
612 /* Procedure actual arguments. */
613 else if (sym->attr.flavor == FL_PROCEDURE
614 && se->expr != current_function_decl)
616 if (!sym->attr.dummy && !sym->attr.proc_pointer)
618 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
619 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
625 /* Dereference the expression, where needed. Since characters
626 are entirely different from other types, they are treated
628 if (sym->ts.type == BT_CHARACTER)
630 /* Dereference character pointer dummy arguments
632 if ((sym->attr.pointer || sym->attr.allocatable)
634 || sym->attr.function
635 || sym->attr.result))
636 se->expr = build_fold_indirect_ref_loc (input_location,
640 else if (!sym->attr.value)
642 /* Dereference non-character scalar dummy arguments. */
643 if (sym->attr.dummy && !sym->attr.dimension)
644 se->expr = build_fold_indirect_ref_loc (input_location,
647 /* Dereference scalar hidden result. */
648 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
649 && (sym->attr.function || sym->attr.result)
650 && !sym->attr.dimension && !sym->attr.pointer
651 && !sym->attr.always_explicit)
652 se->expr = build_fold_indirect_ref_loc (input_location,
655 /* Dereference non-character pointer variables.
656 These must be dummies, results, or scalars. */
657 if ((sym->attr.pointer || sym->attr.allocatable)
659 || sym->attr.function
661 || !sym->attr.dimension))
662 se->expr = build_fold_indirect_ref_loc (input_location,
669 /* For character variables, also get the length. */
670 if (sym->ts.type == BT_CHARACTER)
672 /* If the character length of an entry isn't set, get the length from
673 the master function instead. */
674 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
675 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
677 se->string_length = sym->ts.u.cl->backend_decl;
678 gcc_assert (se->string_length);
686 /* Return the descriptor if that's what we want and this is an array
687 section reference. */
688 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
690 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
691 /* Return the descriptor for array pointers and allocations. */
693 && ref->next == NULL && (se->descriptor_only))
696 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
697 /* Return a pointer to an element. */
701 if (ref->u.c.sym->attr.extension)
702 conv_parent_component_references (se, ref);
704 gfc_conv_component_ref (se, ref);
708 gfc_conv_substring (se, ref, expr->ts.kind,
709 expr->symtree->name, &expr->where);
718 /* Pointer assignment, allocation or pass by reference. Arrays are handled
720 if (se->want_pointer)
722 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
723 gfc_conv_string_parameter (se);
725 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
730 /* Unary ops are easy... Or they would be if ! was a valid op. */
733 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
738 gcc_assert (expr->ts.type != BT_CHARACTER);
739 /* Initialize the operand. */
740 gfc_init_se (&operand, se);
741 gfc_conv_expr_val (&operand, expr->value.op.op1);
742 gfc_add_block_to_block (&se->pre, &operand.pre);
744 type = gfc_typenode_for_spec (&expr->ts);
746 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
747 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
748 All other unary operators have an equivalent GIMPLE unary operator. */
749 if (code == TRUTH_NOT_EXPR)
750 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
751 build_int_cst (type, 0));
753 se->expr = fold_build1 (code, type, operand.expr);
757 /* Expand power operator to optimal multiplications when a value is raised
758 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
759 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
760 Programming", 3rd Edition, 1998. */
762 /* This code is mostly duplicated from expand_powi in the backend.
763 We establish the "optimal power tree" lookup table with the defined size.
764 The items in the table are the exponents used to calculate the index
765 exponents. Any integer n less than the value can get an "addition chain",
766 with the first node being one. */
767 #define POWI_TABLE_SIZE 256
769 /* The table is from builtins.c. */
770 static const unsigned char powi_table[POWI_TABLE_SIZE] =
772 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
773 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
774 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
775 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
776 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
777 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
778 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
779 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
780 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
781 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
782 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
783 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
784 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
785 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
786 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
787 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
788 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
789 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
790 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
791 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
792 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
793 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
794 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
795 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
796 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
797 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
798 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
799 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
800 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
801 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
802 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
803 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
806 /* If n is larger than lookup table's max index, we use the "window
808 #define POWI_WINDOW_SIZE 3
810 /* Recursive function to expand the power operator. The temporary
811 values are put in tmpvar. The function returns tmpvar[1] ** n. */
813 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
820 if (n < POWI_TABLE_SIZE)
825 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
826 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
830 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
831 op0 = gfc_conv_powi (se, n - digit, tmpvar);
832 op1 = gfc_conv_powi (se, digit, tmpvar);
836 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
840 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
841 tmp = gfc_evaluate_now (tmp, &se->pre);
843 if (n < POWI_TABLE_SIZE)
850 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
851 return 1. Else return 0 and a call to runtime library functions
852 will have to be built. */
854 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
859 tree vartmp[POWI_TABLE_SIZE];
861 unsigned HOST_WIDE_INT n;
864 /* If exponent is too large, we won't expand it anyway, so don't bother
865 with large integer values. */
866 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
869 m = double_int_to_shwi (TREE_INT_CST (rhs));
870 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
871 of the asymmetric range of the integer type. */
872 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
874 type = TREE_TYPE (lhs);
875 sgn = tree_int_cst_sgn (rhs);
877 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
878 || optimize_size) && (m > 2 || m < -1))
884 se->expr = gfc_build_const (type, integer_one_node);
888 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
889 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
891 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
892 lhs, build_int_cst (TREE_TYPE (lhs), -1));
893 cond = fold_build2 (EQ_EXPR, boolean_type_node,
894 lhs, build_int_cst (TREE_TYPE (lhs), 1));
897 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
900 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
901 se->expr = fold_build3 (COND_EXPR, type,
902 tmp, build_int_cst (type, 1),
903 build_int_cst (type, 0));
907 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
908 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
909 build_int_cst (type, 0));
910 se->expr = fold_build3 (COND_EXPR, type,
911 cond, build_int_cst (type, 1), tmp);
915 memset (vartmp, 0, sizeof (vartmp));
919 tmp = gfc_build_const (type, integer_one_node);
920 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
923 se->expr = gfc_conv_powi (se, n, vartmp);
929 /* Power op (**). Constant integer exponent has special handling. */
932 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
934 tree gfc_int4_type_node;
941 gfc_init_se (&lse, se);
942 gfc_conv_expr_val (&lse, expr->value.op.op1);
943 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
944 gfc_add_block_to_block (&se->pre, &lse.pre);
946 gfc_init_se (&rse, se);
947 gfc_conv_expr_val (&rse, expr->value.op.op2);
948 gfc_add_block_to_block (&se->pre, &rse.pre);
950 if (expr->value.op.op2->ts.type == BT_INTEGER
951 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
952 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
955 gfc_int4_type_node = gfc_get_int_type (4);
957 kind = expr->value.op.op1->ts.kind;
958 switch (expr->value.op.op2->ts.type)
961 ikind = expr->value.op.op2->ts.kind;
966 rse.expr = convert (gfc_int4_type_node, rse.expr);
988 if (expr->value.op.op1->ts.type == BT_INTEGER)
989 lse.expr = convert (gfc_int4_type_node, lse.expr);
1014 switch (expr->value.op.op1->ts.type)
1017 if (kind == 3) /* Case 16 was not handled properly above. */
1019 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1023 /* Use builtins for real ** int4. */
1029 fndecl = built_in_decls[BUILT_IN_POWIF];
1033 fndecl = built_in_decls[BUILT_IN_POWI];
1038 fndecl = built_in_decls[BUILT_IN_POWIL];
1046 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1050 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1062 fndecl = built_in_decls[BUILT_IN_POWF];
1065 fndecl = built_in_decls[BUILT_IN_POW];
1069 fndecl = built_in_decls[BUILT_IN_POWL];
1080 fndecl = built_in_decls[BUILT_IN_CPOWF];
1083 fndecl = built_in_decls[BUILT_IN_CPOW];
1087 fndecl = built_in_decls[BUILT_IN_CPOWL];
1099 se->expr = build_call_expr_loc (input_location,
1100 fndecl, 2, lse.expr, rse.expr);
1104 /* Generate code to allocate a string temporary. */
1107 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1112 gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
1114 if (gfc_can_put_var_on_stack (len))
1116 /* Create a temporary variable to hold the result. */
1117 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1118 build_int_cst (gfc_charlen_type_node, 1));
1119 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1121 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1122 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1124 tmp = build_array_type (TREE_TYPE (type), tmp);
1126 var = gfc_create_var (tmp, "str");
1127 var = gfc_build_addr_expr (type, var);
1131 /* Allocate a temporary to hold the result. */
1132 var = gfc_create_var (type, "pstr");
1133 tmp = gfc_call_malloc (&se->pre, type,
1134 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1135 fold_convert (TREE_TYPE (len),
1136 TYPE_SIZE (type))));
1137 gfc_add_modify (&se->pre, var, tmp);
1139 /* Free the temporary afterwards. */
1140 tmp = gfc_call_free (convert (pvoid_type_node, var));
1141 gfc_add_expr_to_block (&se->post, tmp);
1148 /* Handle a string concatenation operation. A temporary will be allocated to
1152 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1155 tree len, type, var, tmp, fndecl;
1157 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1158 && expr->value.op.op2->ts.type == BT_CHARACTER);
1159 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1161 gfc_init_se (&lse, se);
1162 gfc_conv_expr (&lse, expr->value.op.op1);
1163 gfc_conv_string_parameter (&lse);
1164 gfc_init_se (&rse, se);
1165 gfc_conv_expr (&rse, expr->value.op.op2);
1166 gfc_conv_string_parameter (&rse);
1168 gfc_add_block_to_block (&se->pre, &lse.pre);
1169 gfc_add_block_to_block (&se->pre, &rse.pre);
1171 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1172 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1173 if (len == NULL_TREE)
1175 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1176 lse.string_length, rse.string_length);
1179 type = build_pointer_type (type);
1181 var = gfc_conv_string_tmp (se, type, len);
1183 /* Do the actual concatenation. */
1184 if (expr->ts.kind == 1)
1185 fndecl = gfor_fndecl_concat_string;
1186 else if (expr->ts.kind == 4)
1187 fndecl = gfor_fndecl_concat_string_char4;
1191 tmp = build_call_expr_loc (input_location,
1192 fndecl, 6, len, var, lse.string_length, lse.expr,
1193 rse.string_length, rse.expr);
1194 gfc_add_expr_to_block (&se->pre, tmp);
1196 /* Add the cleanup for the operands. */
1197 gfc_add_block_to_block (&se->pre, &rse.post);
1198 gfc_add_block_to_block (&se->pre, &lse.post);
1201 se->string_length = len;
1204 /* Translates an op expression. Common (binary) cases are handled by this
1205 function, others are passed on. Recursion is used in either case.
1206 We use the fact that (op1.ts == op2.ts) (except for the power
1208 Operators need no special handling for scalarized expressions as long as
1209 they call gfc_conv_simple_val to get their operands.
1210 Character strings get special handling. */
1213 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1215 enum tree_code code;
1224 switch (expr->value.op.op)
1226 case INTRINSIC_PARENTHESES:
1227 if (expr->ts.type == BT_REAL
1228 || expr->ts.type == BT_COMPLEX)
1230 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1231 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1236 case INTRINSIC_UPLUS:
1237 gfc_conv_expr (se, expr->value.op.op1);
1240 case INTRINSIC_UMINUS:
1241 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1245 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1248 case INTRINSIC_PLUS:
1252 case INTRINSIC_MINUS:
1256 case INTRINSIC_TIMES:
1260 case INTRINSIC_DIVIDE:
1261 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1262 an integer, we must round towards zero, so we use a
1264 if (expr->ts.type == BT_INTEGER)
1265 code = TRUNC_DIV_EXPR;
1270 case INTRINSIC_POWER:
1271 gfc_conv_power_op (se, expr);
1274 case INTRINSIC_CONCAT:
1275 gfc_conv_concat_op (se, expr);
1279 code = TRUTH_ANDIF_EXPR;
1284 code = TRUTH_ORIF_EXPR;
1288 /* EQV and NEQV only work on logicals, but since we represent them
1289 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1291 case INTRINSIC_EQ_OS:
1299 case INTRINSIC_NE_OS:
1300 case INTRINSIC_NEQV:
1307 case INTRINSIC_GT_OS:
1314 case INTRINSIC_GE_OS:
1321 case INTRINSIC_LT_OS:
1328 case INTRINSIC_LE_OS:
1334 case INTRINSIC_USER:
1335 case INTRINSIC_ASSIGN:
1336 /* These should be converted into function calls by the frontend. */
1340 fatal_error ("Unknown intrinsic op");
1344 /* The only exception to this is **, which is handled separately anyway. */
1345 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1347 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1351 gfc_init_se (&lse, se);
1352 gfc_conv_expr (&lse, expr->value.op.op1);
1353 gfc_add_block_to_block (&se->pre, &lse.pre);
1356 gfc_init_se (&rse, se);
1357 gfc_conv_expr (&rse, expr->value.op.op2);
1358 gfc_add_block_to_block (&se->pre, &rse.pre);
1362 gfc_conv_string_parameter (&lse);
1363 gfc_conv_string_parameter (&rse);
1365 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1366 rse.string_length, rse.expr,
1367 expr->value.op.op1->ts.kind);
1368 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1369 gfc_add_block_to_block (&lse.post, &rse.post);
1372 type = gfc_typenode_for_spec (&expr->ts);
1376 /* The result of logical ops is always boolean_type_node. */
1377 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1378 se->expr = convert (type, tmp);
1381 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1383 /* Add the post blocks. */
1384 gfc_add_block_to_block (&se->post, &rse.post);
1385 gfc_add_block_to_block (&se->post, &lse.post);
1388 /* If a string's length is one, we convert it to a single character. */
1391 string_to_single_character (tree len, tree str, int kind)
1393 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1395 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1396 && TREE_INT_CST_HIGH (len) == 0)
1398 str = fold_convert (gfc_get_pchar_type (kind), str);
1399 return build_fold_indirect_ref_loc (input_location,
1408 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1411 if (sym->backend_decl)
1413 /* This becomes the nominal_type in
1414 function.c:assign_parm_find_data_types. */
1415 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1416 /* This becomes the passed_type in
1417 function.c:assign_parm_find_data_types. C promotes char to
1418 integer for argument passing. */
1419 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1421 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1426 /* If we have a constant character expression, make it into an
1428 if ((*expr)->expr_type == EXPR_CONSTANT)
1433 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1434 if ((*expr)->ts.kind != gfc_c_int_kind)
1436 /* The expr needs to be compatible with a C int. If the
1437 conversion fails, then the 2 causes an ICE. */
1438 ts.type = BT_INTEGER;
1439 ts.kind = gfc_c_int_kind;
1440 gfc_convert_type (*expr, &ts, 2);
1443 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1445 if ((*expr)->ref == NULL)
1447 se->expr = string_to_single_character
1448 (build_int_cst (integer_type_node, 1),
1449 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1451 ((*expr)->symtree->n.sym)),
1456 gfc_conv_variable (se, *expr);
1457 se->expr = string_to_single_character
1458 (build_int_cst (integer_type_node, 1),
1459 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1468 /* Compare two strings. If they are all single characters, the result is the
1469 subtraction of them. Otherwise, we build a library call. */
1472 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1478 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1479 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1481 sc1 = string_to_single_character (len1, str1, kind);
1482 sc2 = string_to_single_character (len2, str2, kind);
1484 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1486 /* Deal with single character specially. */
1487 sc1 = fold_convert (integer_type_node, sc1);
1488 sc2 = fold_convert (integer_type_node, sc2);
1489 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1493 /* Build a call for the comparison. */
1497 fndecl = gfor_fndecl_compare_string;
1499 fndecl = gfor_fndecl_compare_string_char4;
1503 tmp = build_call_expr_loc (input_location,
1504 fndecl, 4, len1, str1, len2, str2);
1511 /* Return the backend_decl for a procedure pointer component. */
1514 get_proc_ptr_comp (gfc_expr *e)
1518 gfc_init_se (&comp_se, NULL);
1519 e2 = gfc_copy_expr (e);
1520 e2->expr_type = EXPR_VARIABLE;
1521 gfc_conv_expr (&comp_se, e2);
1523 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1527 /* Select a class typebound procedure at runtime. */
1529 select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
1530 tree declared, locus *where)
1537 gfc_class_esym_list *next_elist, *tmp_elist;
1539 /* Calculate the switch expression: class_object.vindex. */
1540 gcc_assert (elist->class_object->ts.type == BT_CLASS);
1541 tmp = elist->class_object->ts.u.derived->components->next->backend_decl;
1542 vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
1543 elist->class_object->backend_decl,
1545 vindex = gfc_evaluate_now (vindex, &se->pre);
1547 /* Fix the function type to be that of the declared type. */
1548 declared = gfc_create_var (TREE_TYPE (declared), "method");
1550 end_label = gfc_build_label_decl (NULL_TREE);
1552 gfc_init_block (&body);
1554 /* Go through the list of extensions. */
1555 for (; elist; elist = next_elist)
1557 /* This case has already been added. */
1558 if (elist->derived == NULL)
1561 /* Run through the chain picking up all the cases that call the
1564 for (; elist; elist = elist->next)
1568 if (elist->esym != tmp_elist->esym)
1571 cval = build_int_cst (TREE_TYPE (vindex),
1572 elist->derived->vindex);
1573 /* Build a label for the vindex value. */
1574 label = gfc_build_label_decl (NULL_TREE);
1575 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1576 cval, NULL_TREE, label);
1577 gfc_add_expr_to_block (&body, tmp);
1579 /* Null the reference the derived type so that this case is
1581 elist->derived = NULL;
1586 /* Get a pointer to the procedure, */
1587 tmp = gfc_get_symbol_decl (elist->esym);
1588 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1590 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1591 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1594 /* Assign the pointer to the appropriate procedure. */
1595 gfc_add_modify (&body, declared,
1596 fold_convert (TREE_TYPE (declared), tmp));
1598 /* Break to the end of the construct. */
1599 tmp = build1_v (GOTO_EXPR, end_label);
1600 gfc_add_expr_to_block (&body, tmp);
1602 /* Free the elists as we go; freeing them in gfc_free_expr causes
1603 segfaults because it occurs too early and too often. */
1605 next_elist = elist->next;
1610 /* Default is an error. */
1611 label = gfc_build_label_decl (NULL_TREE);
1612 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1613 NULL_TREE, NULL_TREE, label);
1614 gfc_add_expr_to_block (&body, tmp);
1615 tmp = gfc_trans_runtime_error (true, where,
1616 "internal error: bad vindex in dynamic dispatch");
1617 gfc_add_expr_to_block (&body, tmp);
1619 /* Write the switch expression. */
1620 tmp = gfc_finish_block (&body);
1621 tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
1622 gfc_add_expr_to_block (&se->pre, tmp);
1624 tmp = build1_v (LABEL_EXPR, end_label);
1625 gfc_add_expr_to_block (&se->pre, tmp);
1627 se->expr = declared;
1633 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1637 if (expr && expr->symtree
1638 && expr->value.function.class_esym)
1640 if (!sym->backend_decl)
1641 sym->backend_decl = gfc_get_extern_function_decl (sym);
1643 tmp = sym->backend_decl;
1645 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1647 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1648 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1651 select_class_proc (se, expr->value.function.class_esym,
1656 if (gfc_is_proc_ptr_comp (expr, NULL))
1657 tmp = get_proc_ptr_comp (expr);
1658 else if (sym->attr.dummy)
1660 tmp = gfc_get_symbol_decl (sym);
1661 if (sym->attr.proc_pointer)
1662 tmp = build_fold_indirect_ref_loc (input_location,
1664 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1665 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1669 if (!sym->backend_decl)
1670 sym->backend_decl = gfc_get_extern_function_decl (sym);
1672 tmp = sym->backend_decl;
1674 if (sym->attr.cray_pointee)
1676 /* TODO - make the cray pointee a pointer to a procedure,
1677 assign the pointer to it and use it for the call. This
1679 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1680 gfc_get_symbol_decl (sym->cp_pointer));
1681 tmp = gfc_evaluate_now (tmp, &se->pre);
1684 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1686 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1687 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1694 /* Initialize MAPPING. */
1697 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1699 mapping->syms = NULL;
1700 mapping->charlens = NULL;
1704 /* Free all memory held by MAPPING (but not MAPPING itself). */
1707 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1709 gfc_interface_sym_mapping *sym;
1710 gfc_interface_sym_mapping *nextsym;
1712 gfc_charlen *nextcl;
1714 for (sym = mapping->syms; sym; sym = nextsym)
1716 nextsym = sym->next;
1717 sym->new_sym->n.sym->formal = NULL;
1718 gfc_free_symbol (sym->new_sym->n.sym);
1719 gfc_free_expr (sym->expr);
1720 gfc_free (sym->new_sym);
1723 for (cl = mapping->charlens; cl; cl = nextcl)
1726 gfc_free_expr (cl->length);
1732 /* Return a copy of gfc_charlen CL. Add the returned structure to
1733 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1735 static gfc_charlen *
1736 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1739 gfc_charlen *new_charlen;
1741 new_charlen = gfc_get_charlen ();
1742 new_charlen->next = mapping->charlens;
1743 new_charlen->length = gfc_copy_expr (cl->length);
1745 mapping->charlens = new_charlen;
1750 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1751 array variable that can be used as the actual argument for dummy
1752 argument SYM. Add any initialization code to BLOCK. PACKED is as
1753 for gfc_get_nodesc_array_type and DATA points to the first element
1754 in the passed array. */
1757 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1758 gfc_packed packed, tree data)
1763 type = gfc_typenode_for_spec (&sym->ts);
1764 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1765 !sym->attr.target && !sym->attr.pointer
1766 && !sym->attr.proc_pointer);
1768 var = gfc_create_var (type, "ifm");
1769 gfc_add_modify (block, var, fold_convert (type, data));
1775 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1776 and offset of descriptorless array type TYPE given that it has the same
1777 size as DESC. Add any set-up code to BLOCK. */
1780 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1787 offset = gfc_index_zero_node;
1788 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1790 dim = gfc_rank_cst[n];
1791 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1792 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1794 GFC_TYPE_ARRAY_LBOUND (type, n)
1795 = gfc_conv_descriptor_lbound_get (desc, dim);
1796 GFC_TYPE_ARRAY_UBOUND (type, n)
1797 = gfc_conv_descriptor_ubound_get (desc, dim);
1799 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1801 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1802 gfc_conv_descriptor_ubound_get (desc, dim),
1803 gfc_conv_descriptor_lbound_get (desc, dim));
1804 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1805 GFC_TYPE_ARRAY_LBOUND (type, n),
1807 tmp = gfc_evaluate_now (tmp, block);
1808 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1810 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1811 GFC_TYPE_ARRAY_LBOUND (type, n),
1812 GFC_TYPE_ARRAY_STRIDE (type, n));
1813 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1815 offset = gfc_evaluate_now (offset, block);
1816 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1820 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1821 in SE. The caller may still use se->expr and se->string_length after
1822 calling this function. */
1825 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1826 gfc_symbol * sym, gfc_se * se,
1829 gfc_interface_sym_mapping *sm;
1833 gfc_symbol *new_sym;
1835 gfc_symtree *new_symtree;
1837 /* Create a new symbol to represent the actual argument. */
1838 new_sym = gfc_new_symbol (sym->name, NULL);
1839 new_sym->ts = sym->ts;
1840 new_sym->as = gfc_copy_array_spec (sym->as);
1841 new_sym->attr.referenced = 1;
1842 new_sym->attr.dimension = sym->attr.dimension;
1843 new_sym->attr.pointer = sym->attr.pointer;
1844 new_sym->attr.allocatable = sym->attr.allocatable;
1845 new_sym->attr.flavor = sym->attr.flavor;
1846 new_sym->attr.function = sym->attr.function;
1848 /* Ensure that the interface is available and that
1849 descriptors are passed for array actual arguments. */
1850 if (sym->attr.flavor == FL_PROCEDURE)
1852 new_sym->formal = expr->symtree->n.sym->formal;
1853 new_sym->attr.always_explicit
1854 = expr->symtree->n.sym->attr.always_explicit;
1857 /* Create a fake symtree for it. */
1859 new_symtree = gfc_new_symtree (&root, sym->name);
1860 new_symtree->n.sym = new_sym;
1861 gcc_assert (new_symtree == root);
1863 /* Create a dummy->actual mapping. */
1864 sm = XCNEW (gfc_interface_sym_mapping);
1865 sm->next = mapping->syms;
1867 sm->new_sym = new_symtree;
1868 sm->expr = gfc_copy_expr (expr);
1871 /* Stabilize the argument's value. */
1872 if (!sym->attr.function && se)
1873 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1875 if (sym->ts.type == BT_CHARACTER)
1877 /* Create a copy of the dummy argument's length. */
1878 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1879 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1881 /* If the length is specified as "*", record the length that
1882 the caller is passing. We should use the callee's length
1883 in all other cases. */
1884 if (!new_sym->ts.u.cl->length && se)
1886 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1887 new_sym->ts.u.cl->backend_decl = se->string_length;
1894 /* Use the passed value as-is if the argument is a function. */
1895 if (sym->attr.flavor == FL_PROCEDURE)
1898 /* If the argument is either a string or a pointer to a string,
1899 convert it to a boundless character type. */
1900 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1902 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1903 tmp = build_pointer_type (tmp);
1904 if (sym->attr.pointer)
1905 value = build_fold_indirect_ref_loc (input_location,
1909 value = fold_convert (tmp, value);
1912 /* If the argument is a scalar, a pointer to an array or an allocatable,
1914 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1915 value = build_fold_indirect_ref_loc (input_location,
1918 /* For character(*), use the actual argument's descriptor. */
1919 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1920 value = build_fold_indirect_ref_loc (input_location,
1923 /* If the argument is an array descriptor, use it to determine
1924 information about the actual argument's shape. */
1925 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1926 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1928 /* Get the actual argument's descriptor. */
1929 desc = build_fold_indirect_ref_loc (input_location,
1932 /* Create the replacement variable. */
1933 tmp = gfc_conv_descriptor_data_get (desc);
1934 value = gfc_get_interface_mapping_array (&se->pre, sym,
1937 /* Use DESC to work out the upper bounds, strides and offset. */
1938 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1941 /* Otherwise we have a packed array. */
1942 value = gfc_get_interface_mapping_array (&se->pre, sym,
1943 PACKED_FULL, se->expr);
1945 new_sym->backend_decl = value;
1949 /* Called once all dummy argument mappings have been added to MAPPING,
1950 but before the mapping is used to evaluate expressions. Pre-evaluate
1951 the length of each argument, adding any initialization code to PRE and
1952 any finalization code to POST. */
1955 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1956 stmtblock_t * pre, stmtblock_t * post)
1958 gfc_interface_sym_mapping *sym;
1962 for (sym = mapping->syms; sym; sym = sym->next)
1963 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1964 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1966 expr = sym->new_sym->n.sym->ts.u.cl->length;
1967 gfc_apply_interface_mapping_to_expr (mapping, expr);
1968 gfc_init_se (&se, NULL);
1969 gfc_conv_expr (&se, expr);
1970 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1971 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1972 gfc_add_block_to_block (pre, &se.pre);
1973 gfc_add_block_to_block (post, &se.post);
1975 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1980 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1984 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1985 gfc_constructor * c)
1987 for (; c; c = c->next)
1989 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1992 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1993 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1994 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2000 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2004 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2009 for (; ref; ref = ref->next)
2013 for (n = 0; n < ref->u.ar.dimen; n++)
2015 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2016 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2017 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2019 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2026 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2027 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2033 /* Convert intrinsic function calls into result expressions. */
2036 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2044 arg1 = expr->value.function.actual->expr;
2045 if (expr->value.function.actual->next)
2046 arg2 = expr->value.function.actual->next->expr;
2050 sym = arg1->symtree->n.sym;
2052 if (sym->attr.dummy)
2057 switch (expr->value.function.isym->id)
2060 /* TODO figure out why this condition is necessary. */
2061 if (sym->attr.function
2062 && (arg1->ts.u.cl->length == NULL
2063 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2064 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2067 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2074 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2076 dup = mpz_get_si (arg2->value.integer);
2081 dup = sym->as->rank;
2085 for (; d < dup; d++)
2089 if (!sym->as->upper[d] || !sym->as->lower[d])
2091 gfc_free_expr (new_expr);
2095 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
2096 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2098 new_expr = gfc_multiply (new_expr, tmp);
2104 case GFC_ISYM_LBOUND:
2105 case GFC_ISYM_UBOUND:
2106 /* TODO These implementations of lbound and ubound do not limit if
2107 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2112 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2113 d = mpz_get_si (arg2->value.integer) - 1;
2115 /* TODO: If the need arises, this could produce an array of
2119 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2121 if (sym->as->lower[d])
2122 new_expr = gfc_copy_expr (sym->as->lower[d]);
2126 if (sym->as->upper[d])
2127 new_expr = gfc_copy_expr (sym->as->upper[d]);
2135 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2139 gfc_replace_expr (expr, new_expr);
2145 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2146 gfc_interface_mapping * mapping)
2148 gfc_formal_arglist *f;
2149 gfc_actual_arglist *actual;
2151 actual = expr->value.function.actual;
2152 f = map_expr->symtree->n.sym->formal;
2154 for (; f && actual; f = f->next, actual = actual->next)
2159 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2162 if (map_expr->symtree->n.sym->attr.dimension)
2167 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2169 for (d = 0; d < as->rank; d++)
2171 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2172 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2175 expr->value.function.esym->as = as;
2178 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2180 expr->value.function.esym->ts.u.cl->length
2181 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2183 gfc_apply_interface_mapping_to_expr (mapping,
2184 expr->value.function.esym->ts.u.cl->length);
2189 /* EXPR is a copy of an expression that appeared in the interface
2190 associated with MAPPING. Walk it recursively looking for references to
2191 dummy arguments that MAPPING maps to actual arguments. Replace each such
2192 reference with a reference to the associated actual argument. */
2195 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2198 gfc_interface_sym_mapping *sym;
2199 gfc_actual_arglist *actual;
2204 /* Copying an expression does not copy its length, so do that here. */
2205 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2207 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2208 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2211 /* Apply the mapping to any references. */
2212 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2214 /* ...and to the expression's symbol, if it has one. */
2215 /* TODO Find out why the condition on expr->symtree had to be moved into
2216 the loop rather than being outside it, as originally. */
2217 for (sym = mapping->syms; sym; sym = sym->next)
2218 if (expr->symtree && sym->old == expr->symtree->n.sym)
2220 if (sym->new_sym->n.sym->backend_decl)
2221 expr->symtree = sym->new_sym;
2223 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2226 /* ...and to subexpressions in expr->value. */
2227 switch (expr->expr_type)
2232 case EXPR_SUBSTRING:
2236 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2237 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2241 for (actual = expr->value.function.actual; actual; actual = actual->next)
2242 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2244 if (expr->value.function.esym == NULL
2245 && expr->value.function.isym != NULL
2246 && expr->value.function.actual->expr->symtree
2247 && gfc_map_intrinsic_function (expr, mapping))
2250 for (sym = mapping->syms; sym; sym = sym->next)
2251 if (sym->old == expr->value.function.esym)
2253 expr->value.function.esym = sym->new_sym->n.sym;
2254 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2255 expr->value.function.esym->result = sym->new_sym->n.sym;
2260 case EXPR_STRUCTURE:
2261 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2274 /* Evaluate interface expression EXPR using MAPPING. Store the result
2278 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2279 gfc_se * se, gfc_expr * expr)
2281 expr = gfc_copy_expr (expr);
2282 gfc_apply_interface_mapping_to_expr (mapping, expr);
2283 gfc_conv_expr (se, expr);
2284 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2285 gfc_free_expr (expr);
2289 /* Returns a reference to a temporary array into which a component of
2290 an actual argument derived type array is copied and then returned
2291 after the function call. */
2293 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2294 int g77, sym_intent intent)
2310 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2312 gfc_init_se (&lse, NULL);
2313 gfc_init_se (&rse, NULL);
2315 /* Walk the argument expression. */
2316 rss = gfc_walk_expr (expr);
2318 gcc_assert (rss != gfc_ss_terminator);
2320 /* Initialize the scalarizer. */
2321 gfc_init_loopinfo (&loop);
2322 gfc_add_ss_to_loop (&loop, rss);
2324 /* Calculate the bounds of the scalarization. */
2325 gfc_conv_ss_startstride (&loop);
2327 /* Build an ss for the temporary. */
2328 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2329 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2331 base_type = gfc_typenode_for_spec (&expr->ts);
2332 if (GFC_ARRAY_TYPE_P (base_type)
2333 || GFC_DESCRIPTOR_TYPE_P (base_type))
2334 base_type = gfc_get_element_type (base_type);
2336 loop.temp_ss = gfc_get_ss ();;
2337 loop.temp_ss->type = GFC_SS_TEMP;
2338 loop.temp_ss->data.temp.type = base_type;
2340 if (expr->ts.type == BT_CHARACTER)
2341 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2343 loop.temp_ss->string_length = NULL;
2345 parmse->string_length = loop.temp_ss->string_length;
2346 loop.temp_ss->data.temp.dimen = loop.dimen;
2347 loop.temp_ss->next = gfc_ss_terminator;
2349 /* Associate the SS with the loop. */
2350 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2352 /* Setup the scalarizing loops. */
2353 gfc_conv_loop_setup (&loop, &expr->where);
2355 /* Pass the temporary descriptor back to the caller. */
2356 info = &loop.temp_ss->data.info;
2357 parmse->expr = info->descriptor;
2359 /* Setup the gfc_se structures. */
2360 gfc_copy_loopinfo_to_se (&lse, &loop);
2361 gfc_copy_loopinfo_to_se (&rse, &loop);
2364 lse.ss = loop.temp_ss;
2365 gfc_mark_ss_chain_used (rss, 1);
2366 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2368 /* Start the scalarized loop body. */
2369 gfc_start_scalarized_body (&loop, &body);
2371 /* Translate the expression. */
2372 gfc_conv_expr (&rse, expr);
2374 gfc_conv_tmp_array_ref (&lse);
2375 gfc_advance_se_ss_chain (&lse);
2377 if (intent != INTENT_OUT)
2379 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2380 gfc_add_expr_to_block (&body, tmp);
2381 gcc_assert (rse.ss == gfc_ss_terminator);
2382 gfc_trans_scalarizing_loops (&loop, &body);
2386 /* Make sure that the temporary declaration survives by merging
2387 all the loop declarations into the current context. */
2388 for (n = 0; n < loop.dimen; n++)
2390 gfc_merge_block_scope (&body);
2391 body = loop.code[loop.order[n]];
2393 gfc_merge_block_scope (&body);
2396 /* Add the post block after the second loop, so that any
2397 freeing of allocated memory is done at the right time. */
2398 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2400 /**********Copy the temporary back again.*********/
2402 gfc_init_se (&lse, NULL);
2403 gfc_init_se (&rse, NULL);
2405 /* Walk the argument expression. */
2406 lss = gfc_walk_expr (expr);
2407 rse.ss = loop.temp_ss;
2410 /* Initialize the scalarizer. */
2411 gfc_init_loopinfo (&loop2);
2412 gfc_add_ss_to_loop (&loop2, lss);
2414 /* Calculate the bounds of the scalarization. */
2415 gfc_conv_ss_startstride (&loop2);
2417 /* Setup the scalarizing loops. */
2418 gfc_conv_loop_setup (&loop2, &expr->where);
2420 gfc_copy_loopinfo_to_se (&lse, &loop2);
2421 gfc_copy_loopinfo_to_se (&rse, &loop2);
2423 gfc_mark_ss_chain_used (lss, 1);
2424 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2426 /* Declare the variable to hold the temporary offset and start the
2427 scalarized loop body. */
2428 offset = gfc_create_var (gfc_array_index_type, NULL);
2429 gfc_start_scalarized_body (&loop2, &body);
2431 /* Build the offsets for the temporary from the loop variables. The
2432 temporary array has lbounds of zero and strides of one in all
2433 dimensions, so this is very simple. The offset is only computed
2434 outside the innermost loop, so the overall transfer could be
2435 optimized further. */
2436 info = &rse.ss->data.info;
2438 tmp_index = gfc_index_zero_node;
2439 for (n = info->dimen - 1; n > 0; n--)
2442 tmp = rse.loop->loopvar[n];
2443 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2444 tmp, rse.loop->from[n]);
2445 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2448 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2449 rse.loop->to[n-1], rse.loop->from[n-1]);
2450 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2451 tmp_str, gfc_index_one_node);
2453 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2457 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2458 tmp_index, rse.loop->from[0]);
2459 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2461 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2462 rse.loop->loopvar[0], offset);
2464 /* Now use the offset for the reference. */
2465 tmp = build_fold_indirect_ref_loc (input_location,
2467 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2469 if (expr->ts.type == BT_CHARACTER)
2470 rse.string_length = expr->ts.u.cl->backend_decl;
2472 gfc_conv_expr (&lse, expr);
2474 gcc_assert (lse.ss == gfc_ss_terminator);
2476 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2477 gfc_add_expr_to_block (&body, tmp);
2479 /* Generate the copying loops. */
2480 gfc_trans_scalarizing_loops (&loop2, &body);
2482 /* Wrap the whole thing up by adding the second loop to the post-block
2483 and following it by the post-block of the first loop. In this way,
2484 if the temporary needs freeing, it is done after use! */
2485 if (intent != INTENT_IN)
2487 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2488 gfc_add_block_to_block (&parmse->post, &loop2.post);
2491 gfc_add_block_to_block (&parmse->post, &loop.post);
2493 gfc_cleanup_loop (&loop);
2494 gfc_cleanup_loop (&loop2);
2496 /* Pass the string length to the argument expression. */
2497 if (expr->ts.type == BT_CHARACTER)
2498 parmse->string_length = expr->ts.u.cl->backend_decl;
2500 /* We want either the address for the data or the address of the descriptor,
2501 depending on the mode of passing array arguments. */
2503 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2505 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2511 /* Generate the code for argument list functions. */
2514 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2516 /* Pass by value for g77 %VAL(arg), pass the address
2517 indirectly for %LOC, else by reference. Thus %REF
2518 is a "do-nothing" and %LOC is the same as an F95
2520 if (strncmp (name, "%VAL", 4) == 0)
2521 gfc_conv_expr (se, expr);
2522 else if (strncmp (name, "%LOC", 4) == 0)
2524 gfc_conv_expr_reference (se, expr);
2525 se->expr = gfc_build_addr_expr (NULL, se->expr);
2527 else if (strncmp (name, "%REF", 4) == 0)
2528 gfc_conv_expr_reference (se, expr);
2530 gfc_error ("Unknown argument list function at %L", &expr->where);
2534 /* Generate code for a procedure call. Note can return se->post != NULL.
2535 If se->direct_byref is set then se->expr contains the return parameter.
2536 Return nonzero, if the call has alternate specifiers.
2537 'expr' is only needed for procedure pointer components. */
2540 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2541 gfc_actual_arglist * arg, gfc_expr * expr,
2544 gfc_interface_mapping mapping;
2558 gfc_formal_arglist *formal;
2559 int has_alternate_specifier = 0;
2560 bool need_interface_mapping;
2567 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2568 gfc_component *comp = NULL;
2570 arglist = NULL_TREE;
2571 retargs = NULL_TREE;
2572 stringargs = NULL_TREE;
2577 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2579 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2581 if (arg->expr->rank == 0)
2582 gfc_conv_expr_reference (se, arg->expr);
2586 /* This is really the actual arg because no formal arglist is
2587 created for C_LOC. */
2588 fsym = arg->expr->symtree->n.sym;
2590 /* We should want it to do g77 calling convention. */
2592 && !(fsym->attr.pointer || fsym->attr.allocatable)
2593 && fsym->as->type != AS_ASSUMED_SHAPE;
2594 f = f || !sym->attr.always_explicit;
2596 argss = gfc_walk_expr (arg->expr);
2597 gfc_conv_array_parameter (se, arg->expr, argss, f,
2601 /* TODO -- the following two lines shouldn't be necessary, but
2602 they're removed a bug is exposed later in the codepath.
2603 This is workaround was thus introduced, but will have to be
2604 removed; please see PR 35150 for details about the issue. */
2605 se->expr = convert (pvoid_type_node, se->expr);
2606 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2610 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2612 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2613 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2614 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2615 gfc_conv_expr_reference (se, arg->expr);
2619 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2620 && arg->next->expr->rank == 0)
2621 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2623 /* Convert c_f_pointer if fptr is a scalar
2624 and convert c_f_procpointer. */
2628 gfc_init_se (&cptrse, NULL);
2629 gfc_conv_expr (&cptrse, arg->expr);
2630 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2631 gfc_add_block_to_block (&se->post, &cptrse.post);
2633 gfc_init_se (&fptrse, NULL);
2634 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2635 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2636 fptrse.want_pointer = 1;
2638 gfc_conv_expr (&fptrse, arg->next->expr);
2639 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2640 gfc_add_block_to_block (&se->post, &fptrse.post);
2642 if (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2643 tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
2645 tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
2646 se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
2647 fold_convert (tmp, cptrse.expr));
2651 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2656 /* Build the addr_expr for the first argument. The argument is
2657 already an *address* so we don't need to set want_pointer in
2659 gfc_init_se (&arg1se, NULL);
2660 gfc_conv_expr (&arg1se, arg->expr);
2661 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2662 gfc_add_block_to_block (&se->post, &arg1se.post);
2664 /* See if we were given two arguments. */
2665 if (arg->next == NULL)
2666 /* Only given one arg so generate a null and do a
2667 not-equal comparison against the first arg. */
2668 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2669 fold_convert (TREE_TYPE (arg1se.expr),
2670 null_pointer_node));
2676 /* Given two arguments so build the arg2se from second arg. */
2677 gfc_init_se (&arg2se, NULL);
2678 gfc_conv_expr (&arg2se, arg->next->expr);
2679 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2680 gfc_add_block_to_block (&se->post, &arg2se.post);
2682 /* Generate test to compare that the two args are equal. */
2683 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2684 arg1se.expr, arg2se.expr);
2685 /* Generate test to ensure that the first arg is not null. */
2686 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2687 arg1se.expr, null_pointer_node);
2689 /* Finally, the generated test must check that both arg1 is not
2690 NULL and that it is equal to the second arg. */
2691 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2692 not_null_expr, eq_expr);
2699 gfc_is_proc_ptr_comp (expr, &comp);
2703 if (!sym->attr.elemental)
2705 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2706 if (se->ss->useflags)
2708 gcc_assert ((!comp && gfc_return_by_reference (sym)
2709 && sym->result->attr.dimension)
2710 || (comp && comp->attr.dimension));
2711 gcc_assert (se->loop != NULL);
2713 /* Access the previously obtained result. */
2714 gfc_conv_tmp_array_ref (se);
2715 gfc_advance_se_ss_chain (se);
2719 info = &se->ss->data.info;
2724 gfc_init_block (&post);
2725 gfc_init_interface_mapping (&mapping);
2728 formal = sym->formal;
2729 need_interface_mapping = sym->attr.dimension ||
2730 (sym->ts.type == BT_CHARACTER
2731 && sym->ts.u.cl->length
2732 && sym->ts.u.cl->length->expr_type
2737 formal = comp->formal;
2738 need_interface_mapping = comp->attr.dimension ||
2739 (comp->ts.type == BT_CHARACTER
2740 && comp->ts.u.cl->length
2741 && comp->ts.u.cl->length->expr_type
2745 /* Evaluate the arguments. */
2746 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2749 fsym = formal ? formal->sym : NULL;
2750 parm_kind = MISSING;
2754 if (se->ignore_optional)
2756 /* Some intrinsics have already been resolved to the correct
2760 else if (arg->label)
2762 has_alternate_specifier = 1;
2767 /* Pass a NULL pointer for an absent arg. */
2768 gfc_init_se (&parmse, NULL);
2769 parmse.expr = null_pointer_node;
2770 if (arg->missing_arg_type == BT_CHARACTER)
2771 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2774 else if (fsym && fsym->ts.type == BT_CLASS
2775 && e->ts.type == BT_DERIVED)
2781 /* The derived type needs to be converted to a temporary
2783 gfc_init_se (&parmse, se);
2784 type = gfc_typenode_for_spec (&fsym->ts);
2785 var = gfc_create_var (type, "class");
2787 /* Get the components. */
2788 tmp = fsym->ts.u.derived->components->backend_decl;
2789 data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
2790 var, tmp, NULL_TREE);
2791 tmp = fsym->ts.u.derived->components->next->backend_decl;
2792 vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
2793 var, tmp, NULL_TREE);
2794 tmp = fsym->ts.u.derived->components->next->next->backend_decl;
2795 size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
2796 var, tmp, NULL_TREE);
2798 /* Set the vindex. */
2799 tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
2800 gfc_add_modify (&parmse.pre, vindex, tmp);
2803 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
2804 gfc_add_modify (&parmse.pre, size,
2805 fold_convert (TREE_TYPE (size), tmp));
2807 /* Now set the data field. */
2808 argss = gfc_walk_expr (e);
2809 if (argss == gfc_ss_terminator)
2811 gfc_conv_expr_reference (&parmse, e);
2812 tmp = fold_convert (TREE_TYPE (data),
2814 gfc_add_modify (&parmse.pre, data, tmp);
2818 gfc_conv_expr (&parmse, e);
2819 gfc_add_modify (&parmse.pre, data, parmse.expr);
2822 /* Pass the address of the class object. */
2823 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
2825 else if (se->ss && se->ss->useflags)
2827 /* An elemental function inside a scalarized loop. */
2828 gfc_init_se (&parmse, se);
2829 gfc_conv_expr_reference (&parmse, e);
2830 parm_kind = ELEMENTAL;
2834 /* A scalar or transformational function. */
2835 gfc_init_se (&parmse, NULL);
2836 argss = gfc_walk_expr (e);
2838 if (argss == gfc_ss_terminator)
2840 if (e->expr_type == EXPR_VARIABLE
2841 && e->symtree->n.sym->attr.cray_pointee
2842 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2844 /* The Cray pointer needs to be converted to a pointer to
2845 a type given by the expression. */
2846 gfc_conv_expr (&parmse, e);
2847 type = build_pointer_type (TREE_TYPE (parmse.expr));
2848 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2849 parmse.expr = convert (type, tmp);
2851 else if (fsym && fsym->attr.value)
2853 if (fsym->ts.type == BT_CHARACTER
2854 && fsym->ts.is_c_interop
2855 && fsym->ns->proc_name != NULL
2856 && fsym->ns->proc_name->attr.is_bind_c)
2859 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2860 if (parmse.expr == NULL)
2861 gfc_conv_expr (&parmse, e);
2864 gfc_conv_expr (&parmse, e);
2866 else if (arg->name && arg->name[0] == '%')
2867 /* Argument list functions %VAL, %LOC and %REF are signalled
2868 through arg->name. */
2869 conv_arglist_function (&parmse, arg->expr, arg->name);
2870 else if ((e->expr_type == EXPR_FUNCTION)
2871 && e->symtree->n.sym->attr.pointer
2872 && fsym && fsym->attr.target)
2874 gfc_conv_expr (&parmse, e);
2875 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2877 else if (e->expr_type == EXPR_FUNCTION
2878 && e->symtree->n.sym->result
2879 && e->symtree->n.sym->result != e->symtree->n.sym
2880 && e->symtree->n.sym->result->attr.proc_pointer)
2882 /* Functions returning procedure pointers. */
2883 gfc_conv_expr (&parmse, e);
2884 if (fsym && fsym->attr.proc_pointer)
2885 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2889 gfc_conv_expr_reference (&parmse, e);
2890 if (fsym && e->expr_type != EXPR_NULL
2891 && ((fsym->attr.pointer
2892 && fsym->attr.flavor != FL_PROCEDURE)
2893 || (fsym->attr.proc_pointer
2894 && !(e->expr_type == EXPR_VARIABLE
2895 && e->symtree->n.sym->attr.dummy))
2896 || (e->expr_type == EXPR_VARIABLE
2897 && gfc_is_proc_ptr_comp (e, NULL))))
2899 /* Scalar pointer dummy args require an extra level of
2900 indirection. The null pointer already contains
2901 this level of indirection. */
2902 parm_kind = SCALAR_POINTER;
2903 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2909 /* If the procedure requires an explicit interface, the actual
2910 argument is passed according to the corresponding formal
2911 argument. If the corresponding formal argument is a POINTER,
2912 ALLOCATABLE or assumed shape, we do not use g77's calling
2913 convention, and pass the address of the array descriptor
2914 instead. Otherwise we use g77's calling convention. */
2917 && !(fsym->attr.pointer || fsym->attr.allocatable)
2918 && fsym->as->type != AS_ASSUMED_SHAPE;
2919 f = f || !sym->attr.always_explicit;
2921 if (e->expr_type == EXPR_VARIABLE
2922 && is_subref_array (e))
2923 /* The actual argument is a component reference to an
2924 array of derived types. In this case, the argument
2925 is converted to a temporary, which is passed and then
2926 written back after the procedure call. */
2927 gfc_conv_subref_array_arg (&parmse, e, f,
2928 fsym ? fsym->attr.intent : INTENT_INOUT);
2930 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2933 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2934 allocated on entry, it must be deallocated. */
2935 if (fsym && fsym->attr.allocatable
2936 && fsym->attr.intent == INTENT_OUT)
2938 tmp = build_fold_indirect_ref_loc (input_location,
2940 tmp = gfc_trans_dealloc_allocated (tmp);
2941 gfc_add_expr_to_block (&se->pre, tmp);
2947 /* The case with fsym->attr.optional is that of a user subroutine
2948 with an interface indicating an optional argument. When we call
2949 an intrinsic subroutine, however, fsym is NULL, but we might still
2950 have an optional argument, so we proceed to the substitution
2952 if (e && (fsym == NULL || fsym->attr.optional))
2954 /* If an optional argument is itself an optional dummy argument,
2955 check its presence and substitute a null if absent. */
2956 if (e->expr_type == EXPR_VARIABLE
2957 && e->symtree->n.sym->attr.optional)
2958 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2959 e->representation.length);
2964 /* Obtain the character length of an assumed character length
2965 length procedure from the typespec. */
2966 if (fsym->ts.type == BT_CHARACTER
2967 && parmse.string_length == NULL_TREE
2968 && e->ts.type == BT_PROCEDURE
2969 && e->symtree->n.sym->ts.type == BT_CHARACTER
2970 && e->symtree->n.sym->ts.u.cl->length != NULL
2971 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2973 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
2974 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
2978 if (fsym && need_interface_mapping && e)
2979 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2981 gfc_add_block_to_block (&se->pre, &parmse.pre);
2982 gfc_add_block_to_block (&post, &parmse.post);
2984 /* Allocated allocatable components of derived types must be
2985 deallocated for non-variable scalars. Non-variable arrays are
2986 dealt with in trans-array.c(gfc_conv_array_parameter). */
2987 if (e && e->ts.type == BT_DERIVED
2988 && e->ts.u.derived->attr.alloc_comp
2989 && !(e->symtree && e->symtree->n.sym->attr.pointer)
2990 && (e->expr_type != EXPR_VARIABLE && !e->rank))
2993 tmp = build_fold_indirect_ref_loc (input_location,
2995 parm_rank = e->rank;
3003 case (SCALAR_POINTER):
3004 tmp = build_fold_indirect_ref_loc (input_location,
3009 if (e->expr_type == EXPR_OP
3010 && e->value.op.op == INTRINSIC_PARENTHESES
3011 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3014 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3015 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3016 gfc_add_expr_to_block (&se->post, local_tmp);
3019 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3021 gfc_add_expr_to_block (&se->post, tmp);
3024 /* Add argument checking of passing an unallocated/NULL actual to
3025 a nonallocatable/nonpointer dummy. */
3027 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3029 symbol_attribute *attr;
3033 if (e->expr_type == EXPR_VARIABLE)
3034 attr = &e->symtree->n.sym->attr;
3035 else if (e->expr_type == EXPR_FUNCTION)
3037 /* For intrinsic functions, the gfc_attr are not available. */
3038 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3039 goto end_pointer_check;
3041 if (e->symtree->n.sym->attr.generic)
3042 attr = &e->value.function.esym->attr;
3044 attr = &e->symtree->n.sym->result->attr;
3047 goto end_pointer_check;
3051 /* If the actual argument is an optional pointer/allocatable and
3052 the formal argument takes an nonpointer optional value,
3053 it is invalid to pass a non-present argument on, even
3054 though there is no technical reason for this in gfortran.
3055 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3056 tree present, nullptr, type;
3058 if (attr->allocatable
3059 && (fsym == NULL || !fsym->attr.allocatable))
3060 asprintf (&msg, "Allocatable actual argument '%s' is not "
3061 "allocated or not present", e->symtree->n.sym->name);
3062 else if (attr->pointer
3063 && (fsym == NULL || !fsym->attr.pointer))
3064 asprintf (&msg, "Pointer actual argument '%s' is not "
3065 "associated or not present",
3066 e->symtree->n.sym->name);
3067 else if (attr->proc_pointer
3068 && (fsym == NULL || !fsym->attr.proc_pointer))
3069 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3070 "associated or not present",
3071 e->symtree->n.sym->name);
3073 goto end_pointer_check;
3075 present = gfc_conv_expr_present (e->symtree->n.sym);
3076 type = TREE_TYPE (present);
3077 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3078 fold_convert (type, null_pointer_node));
3079 type = TREE_TYPE (parmse.expr);
3080 nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3081 fold_convert (type, null_pointer_node));
3082 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3087 if (attr->allocatable
3088 && (fsym == NULL || !fsym->attr.allocatable))
3089 asprintf (&msg, "Allocatable actual argument '%s' is not "
3090 "allocated", e->symtree->n.sym->name);
3091 else if (attr->pointer
3092 && (fsym == NULL || !fsym->attr.pointer))
3093 asprintf (&msg, "Pointer actual argument '%s' is not "
3094 "associated", e->symtree->n.sym->name);
3095 else if (attr->proc_pointer
3096 && (fsym == NULL || !fsym->attr.proc_pointer))
3097 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3098 "associated", e->symtree->n.sym->name);
3100 goto end_pointer_check;
3103 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3104 fold_convert (TREE_TYPE (parmse.expr),
3105 null_pointer_node));
3108 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3115 /* Character strings are passed as two parameters, a length and a
3116 pointer - except for Bind(c) which only passes the pointer. */
3117 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3118 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
3120 arglist = gfc_chainon_list (arglist, parmse.expr);
3122 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3129 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3130 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3131 else if (ts.type == BT_CHARACTER)
3133 if (ts.u.cl->length == NULL)
3135 /* Assumed character length results are not allowed by 5.1.1.5 of the
3136 standard and are trapped in resolve.c; except in the case of SPREAD
3137 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3138 we take the character length of the first argument for the result.
3139 For dummies, we have to look through the formal argument list for
3140 this function and use the character length found there.*/
3141 if (!sym->attr.dummy)
3142 cl.backend_decl = TREE_VALUE (stringargs);
3145 formal = sym->ns->proc_name->formal;
3146 for (; formal; formal = formal->next)
3147 if (strcmp (formal->sym->name, sym->name) == 0)
3148 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3155 /* Calculate the length of the returned string. */
3156 gfc_init_se (&parmse, NULL);
3157 if (need_interface_mapping)
3158 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3160 gfc_conv_expr (&parmse, ts.u.cl->length);
3161 gfc_add_block_to_block (&se->pre, &parmse.pre);
3162 gfc_add_block_to_block (&se->post, &parmse.post);
3164 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3165 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3166 build_int_cst (gfc_charlen_type_node, 0));
3167 cl.backend_decl = tmp;
3170 /* Set up a charlen structure for it. */
3175 len = cl.backend_decl;
3178 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3179 || (!comp && gfc_return_by_reference (sym));
3182 if (se->direct_byref)
3184 /* Sometimes, too much indirection can be applied; e.g. for
3185 function_result = array_valued_recursive_function. */
3186 if (TREE_TYPE (TREE_TYPE (se->expr))
3187 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3188 && GFC_DESCRIPTOR_TYPE_P
3189 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3190 se->expr = build_fold_indirect_ref_loc (input_location,
3193 retargs = gfc_chainon_list (retargs, se->expr);
3195 else if (comp && comp->attr.dimension)
3197 gcc_assert (se->loop && info);
3199 /* Set the type of the array. */
3200 tmp = gfc_typenode_for_spec (&comp->ts);
3201 info->dimen = se->loop->dimen;
3203 /* Evaluate the bounds of the result, if known. */
3204 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3206 /* Create a temporary to store the result. In case the function
3207 returns a pointer, the temporary will be a shallow copy and
3208 mustn't be deallocated. */
3209 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3210 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3211 NULL_TREE, false, !comp->attr.pointer,
3212 callee_alloc, &se->ss->expr->where);
3214 /* Pass the temporary as the first argument. */
3215 tmp = info->descriptor;
3216 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3217 retargs = gfc_chainon_list (retargs, tmp);
3219 else if (!comp && sym->result->attr.dimension)
3221 gcc_assert (se->loop && info);
3223 /* Set the type of the array. */
3224 tmp = gfc_typenode_for_spec (&ts);
3225 info->dimen = se->loop->dimen;
3227 /* Evaluate the bounds of the result, if known. */
3228 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3230 /* Create a temporary to store the result. In case the function
3231 returns a pointer, the temporary will be a shallow copy and
3232 mustn't be deallocated. */
3233 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3234 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3235 NULL_TREE, false, !sym->attr.pointer,
3236 callee_alloc, &se->ss->expr->where);
3238 /* Pass the temporary as the first argument. */
3239 tmp = info->descriptor;
3240 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3241 retargs = gfc_chainon_list (retargs, tmp);
3243 else if (ts.type == BT_CHARACTER)
3245 /* Pass the string length. */
3246 type = gfc_get_character_type (ts.kind, ts.u.cl);
3247 type = build_pointer_type (type);
3249 /* Return an address to a char[0:len-1]* temporary for
3250 character pointers. */
3251 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3252 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3254 var = gfc_create_var (type, "pstr");
3256 /* Provide an address expression for the function arguments. */
3257 var = gfc_build_addr_expr (NULL_TREE, var);
3260 var = gfc_conv_string_tmp (se, type, len);
3262 retargs = gfc_chainon_list (retargs, var);
3266 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3268 type = gfc_get_complex_type (ts.kind);
3269 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3270 retargs = gfc_chainon_list (retargs, var);
3273 /* Add the string length to the argument list. */
3274 if (ts.type == BT_CHARACTER)
3275 retargs = gfc_chainon_list (retargs, len);
3277 gfc_free_interface_mapping (&mapping);
3279 /* Add the return arguments. */
3280 arglist = chainon (retargs, arglist);
3282 /* Add the hidden string length parameters to the arguments. */
3283 arglist = chainon (arglist, stringargs);
3285 /* We may want to append extra arguments here. This is used e.g. for
3286 calls to libgfortran_matmul_??, which need extra information. */
3287 if (append_args != NULL_TREE)
3288 arglist = chainon (arglist, append_args);
3290 /* Generate the actual call. */
3291 conv_function_val (se, sym, expr);
3293 /* If there are alternate return labels, function type should be
3294 integer. Can't modify the type in place though, since it can be shared
3295 with other functions. For dummy arguments, the typing is done to
3296 to this result, even if it has to be repeated for each call. */
3297 if (has_alternate_specifier
3298 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3300 if (!sym->attr.dummy)
3302 TREE_TYPE (sym->backend_decl)
3303 = build_function_type (integer_type_node,
3304 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3305 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3308 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3311 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3312 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3314 /* If we have a pointer function, but we don't want a pointer, e.g.
3317 where f is pointer valued, we have to dereference the result. */
3318 if (!se->want_pointer && !byref && sym->attr.pointer
3319 && !gfc_is_proc_ptr_comp (expr, NULL))
3320 se->expr = build_fold_indirect_ref_loc (input_location,
3323 /* f2c calling conventions require a scalar default real function to
3324 return a double precision result. Convert this back to default
3325 real. We only care about the cases that can happen in Fortran 77.
3327 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3328 && sym->ts.kind == gfc_default_real_kind
3329 && !sym->attr.always_explicit)
3330 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3332 /* A pure function may still have side-effects - it may modify its
3334 TREE_SIDE_EFFECTS (se->expr) = 1;
3336 if (!sym->attr.pure)
3337 TREE_SIDE_EFFECTS (se->expr) = 1;
3342 /* Add the function call to the pre chain. There is no expression. */
3343 gfc_add_expr_to_block (&se->pre, se->expr);
3344 se->expr = NULL_TREE;
3346 if (!se->direct_byref)
3348 if (sym->attr.dimension || (comp && comp->attr.dimension))
3350 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3352 /* Check the data pointer hasn't been modified. This would
3353 happen in a function returning a pointer. */
3354 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3355 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3357 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3360 se->expr = info->descriptor;
3361 /* Bundle in the string length. */
3362 se->string_length = len;
3364 else if (ts.type == BT_CHARACTER)
3366 /* Dereference for character pointer results. */
3367 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3368 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3369 se->expr = build_fold_indirect_ref_loc (input_location, var);
3373 se->string_length = len;
3377 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3378 se->expr = build_fold_indirect_ref_loc (input_location, var);
3383 /* Follow the function call with the argument post block. */
3385 gfc_add_block_to_block (&se->pre, &post);
3387 gfc_add_block_to_block (&se->post, &post);
3389 return has_alternate_specifier;
3393 /* Fill a character string with spaces. */
3396 fill_with_spaces (tree start, tree type, tree size)
3398 stmtblock_t block, loop;
3399 tree i, el, exit_label, cond, tmp;
3401 /* For a simple char type, we can call memset(). */
3402 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3403 return build_call_expr_loc (input_location,
3404 built_in_decls[BUILT_IN_MEMSET], 3, start,
3405 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3406 lang_hooks.to_target_charset (' ')),
3409 /* Otherwise, we use a loop:
3410 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3414 /* Initialize variables. */
3415 gfc_init_block (&block);
3416 i = gfc_create_var (sizetype, "i");
3417 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3418 el = gfc_create_var (build_pointer_type (type), "el");
3419 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3420 exit_label = gfc_build_label_decl (NULL_TREE);
3421 TREE_USED (exit_label) = 1;
3425 gfc_init_block (&loop);
3427 /* Exit condition. */
3428 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3429 fold_convert (sizetype, integer_zero_node));
3430 tmp = build1_v (GOTO_EXPR, exit_label);
3431 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3432 build_empty_stmt (input_location));
3433 gfc_add_expr_to_block (&loop, tmp);
3436 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3437 build_int_cst (type,
3438 lang_hooks.to_target_charset (' ')));
3440 /* Increment loop variables. */
3441 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3442 TYPE_SIZE_UNIT (type)));
3443 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3445 TYPE_SIZE_UNIT (type)));
3447 /* Making the loop... actually loop! */
3448 tmp = gfc_finish_block (&loop);
3449 tmp = build1_v (LOOP_EXPR, tmp);
3450 gfc_add_expr_to_block (&block, tmp);
3452 /* The exit label. */
3453 tmp = build1_v (LABEL_EXPR, exit_label);
3454 gfc_add_expr_to_block (&block, tmp);
3457 return gfc_finish_block (&block);
3461 /* Generate code to copy a string. */
3464 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3465 int dkind, tree slength, tree src, int skind)
3467 tree tmp, dlen, slen;
3476 stmtblock_t tempblock;
3478 gcc_assert (dkind == skind);
3480 if (slength != NULL_TREE)
3482 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3483 ssc = string_to_single_character (slen, src, skind);
3487 slen = build_int_cst (size_type_node, 1);
3491 if (dlength != NULL_TREE)
3493 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3494 dsc = string_to_single_character (slen, dest, dkind);
3498 dlen = build_int_cst (size_type_node, 1);
3502 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3503 ssc = string_to_single_character (slen, src, skind);
3504 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3505 dsc = string_to_single_character (dlen, dest, dkind);
3508 /* Assign directly if the types are compatible. */
3509 if (dsc != NULL_TREE && ssc != NULL_TREE
3510 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3512 gfc_add_modify (block, dsc, ssc);
3516 /* Do nothing if the destination length is zero. */
3517 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3518 build_int_cst (size_type_node, 0));
3520 /* The following code was previously in _gfortran_copy_string:
3522 // The two strings may overlap so we use memmove.
3524 copy_string (GFC_INTEGER_4 destlen, char * dest,
3525 GFC_INTEGER_4 srclen, const char * src)
3527 if (srclen >= destlen)
3529 // This will truncate if too long.
3530 memmove (dest, src, destlen);
3534 memmove (dest, src, srclen);
3536 memset (&dest[srclen], ' ', destlen - srclen);
3540 We're now doing it here for better optimization, but the logic
3543 /* For non-default character kinds, we have to multiply the string
3544 length by the base type size. */
3545 chartype = gfc_get_char_type (dkind);
3546 slen = fold_build2 (MULT_EXPR, size_type_node,
3547 fold_convert (size_type_node, slen),
3548 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3549 dlen = fold_build2 (MULT_EXPR, size_type_node,
3550 fold_convert (size_type_node, dlen),
3551 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3554 dest = fold_convert (pvoid_type_node, dest);
3556 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3559 src = fold_convert (pvoid_type_node, src);
3561 src = gfc_build_addr_expr (pvoid_type_node, src);
3563 /* Truncate string if source is too long. */
3564 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3565 tmp2 = build_call_expr_loc (input_location,
3566 built_in_decls[BUILT_IN_MEMMOVE],
3567 3, dest, src, dlen);
3569 /* Else copy and pad with spaces. */
3570 tmp3 = build_call_expr_loc (input_location,
3571 built_in_decls[BUILT_IN_MEMMOVE],
3572 3, dest, src, slen);
3574 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3575 fold_convert (sizetype, slen));
3576 tmp4 = fill_with_spaces (tmp4, chartype,
3577 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3580 gfc_init_block (&tempblock);
3581 gfc_add_expr_to_block (&tempblock, tmp3);
3582 gfc_add_expr_to_block (&tempblock, tmp4);
3583 tmp3 = gfc_finish_block (&tempblock);
3585 /* The whole copy_string function is there. */
3586 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3587 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3588 build_empty_stmt (input_location));
3589 gfc_add_expr_to_block (block, tmp);
3593 /* Translate a statement function.
3594 The value of a statement function reference is obtained by evaluating the
3595 expression using the values of the actual arguments for the values of the
3596 corresponding dummy arguments. */
3599 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3603 gfc_formal_arglist *fargs;
3604 gfc_actual_arglist *args;
3607 gfc_saved_var *saved_vars;
3613 sym = expr->symtree->n.sym;
3614 args = expr->value.function.actual;
3615 gfc_init_se (&lse, NULL);
3616 gfc_init_se (&rse, NULL);
3619 for (fargs = sym->formal; fargs; fargs = fargs->next)
3621 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3622 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3624 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3626 /* Each dummy shall be specified, explicitly or implicitly, to be
3628 gcc_assert (fargs->sym->attr.dimension == 0);
3631 /* Create a temporary to hold the value. */
3632 type = gfc_typenode_for_spec (&fsym->ts);
3633 temp_vars[n] = gfc_create_var (type, fsym->name);
3635 if (fsym->ts.type == BT_CHARACTER)
3637 /* Copy string arguments. */
3640 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3641 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3643 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3644 tmp = gfc_build_addr_expr (build_pointer_type (type),
3647 gfc_conv_expr (&rse, args->expr);
3648 gfc_conv_string_parameter (&rse);
3649 gfc_add_block_to_block (&se->pre, &lse.pre);
3650 gfc_add_block_to_block (&se->pre, &rse.pre);
3652 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3653 rse.string_length, rse.expr, fsym->ts.kind);
3654 gfc_add_block_to_block (&se->pre, &lse.post);
3655 gfc_add_block_to_block (&se->pre, &rse.post);
3659 /* For everything else, just evaluate the expression. */
3660 gfc_conv_expr (&lse, args->expr);
3662 gfc_add_block_to_block (&se->pre, &lse.pre);
3663 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3664 gfc_add_block_to_block (&se->pre, &lse.post);
3670 /* Use the temporary variables in place of the real ones. */
3671 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3672 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3674 gfc_conv_expr (se, sym->value);
3676 if (sym->ts.type == BT_CHARACTER)
3678 gfc_conv_const_charlen (sym->ts.u.cl);
3680 /* Force the expression to the correct length. */
3681 if (!INTEGER_CST_P (se->string_length)
3682 || tree_int_cst_lt (se->string_length,
3683 sym->ts.u.cl->backend_decl))
3685 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3686 tmp = gfc_create_var (type, sym->name);
3687 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3688 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3689 sym->ts.kind, se->string_length, se->expr,
3693 se->string_length = sym->ts.u.cl->backend_decl;
3696 /* Restore the original variables. */
3697 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3698 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3699 gfc_free (saved_vars);
3703 /* Translate a function expression. */
3706 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3710 if (expr->value.function.isym)
3712 gfc_conv_intrinsic_function (se, expr);
3716 /* We distinguish statement functions from general functions to improve
3717 runtime performance. */
3718 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3720 gfc_conv_statement_function (se, expr);
3724 /* expr.value.function.esym is the resolved (specific) function symbol for
3725 most functions. However this isn't set for dummy procedures. */
3726 sym = expr->value.function.esym;
3728 sym = expr->symtree->n.sym;
3730 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3736 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3738 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3739 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3741 gfc_conv_tmp_array_ref (se);
3742 gfc_advance_se_ss_chain (se);
3746 /* Build a static initializer. EXPR is the expression for the initial value.
3747 The other parameters describe the variable of the component being
3748 initialized. EXPR may be null. */
3751 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3752 bool array, bool pointer)
3756 if (!(expr || pointer))
3759 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3760 (these are the only two iso_c_binding derived types that can be
3761 used as initialization expressions). If so, we need to modify
3762 the 'expr' to be that for a (void *). */
3763 if (expr != NULL && expr->ts.type == BT_DERIVED
3764 && expr->ts.is_iso_c && expr->ts.u.derived)
3766 gfc_symbol *derived = expr->ts.u.derived;
3768 expr = gfc_int_expr (0);
3770 /* The derived symbol has already been converted to a (void *). Use
3772 expr->ts.f90_type = derived->ts.f90_type;
3773 expr->ts.kind = derived->ts.kind;
3778 /* Arrays need special handling. */
3780 return gfc_build_null_descriptor (type);
3782 return gfc_conv_array_initializer (type, expr);
3785 return fold_convert (type, null_pointer_node);
3792 gfc_init_se (&se, NULL);
3793 gfc_conv_structure (&se, expr, 1);
3797 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3800 gfc_init_se (&se, NULL);
3801 gfc_conv_constant (&se, expr);
3808 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3820 gfc_start_block (&block);
3822 /* Initialize the scalarizer. */
3823 gfc_init_loopinfo (&loop);
3825 gfc_init_se (&lse, NULL);
3826 gfc_init_se (&rse, NULL);
3829 rss = gfc_walk_expr (expr);
3830 if (rss == gfc_ss_terminator)
3832 /* The rhs is scalar. Add a ss for the expression. */
3833 rss = gfc_get_ss ();
3834 rss->next = gfc_ss_terminator;
3835 rss->type = GFC_SS_SCALAR;
3839 /* Create a SS for the destination. */
3840 lss = gfc_get_ss ();
3841 lss->type = GFC_SS_COMPONENT;
3843 lss->shape = gfc_get_shape (cm->as->rank);
3844 lss->next = gfc_ss_terminator;
3845 lss->data.info.dimen = cm->as->rank;
3846 lss->data.info.descriptor = dest;
3847 lss->data.info.data = gfc_conv_array_data (dest);
3848 lss->data.info.offset = gfc_conv_array_offset (dest);
3849 for (n = 0; n < cm->as->rank; n++)
3851 lss->data.info.dim[n] = n;
3852 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3853 lss->data.info.stride[n] = gfc_index_one_node;
3855 mpz_init (lss->shape[n]);
3856 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3857 cm->as->lower[n]->value.integer);
3858 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3861 /* Associate the SS with the loop. */
3862 gfc_add_ss_to_loop (&loop, lss);
3863 gfc_add_ss_to_loop (&loop, rss);
3865 /* Calculate the bounds of the scalarization. */
3866 gfc_conv_ss_startstride (&loop);
3868 /* Setup the scalarizing loops. */
3869 gfc_conv_loop_setup (&loop, &expr->where);
3871 /* Setup the gfc_se structures. */
3872 gfc_copy_loopinfo_to_se (&lse, &loop);
3873 gfc_copy_loopinfo_to_se (&rse, &loop);
3876 gfc_mark_ss_chain_used (rss, 1);
3878 gfc_mark_ss_chain_used (lss, 1);
3880 /* Start the scalarized loop body. */
3881 gfc_start_scalarized_body (&loop, &body);
3883 gfc_conv_tmp_array_ref (&lse);
3884 if (cm->ts.type == BT_CHARACTER)
3885 lse.string_length = cm->ts.u.cl->backend_decl;
3887 gfc_conv_expr (&rse, expr);
3889 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3890 gfc_add_expr_to_block (&body, tmp);
3892 gcc_assert (rse.ss == gfc_ss_terminator);
3894 /* Generate the copying loops. */
3895 gfc_trans_scalarizing_loops (&loop, &body);
3897 /* Wrap the whole thing up. */
3898 gfc_add_block_to_block (&block, &loop.pre);
3899 gfc_add_block_to_block (&block, &loop.post);
3901 for (n = 0; n < cm->as->rank; n++)
3902 mpz_clear (lss->shape[n]);
3903 gfc_free (lss->shape);
3905 gfc_cleanup_loop (&loop);
3907 return gfc_finish_block (&block);
3911 /* Assign a single component of a derived type constructor. */
3914 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3924 gfc_start_block (&block);
3926 if (cm->attr.pointer)
3928 gfc_init_se (&se, NULL);
3929 /* Pointer component. */
3930 if (cm->attr.dimension)
3932 /* Array pointer. */
3933 if (expr->expr_type == EXPR_NULL)
3934 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3937 rss = gfc_walk_expr (expr);
3938 se.direct_byref = 1;
3940 gfc_conv_expr_descriptor (&se, expr, rss);
3941 gfc_add_block_to_block (&block, &se.pre);
3942 gfc_add_block_to_block (&block, &se.post);
3947 /* Scalar pointers. */
3948 se.want_pointer = 1;
3949 gfc_conv_expr (&se, expr);
3950 gfc_add_block_to_block (&block, &se.pre);
3951 gfc_add_modify (&block, dest,
3952 fold_convert (TREE_TYPE (dest), se.expr));
3953 gfc_add_block_to_block (&block, &se.post);
3956 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
3958 /* NULL initialization for CLASS components. */
3959 tmp = gfc_trans_structure_assign (dest,
3960 gfc_default_initializer (&cm->ts));
3961 gfc_add_expr_to_block (&block, tmp);
3963 else if (cm->attr.dimension)
3965 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3966 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3967 else if (cm->attr.allocatable)
3971 gfc_init_se (&se, NULL);
3973 rss = gfc_walk_expr (expr);
3974 se.want_pointer = 0;
3975 gfc_conv_expr_descriptor (&se, expr, rss);
3976 gfc_add_block_to_block (&block, &se.pre);
3977 gfc_add_modify (&block, dest, se.expr);
3979 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
3980 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
3983 tmp = gfc_duplicate_allocatable (dest, se.expr,
3984 TREE_TYPE(cm->backend_decl),
3987 gfc_add_expr_to_block (&block, tmp);
3988 gfc_add_block_to_block (&block, &se.post);
3990 if (expr->expr_type != EXPR_VARIABLE)
3991 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3993 /* Shift the lbound and ubound of temporaries to being unity, rather
3994 than zero, based. Calculate the offset for all cases. */
3995 offset = gfc_conv_descriptor_offset_get (dest);
3996 gfc_add_modify (&block, offset, gfc_index_zero_node);
3997 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3998 for (n = 0; n < expr->rank; n++)
4000 if (expr->expr_type != EXPR_VARIABLE
4001 && expr->expr_type != EXPR_CONSTANT)
4004 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4005 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4006 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4007 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4008 span, gfc_index_one_node);
4009 gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
4011 gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
4012 gfc_index_one_node);
4014 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4015 gfc_conv_descriptor_lbound_get (dest,
4017 gfc_conv_descriptor_stride_get (dest,
4019 gfc_add_modify (&block, tmp2, tmp);
4020 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4021 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4024 if (expr->expr_type == EXPR_FUNCTION
4025 && expr->value.function.isym
4026 && expr->value.function.isym->conversion
4027 && expr->value.function.actual->expr
4028 && expr->value.function.actual->expr->expr_type
4031 /* If a conversion expression has a null data pointer
4032 argument, nullify the allocatable component. */
4036 s = expr->value.function.actual->expr->symtree->n.sym;
4037 if (s->attr.allocatable || s->attr.pointer)
4039 non_null_expr = gfc_finish_block (&block);
4040 gfc_start_block (&block);
4041 gfc_conv_descriptor_data_set (&block, dest,
4043 null_expr = gfc_finish_block (&block);
4044 tmp = gfc_conv_descriptor_data_get (s->backend_decl);
4045 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4046 fold_convert (TREE_TYPE (tmp),
4047 null_pointer_node));
4048 return build3_v (COND_EXPR, tmp, null_expr,
4055 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4056 gfc_add_expr_to_block (&block, tmp);
4059 else if (expr->ts.type == BT_DERIVED)
4061 if (expr->expr_type != EXPR_STRUCTURE)
4063 gfc_init_se (&se, NULL);
4064 gfc_conv_expr (&se, expr);
4065 gfc_add_block_to_block (&block, &se.pre);
4066 gfc_add_modify (&block, dest,
4067 fold_convert (TREE_TYPE (dest), se.expr));
4068 gfc_add_block_to_block (&block, &se.post);
4072 /* Nested constructors. */
4073 tmp = gfc_trans_structure_assign (dest, expr);
4074 gfc_add_expr_to_block (&block, tmp);
4079 /* Scalar component. */
4080 gfc_init_se (&se, NULL);
4081 gfc_init_se (&lse, NULL);
4083 gfc_conv_expr (&se, expr);
4084 if (cm->ts.type == BT_CHARACTER)
4085 lse.string_length = cm->ts.u.cl->backend_decl;
4087 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
4088 gfc_add_expr_to_block (&block, tmp);
4090 return gfc_finish_block (&block);
4093 /* Assign a derived type constructor to a variable. */
4096 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4104 gfc_start_block (&block);
4105 cm = expr->ts.u.derived->components;
4106 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4108 /* Skip absent members in default initializers. */
4112 field = cm->backend_decl;
4113 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4114 dest, field, NULL_TREE);
4115 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4116 gfc_add_expr_to_block (&block, tmp);
4118 return gfc_finish_block (&block);
4121 /* Build an expression for a constructor. If init is nonzero then
4122 this is part of a static variable initializer. */
4125 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4132 VEC(constructor_elt,gc) *v = NULL;
4134 gcc_assert (se->ss == NULL);
4135 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4136 type = gfc_typenode_for_spec (&expr->ts);
4140 /* Create a temporary variable and fill it in. */
4141 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4142 tmp = gfc_trans_structure_assign (se->expr, expr);
4143 gfc_add_expr_to_block (&se->pre, tmp);
4147 cm = expr->ts.u.derived->components;
4149 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4151 /* Skip absent members in default initializers and allocatable
4152 components. Although the latter have a default initializer
4153 of EXPR_NULL,... by default, the static nullify is not needed
4154 since this is done every time we come into scope. */
4155 if (!c->expr || cm->attr.allocatable)
4158 if (cm->ts.type == BT_CLASS)
4160 val = gfc_conv_initializer (c->expr, &cm->ts,
4161 TREE_TYPE (cm->ts.u.derived->components->backend_decl),
4162 cm->ts.u.derived->components->attr.dimension,
4163 cm->ts.u.derived->components->attr.pointer);
4165 /* Append it to the constructor list. */
4166 CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
4171 val = gfc_conv_initializer (c->expr, &cm->ts,
4172 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4173 cm->attr.pointer || cm->attr.proc_pointer);
4175 /* Append it to the constructor list. */
4176 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4179 se->expr = build_constructor (type, v);
4181 TREE_CONSTANT (se->expr) = 1;
4185 /* Translate a substring expression. */
4188 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4194 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4196 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4197 expr->value.character.length,
4198 expr->value.character.string);
4200 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4201 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4204 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4208 /* Entry point for expression translation. Evaluates a scalar quantity.
4209 EXPR is the expression to be translated, and SE is the state structure if
4210 called from within the scalarized. */
4213 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4215 if (se->ss && se->ss->expr == expr
4216 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4218 /* Substitute a scalar expression evaluated outside the scalarization
4220 se->expr = se->ss->data.scalar.expr;
4221 se->string_length = se->ss->string_length;
4222 gfc_advance_se_ss_chain (se);
4226 /* We need to convert the expressions for the iso_c_binding derived types.
4227 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4228 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4229 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4230 updated to be an integer with a kind equal to the size of a (void *). */
4231 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4232 && expr->ts.u.derived->attr.is_iso_c)
4234 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4235 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4237 /* Set expr_type to EXPR_NULL, which will result in
4238 null_pointer_node being used below. */
4239 expr->expr_type = EXPR_NULL;
4243 /* Update the type/kind of the expression to be what the new
4244 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4245 expr->ts.type = expr->ts.u.derived->ts.type;
4246 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4247 expr->ts.kind = expr->ts.u.derived->ts.kind;
4251 switch (expr->expr_type)
4254 gfc_conv_expr_op (se, expr);
4258 gfc_conv_function_expr (se, expr);
4262 gfc_conv_constant (se, expr);
4266 gfc_conv_variable (se, expr);
4270 se->expr = null_pointer_node;
4273 case EXPR_SUBSTRING:
4274 gfc_conv_substring_expr (se, expr);
4277 case EXPR_STRUCTURE:
4278 gfc_conv_structure (se, expr, 0);
4282 gfc_conv_array_constructor_expr (se, expr);
4291 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4292 of an assignment. */
4294 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4296 gfc_conv_expr (se, expr);
4297 /* All numeric lvalues should have empty post chains. If not we need to
4298 figure out a way of rewriting an lvalue so that it has no post chain. */
4299 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4302 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4303 numeric expressions. Used for scalar values where inserting cleanup code
4306 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4310 gcc_assert (expr->ts.type != BT_CHARACTER);
4311 gfc_conv_expr (se, expr);
4314 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4315 gfc_add_modify (&se->pre, val, se->expr);
4317 gfc_add_block_to_block (&se->pre, &se->post);
4321 /* Helper to translate an expression and convert it to a particular type. */
4323 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4325 gfc_conv_expr_val (se, expr);
4326 se->expr = convert (type, se->expr);
4330 /* Converts an expression so that it can be passed by reference. Scalar
4334 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4338 if (se->ss && se->ss->expr == expr
4339 && se->ss->type == GFC_SS_REFERENCE)
4341 se->expr = se->ss->data.scalar.expr;
4342 se->string_length = se->ss->string_length;
4343 gfc_advance_se_ss_chain (se);
4347 if (expr->ts.type == BT_CHARACTER)
4349 gfc_conv_expr (se, expr);
4350 gfc_conv_string_parameter (se);
4354 if (expr->expr_type == EXPR_VARIABLE)
4356 se->want_pointer = 1;
4357 gfc_conv_expr (se, expr);
4360 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4361 gfc_add_modify (&se->pre, var, se->expr);
4362 gfc_add_block_to_block (&se->pre, &se->post);
4368 if (expr->expr_type == EXPR_FUNCTION
4369 && expr->symtree->n.sym->attr.pointer
4370 && !expr->symtree->n.sym->attr.dimension)
4372 se->want_pointer = 1;
4373 gfc_conv_expr (se, expr);
4374 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4375 gfc_add_modify (&se->pre, var, se->expr);
4381 gfc_conv_expr (se, expr);
4383 /* Create a temporary var to hold the value. */
4384 if (TREE_CONSTANT (se->expr))
4386 tree tmp = se->expr;
4387 STRIP_TYPE_NOPS (tmp);
4388 var = build_decl (input_location,
4389 CONST_DECL, NULL, TREE_TYPE (tmp));
4390 DECL_INITIAL (var) = tmp;
4391 TREE_STATIC (var) = 1;
4396 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4397 gfc_add_modify (&se->pre, var, se->expr);
4399 gfc_add_block_to_block (&se->pre, &se->post);
4401 /* Take the address of that value. */
4402 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4407 gfc_trans_pointer_assign (gfc_code * code)
4409 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4413 /* Generate code for a pointer assignment. */
4416 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4427 gfc_start_block (&block);
4429 gfc_init_se (&lse, NULL);
4431 lss = gfc_walk_expr (expr1);
4432 rss = gfc_walk_expr (expr2);
4433 if (lss == gfc_ss_terminator)
4435 /* Scalar pointers. */
4436 lse.want_pointer = 1;
4437 gfc_conv_expr (&lse, expr1);
4438 gcc_assert (rss == gfc_ss_terminator);
4439 gfc_init_se (&rse, NULL);
4440 rse.want_pointer = 1;
4441 gfc_conv_expr (&rse, expr2);
4443 if (expr1->symtree->n.sym->attr.proc_pointer
4444 && expr1->symtree->n.sym->attr.dummy)
4445 lse.expr = build_fold_indirect_ref_loc (input_location,
4448 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4449 && expr2->symtree->n.sym->attr.dummy)
4450 rse.expr = build_fold_indirect_ref_loc (input_location,
4453 gfc_add_block_to_block (&block, &lse.pre);
4454 gfc_add_block_to_block (&block, &rse.pre);
4456 /* Check character lengths if character expression. The test is only
4457 really added if -fbounds-check is enabled. */
4458 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4459 && !expr1->symtree->n.sym->attr.proc_pointer
4460 && !gfc_is_proc_ptr_comp (expr1, NULL))
4462 gcc_assert (expr2->ts.type == BT_CHARACTER);
4463 gcc_assert (lse.string_length && rse.string_length);
4464 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4465 lse.string_length, rse.string_length,
4469 gfc_add_modify (&block, lse.expr,
4470 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4472 gfc_add_block_to_block (&block, &rse.post);
4473 gfc_add_block_to_block (&block, &lse.post);
4478 tree strlen_rhs = NULL_TREE;
4480 /* Array pointer. */
4481 gfc_conv_expr_descriptor (&lse, expr1, lss);
4482 strlen_lhs = lse.string_length;
4483 switch (expr2->expr_type)
4486 /* Just set the data pointer to null. */
4487 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4491 /* Assign directly to the pointer's descriptor. */
4492 lse.direct_byref = 1;
4493 gfc_conv_expr_descriptor (&lse, expr2, rss);
4494 strlen_rhs = lse.string_length;
4496 /* If this is a subreference array pointer assignment, use the rhs
4497 descriptor element size for the lhs span. */
4498 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4500 decl = expr1->symtree->n.sym->backend_decl;
4501 gfc_init_se (&rse, NULL);
4502 rse.descriptor_only = 1;
4503 gfc_conv_expr (&rse, expr2);
4504 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4505 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4506 if (!INTEGER_CST_P (tmp))
4507 gfc_add_block_to_block (&lse.post, &rse.pre);
4508 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4514 /* Assign to a temporary descriptor and then copy that
4515 temporary to the pointer. */
4517 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4520 lse.direct_byref = 1;
4521 gfc_conv_expr_descriptor (&lse, expr2, rss);
4522 strlen_rhs = lse.string_length;
4523 gfc_add_modify (&lse.pre, desc, tmp);
4527 gfc_add_block_to_block (&block, &lse.pre);
4529 /* Check string lengths if applicable. The check is only really added
4530 to the output code if -fbounds-check is enabled. */
4531 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4533 gcc_assert (expr2->ts.type == BT_CHARACTER);
4534 gcc_assert (strlen_lhs && strlen_rhs);
4535 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4536 strlen_lhs, strlen_rhs, &block);
4539 gfc_add_block_to_block (&block, &lse.post);
4541 return gfc_finish_block (&block);
4545 /* Makes sure se is suitable for passing as a function string parameter. */
4546 /* TODO: Need to check all callers of this function. It may be abused. */
4549 gfc_conv_string_parameter (gfc_se * se)
4553 if (TREE_CODE (se->expr) == STRING_CST)
4555 type = TREE_TYPE (TREE_TYPE (se->expr));
4556 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4560 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4562 if (TREE_CODE (se->expr) != INDIRECT_REF)
4564 type = TREE_TYPE (se->expr);
4565 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4569 type = gfc_get_character_type_len (gfc_default_character_kind,
4571 type = build_pointer_type (type);
4572 se->expr = gfc_build_addr_expr (type, se->expr);
4576 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4577 gcc_assert (se->string_length
4578 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4582 /* Generate code for assignment of scalar variables. Includes character
4583 strings and derived types with allocatable components. */
4586 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4587 bool l_is_temp, bool r_is_var)
4593 gfc_init_block (&block);
4595 if (ts.type == BT_CHARACTER)
4600 if (lse->string_length != NULL_TREE)
4602 gfc_conv_string_parameter (lse);
4603 gfc_add_block_to_block (&block, &lse->pre);
4604 llen = lse->string_length;
4607 if (rse->string_length != NULL_TREE)
4609 gcc_assert (rse->string_length != NULL_TREE);
4610 gfc_conv_string_parameter (rse);
4611 gfc_add_block_to_block (&block, &rse->pre);
4612 rlen = rse->string_length;
4615 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4616 rse->expr, ts.kind);
4618 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4622 /* Are the rhs and the lhs the same? */
4625 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4626 gfc_build_addr_expr (NULL_TREE, lse->expr),
4627 gfc_build_addr_expr (NULL_TREE, rse->expr));
4628 cond = gfc_evaluate_now (cond, &lse->pre);
4631 /* Deallocate the lhs allocated components as long as it is not
4632 the same as the rhs. This must be done following the assignment
4633 to prevent deallocating data that could be used in the rhs
4637 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4638 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4640 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4642 gfc_add_expr_to_block (&lse->post, tmp);
4645 gfc_add_block_to_block (&block, &rse->pre);
4646 gfc_add_block_to_block (&block, &lse->pre);
4648 gfc_add_modify (&block, lse->expr,
4649 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4651 /* Do a deep copy if the rhs is a variable, if it is not the
4655 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4656 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4658 gfc_add_expr_to_block (&block, tmp);
4661 else if (ts.type == BT_DERIVED)
4663 gfc_add_block_to_block (&block, &lse->pre);
4664 gfc_add_block_to_block (&block, &rse->pre);
4665 tmp = gfc_evaluate_now (rse->expr, &block);
4666 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), tmp);
4667 gfc_add_modify (&block, lse->expr, tmp);
4671 gfc_add_block_to_block (&block, &lse->pre);
4672 gfc_add_block_to_block (&block, &rse->pre);
4674 gfc_add_modify (&block, lse->expr,
4675 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4678 gfc_add_block_to_block (&block, &lse->post);
4679 gfc_add_block_to_block (&block, &rse->post);
4681 return gfc_finish_block (&block);
4685 /* Try to translate array(:) = func (...), where func is a transformational
4686 array function, without using a temporary. Returns NULL is this isn't the
4690 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4695 bool seen_array_ref;
4697 gfc_component *comp = NULL;
4699 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4700 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4703 /* Elemental functions don't need a temporary anyway. */
4704 if (expr2->value.function.esym != NULL
4705 && expr2->value.function.esym->attr.elemental)
4708 /* Fail if rhs is not FULL or a contiguous section. */
4709 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4712 /* Fail if EXPR1 can't be expressed as a descriptor. */
4713 if (gfc_ref_needs_temporary_p (expr1->ref))
4716 /* Functions returning pointers need temporaries. */
4717 if (expr2->symtree->n.sym->attr.pointer
4718 || expr2->symtree->n.sym->attr.allocatable)
4721 /* Character array functions need temporaries unless the
4722 character lengths are the same. */
4723 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4725 if (expr1->ts.u.cl->length == NULL
4726 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4729 if (expr2->ts.u.cl->length == NULL
4730 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4733 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
4734 expr2->ts.u.cl->length->value.integer) != 0)
4738 /* Check that no LHS component references appear during an array
4739 reference. This is needed because we do not have the means to
4740 span any arbitrary stride with an array descriptor. This check
4741 is not needed for the rhs because the function result has to be
4743 seen_array_ref = false;
4744 for (ref = expr1->ref; ref; ref = ref->next)
4746 if (ref->type == REF_ARRAY)
4747 seen_array_ref= true;
4748 else if (ref->type == REF_COMPONENT && seen_array_ref)
4752 /* Check for a dependency. */
4753 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4754 expr2->value.function.esym,
4755 expr2->value.function.actual,
4759 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4761 gcc_assert (expr2->value.function.isym
4762 || (gfc_is_proc_ptr_comp (expr2, &comp)
4763 && comp && comp->attr.dimension)
4764 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
4765 && expr2->value.function.esym->result->attr.dimension));
4767 ss = gfc_walk_expr (expr1);
4768 gcc_assert (ss != gfc_ss_terminator);
4769 gfc_init_se (&se, NULL);
4770 gfc_start_block (&se.pre);
4771 se.want_pointer = 1;
4773 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
4775 se.direct_byref = 1;
4776 se.ss = gfc_walk_expr (expr2);
4777 gcc_assert (se.ss != gfc_ss_terminator);
4778 gfc_conv_function_expr (&se, expr2);
4779 gfc_add_block_to_block (&se.pre, &se.post);
4781 return gfc_finish_block (&se.pre);
4784 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4787 is_zero_initializer_p (gfc_expr * expr)
4789 if (expr->expr_type != EXPR_CONSTANT)
4792 /* We ignore constants with prescribed memory representations for now. */
4793 if (expr->representation.string)
4796 switch (expr->ts.type)
4799 return mpz_cmp_si (expr->value.integer, 0) == 0;
4802 return mpfr_zero_p (expr->value.real)
4803 && MPFR_SIGN (expr->value.real) >= 0;
4806 return expr->value.logical == 0;
4809 return mpfr_zero_p (mpc_realref (expr->value.complex))
4810 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4811 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4812 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4820 /* Try to efficiently translate array(:) = 0. Return NULL if this
4824 gfc_trans_zero_assign (gfc_expr * expr)
4826 tree dest, len, type;
4830 sym = expr->symtree->n.sym;
4831 dest = gfc_get_symbol_decl (sym);
4833 type = TREE_TYPE (dest);
4834 if (POINTER_TYPE_P (type))
4835 type = TREE_TYPE (type);
4836 if (!GFC_ARRAY_TYPE_P (type))
4839 /* Determine the length of the array. */
4840 len = GFC_TYPE_ARRAY_SIZE (type);
4841 if (!len || TREE_CODE (len) != INTEGER_CST)
4844 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4845 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4846 fold_convert (gfc_array_index_type, tmp));
4848 /* If we are zeroing a local array avoid taking its address by emitting
4850 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4851 return build2 (MODIFY_EXPR, void_type_node,
4852 dest, build_constructor (TREE_TYPE (dest), NULL));
4854 /* Convert arguments to the correct types. */
4855 dest = fold_convert (pvoid_type_node, dest);
4856 len = fold_convert (size_type_node, len);
4858 /* Construct call to __builtin_memset. */
4859 tmp = build_call_expr_loc (input_location,
4860 built_in_decls[BUILT_IN_MEMSET],
4861 3, dest, integer_zero_node, len);
4862 return fold_convert (void_type_node, tmp);
4866 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4867 that constructs the call to __builtin_memcpy. */
4870 gfc_build_memcpy_call (tree dst, tree src, tree len)
4874 /* Convert arguments to the correct types. */
4875 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4876 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4878 dst = fold_convert (pvoid_type_node, dst);
4880 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4881 src = gfc_build_addr_expr (pvoid_type_node, src);
4883 src = fold_convert (pvoid_type_node, src);
4885 len = fold_convert (size_type_node, len);
4887 /* Construct call to __builtin_memcpy. */
4888 tmp = build_call_expr_loc (input_location,
4889 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4890 return fold_convert (void_type_node, tmp);
4894 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4895 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4896 source/rhs, both are gfc_full_array_ref_p which have been checked for
4900 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4902 tree dst, dlen, dtype;
4903 tree src, slen, stype;
4906 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4907 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4909 dtype = TREE_TYPE (dst);
4910 if (POINTER_TYPE_P (dtype))
4911 dtype = TREE_TYPE (dtype);
4912 stype = TREE_TYPE (src);
4913 if (POINTER_TYPE_P (stype))
4914 stype = TREE_TYPE (stype);
4916 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4919 /* Determine the lengths of the arrays. */
4920 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4921 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4923 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4924 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4925 fold_convert (gfc_array_index_type, tmp));
4927 slen = GFC_TYPE_ARRAY_SIZE (stype);
4928 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4930 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4931 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4932 fold_convert (gfc_array_index_type, tmp));
4934 /* Sanity check that they are the same. This should always be
4935 the case, as we should already have checked for conformance. */
4936 if (!tree_int_cst_equal (slen, dlen))
4939 return gfc_build_memcpy_call (dst, src, dlen);
4943 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4944 this can't be done. EXPR1 is the destination/lhs for which
4945 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4948 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4950 unsigned HOST_WIDE_INT nelem;
4956 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4960 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4961 dtype = TREE_TYPE (dst);
4962 if (POINTER_TYPE_P (dtype))
4963 dtype = TREE_TYPE (dtype);
4964 if (!GFC_ARRAY_TYPE_P (dtype))
4967 /* Determine the lengths of the array. */
4968 len = GFC_TYPE_ARRAY_SIZE (dtype);
4969 if (!len || TREE_CODE (len) != INTEGER_CST)
4972 /* Confirm that the constructor is the same size. */
4973 if (compare_tree_int (len, nelem) != 0)
4976 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4977 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4978 fold_convert (gfc_array_index_type, tmp));
4980 stype = gfc_typenode_for_spec (&expr2->ts);
4981 src = gfc_build_constant_array_constructor (expr2, stype);
4983 stype = TREE_TYPE (src);
4984 if (POINTER_TYPE_P (stype))
4985 stype = TREE_TYPE (stype);
4987 return gfc_build_memcpy_call (dst, src, len);
4991 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4992 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
4995 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
5000 gfc_ss *lss_section;
5007 bool scalar_to_array;
5010 /* Assignment of the form lhs = rhs. */
5011 gfc_start_block (&block);
5013 gfc_init_se (&lse, NULL);
5014 gfc_init_se (&rse, NULL);
5017 lss = gfc_walk_expr (expr1);
5019 if (lss != gfc_ss_terminator)
5021 /* Allow the scalarizer to workshare array assignments. */
5022 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5023 ompws_flags |= OMPWS_SCALARIZER_WS;
5025 /* The assignment needs scalarization. */
5028 /* Find a non-scalar SS from the lhs. */
5029 while (lss_section != gfc_ss_terminator
5030 && lss_section->type != GFC_SS_SECTION)
5031 lss_section = lss_section->next;
5033 gcc_assert (lss_section != gfc_ss_terminator);
5035 /* Initialize the scalarizer. */
5036 gfc_init_loopinfo (&loop);
5039 rss = gfc_walk_expr (expr2);
5040 if (rss == gfc_ss_terminator)
5042 /* The rhs is scalar. Add a ss for the expression. */
5043 rss = gfc_get_ss ();
5044 rss->next = gfc_ss_terminator;
5045 rss->type = GFC_SS_SCALAR;
5048 /* Associate the SS with the loop. */
5049 gfc_add_ss_to_loop (&loop, lss);
5050 gfc_add_ss_to_loop (&loop, rss);
5052 /* Calculate the bounds of the scalarization. */
5053 gfc_conv_ss_startstride (&loop);
5054 /* Resolve any data dependencies in the statement. */
5055 gfc_conv_resolve_dependencies (&loop, lss, rss);
5056 /* Setup the scalarizing loops. */
5057 gfc_conv_loop_setup (&loop, &expr2->where);
5059 /* Setup the gfc_se structures. */
5060 gfc_copy_loopinfo_to_se (&lse, &loop);
5061 gfc_copy_loopinfo_to_se (&rse, &loop);
5064 gfc_mark_ss_chain_used (rss, 1);
5065 if (loop.temp_ss == NULL)
5068 gfc_mark_ss_chain_used (lss, 1);
5072 lse.ss = loop.temp_ss;
5073 gfc_mark_ss_chain_used (lss, 3);
5074 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5077 /* Start the scalarized loop body. */
5078 gfc_start_scalarized_body (&loop, &body);
5081 gfc_init_block (&body);
5083 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5085 /* Translate the expression. */
5086 gfc_conv_expr (&rse, expr2);
5088 /* Stabilize a string length for temporaries. */
5089 if (expr2->ts.type == BT_CHARACTER)
5090 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5092 string_length = NULL_TREE;
5096 gfc_conv_tmp_array_ref (&lse);
5097 gfc_advance_se_ss_chain (&lse);
5098 if (expr2->ts.type == BT_CHARACTER)
5099 lse.string_length = string_length;
5102 gfc_conv_expr (&lse, expr1);
5104 /* Assignments of scalar derived types with allocatable components
5105 to arrays must be done with a deep copy and the rhs temporary
5106 must have its components deallocated afterwards. */
5107 scalar_to_array = (expr2->ts.type == BT_DERIVED
5108 && expr2->ts.u.derived->attr.alloc_comp
5109 && expr2->expr_type != EXPR_VARIABLE
5110 && !gfc_is_constant_expr (expr2)
5111 && expr1->rank && !expr2->rank);
5112 if (scalar_to_array)
5114 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5115 gfc_add_expr_to_block (&loop.post, tmp);
5118 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5119 l_is_temp || init_flag,
5120 (expr2->expr_type == EXPR_VARIABLE)
5121 || scalar_to_array);
5122 gfc_add_expr_to_block (&body, tmp);
5124 if (lss == gfc_ss_terminator)
5126 /* Use the scalar assignment as is. */
5127 gfc_add_block_to_block (&block, &body);
5131 gcc_assert (lse.ss == gfc_ss_terminator
5132 && rse.ss == gfc_ss_terminator);
5136 gfc_trans_scalarized_loop_boundary (&loop, &body);
5138 /* We need to copy the temporary to the actual lhs. */
5139 gfc_init_se (&lse, NULL);
5140 gfc_init_se (&rse, NULL);
5141 gfc_copy_loopinfo_to_se (&lse, &loop);
5142 gfc_copy_loopinfo_to_se (&rse, &loop);
5144 rse.ss = loop.temp_ss;
5147 gfc_conv_tmp_array_ref (&rse);
5148 gfc_advance_se_ss_chain (&rse);
5149 gfc_conv_expr (&lse, expr1);
5151 gcc_assert (lse.ss == gfc_ss_terminator
5152 && rse.ss == gfc_ss_terminator);
5154 if (expr2->ts.type == BT_CHARACTER)
5155 rse.string_length = string_length;
5157 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5159 gfc_add_expr_to_block (&body, tmp);
5162 /* Generate the copying loops. */
5163 gfc_trans_scalarizing_loops (&loop, &body);
5165 /* Wrap the whole thing up. */
5166 gfc_add_block_to_block (&block, &loop.pre);
5167 gfc_add_block_to_block (&block, &loop.post);
5169 gfc_cleanup_loop (&loop);
5172 return gfc_finish_block (&block);
5176 /* Check whether EXPR is a copyable array. */
5179 copyable_array_p (gfc_expr * expr)
5181 if (expr->expr_type != EXPR_VARIABLE)
5184 /* First check it's an array. */
5185 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5188 if (!gfc_full_array_ref_p (expr->ref, NULL))
5191 /* Next check that it's of a simple enough type. */
5192 switch (expr->ts.type)
5204 return !expr->ts.u.derived->attr.alloc_comp;
5213 /* Translate an assignment. */
5216 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
5220 /* Special case a single function returning an array. */
5221 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5223 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5228 /* Special case assigning an array to zero. */
5229 if (copyable_array_p (expr1)
5230 && is_zero_initializer_p (expr2))
5232 tmp = gfc_trans_zero_assign (expr1);
5237 /* Special case copying one array to another. */
5238 if (copyable_array_p (expr1)
5239 && copyable_array_p (expr2)
5240 && gfc_compare_types (&expr1->ts, &expr2->ts)
5241 && !gfc_check_dependency (expr1, expr2, 0))
5243 tmp = gfc_trans_array_copy (expr1, expr2);
5248 /* Special case initializing an array from a constant array constructor. */
5249 if (copyable_array_p (expr1)
5250 && expr2->expr_type == EXPR_ARRAY
5251 && gfc_compare_types (&expr1->ts, &expr2->ts))
5253 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5258 /* Fallback to the scalarizer to generate explicit loops. */
5259 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
5263 gfc_trans_init_assign (gfc_code * code)
5265 return gfc_trans_assignment (code->expr1, code->expr2, true);
5269 gfc_trans_assign (gfc_code * code)
5271 return gfc_trans_assignment (code->expr1, code->expr2, false);
5275 /* Translate an assignment to a CLASS object
5276 (pointer or ordinary assignment). */
5279 gfc_trans_class_assign (gfc_code *code)
5284 gfc_start_block (&block);
5286 if (code->expr2->ts.type != BT_CLASS)
5288 /* Insert an additional assignment which sets the '$vindex' field. */
5290 lhs = gfc_copy_expr (code->expr1);
5291 gfc_add_component_ref (lhs, "$vindex");
5292 if (code->expr2->ts.type == BT_DERIVED)
5293 /* vindex is constant, determined at compile time. */
5294 rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
5295 else if (code->expr2->expr_type == EXPR_NULL)
5296 rhs = gfc_int_expr (0);
5299 tmp = gfc_trans_assignment (lhs, rhs, false);
5300 gfc_add_expr_to_block (&block, tmp);
5302 /* Insert another assignment which sets the '$size' field. */
5303 lhs = gfc_copy_expr (code->expr1);
5304 gfc_add_component_ref (lhs, "$size");
5305 if (code->expr2->ts.type == BT_DERIVED)
5307 /* Size is fixed at compile time. */
5309 gfc_init_se (&lse, NULL);
5310 gfc_conv_expr (&lse, lhs);
5311 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5312 gfc_add_modify (&block, lse.expr,
5313 fold_convert (TREE_TYPE (lse.expr), tmp));
5315 else if (code->expr2->expr_type == EXPR_NULL)
5317 rhs = gfc_int_expr (0);
5318 tmp = gfc_trans_assignment (lhs, rhs, false);
5319 gfc_add_expr_to_block (&block, tmp);
5324 gfc_free_expr (lhs);
5325 gfc_free_expr (rhs);
5328 /* Do the actual CLASS assignment. */
5329 if (code->expr2->ts.type == BT_CLASS)
5330 code->op = EXEC_ASSIGN;
5332 gfc_add_component_ref (code->expr1, "$data");
5334 if (code->op == EXEC_ASSIGN)
5335 tmp = gfc_trans_assign (code);
5336 else if (code->op == EXEC_POINTER_ASSIGN)
5337 tmp = gfc_trans_pointer_assign (code);
5341 gfc_add_expr_to_block (&block, tmp);
5343 return gfc_finish_block (&block);