1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se * se, gfc_se * parent)
66 memset (se, 0, sizeof (gfc_se));
67 gfc_init_block (&se->pre);
68 gfc_init_block (&se->post);
73 gfc_copy_se_loopvars (se, parent);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se * se)
110 if (CONSTANT_CLASS_P (se->expr))
113 /* We need a temporary for this result. */
114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115 gfc_add_modify (&se->pre, var, se->expr);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol * sym)
128 gcc_assert (sym->attr.dummy);
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
140 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
141 fold_convert (TREE_TYPE (decl), null_pointer_node));
143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
144 as actual argument to denote absent dummies. For array descriptors,
145 we thus also need to check the array descriptor. */
146 if (!sym->attr.pointer && !sym->attr.allocatable
147 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
148 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
151 tmp = build_fold_indirect_ref_loc (input_location, decl);
152 tmp = gfc_conv_array_data (tmp);
153 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
154 fold_convert (TREE_TYPE (tmp), null_pointer_node));
155 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
156 boolean_type_node, cond, tmp);
163 /* Converts a missing, dummy argument into a null or zero. */
166 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
171 present = gfc_conv_expr_present (arg->symtree->n.sym);
175 /* Create a temporary and convert it to the correct type. */
176 tmp = gfc_get_int_type (kind);
177 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
180 /* Test for a NULL value. */
181 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
182 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
183 tmp = gfc_evaluate_now (tmp, &se->pre);
184 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
188 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
190 build_zero_cst (TREE_TYPE (se->expr)));
191 tmp = gfc_evaluate_now (tmp, &se->pre);
195 if (ts.type == BT_CHARACTER)
197 tmp = build_int_cst (gfc_charlen_type_node, 0);
198 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
199 present, se->string_length, tmp);
200 tmp = gfc_evaluate_now (tmp, &se->pre);
201 se->string_length = tmp;
207 /* Get the character length of an expression, looking through gfc_refs
211 gfc_get_expr_charlen (gfc_expr *e)
216 gcc_assert (e->expr_type == EXPR_VARIABLE
217 && e->ts.type == BT_CHARACTER);
219 length = NULL; /* To silence compiler warning. */
221 if (is_subref_array (e) && e->ts.u.cl->length)
224 gfc_init_se (&tmpse, NULL);
225 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
226 e->ts.u.cl->backend_decl = tmpse.expr;
230 /* First candidate: if the variable is of type CHARACTER, the
231 expression's length could be the length of the character
233 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
234 length = e->symtree->n.sym->ts.u.cl->backend_decl;
236 /* Look through the reference chain for component references. */
237 for (r = e->ref; r; r = r->next)
242 if (r->u.c.component->ts.type == BT_CHARACTER)
243 length = r->u.c.component->ts.u.cl->backend_decl;
251 /* We should never got substring references here. These will be
252 broken down by the scalarizer. */
258 gcc_assert (length != NULL);
263 /* For each character array constructor subexpression without a ts.u.cl->length,
264 replace it by its first element (if there aren't any elements, the length
265 should already be set to zero). */
268 flatten_array_ctors_without_strlen (gfc_expr* e)
270 gfc_actual_arglist* arg;
276 switch (e->expr_type)
280 flatten_array_ctors_without_strlen (e->value.op.op1);
281 flatten_array_ctors_without_strlen (e->value.op.op2);
285 /* TODO: Implement as with EXPR_FUNCTION when needed. */
289 for (arg = e->value.function.actual; arg; arg = arg->next)
290 flatten_array_ctors_without_strlen (arg->expr);
295 /* We've found what we're looking for. */
296 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
301 gcc_assert (e->value.constructor);
303 c = gfc_constructor_first (e->value.constructor);
307 flatten_array_ctors_without_strlen (new_expr);
308 gfc_replace_expr (e, new_expr);
312 /* Otherwise, fall through to handle constructor elements. */
314 for (c = gfc_constructor_first (e->value.constructor);
315 c; c = gfc_constructor_next (c))
316 flatten_array_ctors_without_strlen (c->expr);
326 /* Generate code to initialize a string length variable. Returns the
327 value. For array constructors, cl->length might be NULL and in this case,
328 the first element of the constructor is needed. expr is the original
329 expression so we can access it but can be NULL if this is not needed. */
332 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
336 gfc_init_se (&se, NULL);
340 && TREE_CODE (cl->backend_decl) == VAR_DECL)
343 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
344 "flatten" array constructors by taking their first element; all elements
345 should be the same length or a cl->length should be present. */
350 expr_flat = gfc_copy_expr (expr);
351 flatten_array_ctors_without_strlen (expr_flat);
352 gfc_resolve_expr (expr_flat);
354 gfc_conv_expr (&se, expr_flat);
355 gfc_add_block_to_block (pblock, &se.pre);
356 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
358 gfc_free_expr (expr_flat);
362 /* Convert cl->length. */
364 gcc_assert (cl->length);
366 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
367 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
368 se.expr, build_int_cst (gfc_charlen_type_node, 0));
369 gfc_add_block_to_block (pblock, &se.pre);
371 if (cl->backend_decl)
372 gfc_add_modify (pblock, cl->backend_decl, se.expr);
374 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
379 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
380 const char *name, locus *where)
389 type = gfc_get_character_type (kind, ref->u.ss.length);
390 type = build_pointer_type (type);
392 gfc_init_se (&start, se);
393 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
394 gfc_add_block_to_block (&se->pre, &start.pre);
396 if (integer_onep (start.expr))
397 gfc_conv_string_parameter (se);
402 /* Avoid multiple evaluation of substring start. */
403 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
404 start.expr = gfc_evaluate_now (start.expr, &se->pre);
406 /* Change the start of the string. */
407 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
410 tmp = build_fold_indirect_ref_loc (input_location,
412 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
413 se->expr = gfc_build_addr_expr (type, tmp);
416 /* Length = end + 1 - start. */
417 gfc_init_se (&end, se);
418 if (ref->u.ss.end == NULL)
419 end.expr = se->string_length;
422 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
423 gfc_add_block_to_block (&se->pre, &end.pre);
427 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
428 end.expr = gfc_evaluate_now (end.expr, &se->pre);
430 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
432 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
433 boolean_type_node, start.expr,
436 /* Check lower bound. */
437 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
439 build_int_cst (gfc_charlen_type_node, 1));
440 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
441 boolean_type_node, nonempty, fault);
443 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
444 "is less than one", name);
446 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
448 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
449 fold_convert (long_integer_type_node,
453 /* Check upper bound. */
454 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
455 end.expr, se->string_length);
456 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
457 boolean_type_node, nonempty, fault);
459 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
460 "exceeds string length (%%ld)", name);
462 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
463 "exceeds string length (%%ld)");
464 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
465 fold_convert (long_integer_type_node, end.expr),
466 fold_convert (long_integer_type_node,
471 /* If the start and end expressions are equal, the length is one. */
473 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
474 tmp = build_int_cst (gfc_charlen_type_node, 1);
477 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
478 end.expr, start.expr);
479 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
480 build_int_cst (gfc_charlen_type_node, 1), tmp);
481 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
482 tmp, build_int_cst (gfc_charlen_type_node, 0));
485 se->string_length = tmp;
489 /* Convert a derived type component reference. */
492 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
499 c = ref->u.c.component;
501 gcc_assert (c->backend_decl);
503 field = c->backend_decl;
504 gcc_assert (TREE_CODE (field) == FIELD_DECL);
506 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
507 decl, field, NULL_TREE);
511 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
513 tmp = c->ts.u.cl->backend_decl;
514 /* Components must always be constant length. */
515 gcc_assert (tmp && INTEGER_CST_P (tmp));
516 se->string_length = tmp;
519 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
520 && c->ts.type != BT_CHARACTER)
521 || c->attr.proc_pointer)
522 se->expr = build_fold_indirect_ref_loc (input_location,
527 /* This function deals with component references to components of the
528 parent type for derived type extensons. */
530 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
538 c = ref->u.c.component;
540 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
541 parent.type = REF_COMPONENT;
544 parent.u.c.component = dt->components;
546 if (dt->backend_decl == NULL)
547 gfc_get_derived_type (dt);
549 if (dt->attr.extension && dt->components)
551 if (dt->attr.is_class)
552 cmp = dt->components;
554 cmp = dt->components->next;
555 /* Return if the component is not in the parent type. */
556 for (; cmp; cmp = cmp->next)
557 if (strcmp (c->name, cmp->name) == 0)
560 /* Otherwise build the reference and call self. */
561 gfc_conv_component_ref (se, &parent);
562 parent.u.c.sym = dt->components->ts.u.derived;
563 parent.u.c.component = c;
564 conv_parent_component_references (se, &parent);
568 /* Return the contents of a variable. Also handles reference/pointer
569 variables (all Fortran pointer references are implicit). */
572 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
576 tree parent_decl = NULL_TREE;
579 bool alternate_entry;
582 sym = expr->symtree->n.sym;
585 /* Check that something hasn't gone horribly wrong. */
586 gcc_assert (se->ss != gfc_ss_terminator);
587 gcc_assert (se->ss->expr == expr);
589 /* A scalarized term. We already know the descriptor. */
590 se->expr = se->ss->data.info.descriptor;
591 se->string_length = se->ss->string_length;
592 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
593 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
598 tree se_expr = NULL_TREE;
600 se->expr = gfc_get_symbol_decl (sym);
602 /* Deal with references to a parent results or entries by storing
603 the current_function_decl and moving to the parent_decl. */
604 return_value = sym->attr.function && sym->result == sym;
605 alternate_entry = sym->attr.function && sym->attr.entry
606 && sym->result == sym;
607 entry_master = sym->attr.result
608 && sym->ns->proc_name->attr.entry_master
609 && !gfc_return_by_reference (sym->ns->proc_name);
610 if (current_function_decl)
611 parent_decl = DECL_CONTEXT (current_function_decl);
613 if ((se->expr == parent_decl && return_value)
614 || (sym->ns && sym->ns->proc_name
616 && sym->ns->proc_name->backend_decl == parent_decl
617 && (alternate_entry || entry_master)))
622 /* Special case for assigning the return value of a function.
623 Self recursive functions must have an explicit return value. */
624 if (return_value && (se->expr == current_function_decl || parent_flag))
625 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
627 /* Similarly for alternate entry points. */
628 else if (alternate_entry
629 && (sym->ns->proc_name->backend_decl == current_function_decl
632 gfc_entry_list *el = NULL;
634 for (el = sym->ns->entries; el; el = el->next)
637 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
642 else if (entry_master
643 && (sym->ns->proc_name->backend_decl == current_function_decl
645 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
650 /* Procedure actual arguments. */
651 else if (sym->attr.flavor == FL_PROCEDURE
652 && se->expr != current_function_decl)
654 if (!sym->attr.dummy && !sym->attr.proc_pointer)
656 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
657 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
663 /* Dereference the expression, where needed. Since characters
664 are entirely different from other types, they are treated
666 if (sym->ts.type == BT_CHARACTER)
668 /* Dereference character pointer dummy arguments
670 if ((sym->attr.pointer || sym->attr.allocatable)
672 || sym->attr.function
673 || sym->attr.result))
674 se->expr = build_fold_indirect_ref_loc (input_location,
678 else if (!sym->attr.value)
680 /* Dereference non-character scalar dummy arguments. */
681 if (sym->attr.dummy && !sym->attr.dimension)
682 se->expr = build_fold_indirect_ref_loc (input_location,
685 /* Dereference scalar hidden result. */
686 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
687 && (sym->attr.function || sym->attr.result)
688 && !sym->attr.dimension && !sym->attr.pointer
689 && !sym->attr.always_explicit)
690 se->expr = build_fold_indirect_ref_loc (input_location,
693 /* Dereference non-character pointer variables.
694 These must be dummies, results, or scalars. */
695 if ((sym->attr.pointer || sym->attr.allocatable
696 || gfc_is_associate_pointer (sym))
698 || sym->attr.function
700 || !sym->attr.dimension))
701 se->expr = build_fold_indirect_ref_loc (input_location,
708 /* For character variables, also get the length. */
709 if (sym->ts.type == BT_CHARACTER)
711 /* If the character length of an entry isn't set, get the length from
712 the master function instead. */
713 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
714 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
716 se->string_length = sym->ts.u.cl->backend_decl;
717 gcc_assert (se->string_length);
725 /* Return the descriptor if that's what we want and this is an array
726 section reference. */
727 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
729 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
730 /* Return the descriptor for array pointers and allocations. */
732 && ref->next == NULL && (se->descriptor_only))
735 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
736 /* Return a pointer to an element. */
740 if (ref->u.c.sym->attr.extension)
741 conv_parent_component_references (se, ref);
743 gfc_conv_component_ref (se, ref);
747 gfc_conv_substring (se, ref, expr->ts.kind,
748 expr->symtree->name, &expr->where);
757 /* Pointer assignment, allocation or pass by reference. Arrays are handled
759 if (se->want_pointer)
761 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
762 gfc_conv_string_parameter (se);
764 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
769 /* Unary ops are easy... Or they would be if ! was a valid op. */
772 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
777 gcc_assert (expr->ts.type != BT_CHARACTER);
778 /* Initialize the operand. */
779 gfc_init_se (&operand, se);
780 gfc_conv_expr_val (&operand, expr->value.op.op1);
781 gfc_add_block_to_block (&se->pre, &operand.pre);
783 type = gfc_typenode_for_spec (&expr->ts);
785 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
786 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
787 All other unary operators have an equivalent GIMPLE unary operator. */
788 if (code == TRUTH_NOT_EXPR)
789 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
790 build_int_cst (type, 0));
792 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
796 /* Expand power operator to optimal multiplications when a value is raised
797 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
798 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
799 Programming", 3rd Edition, 1998. */
801 /* This code is mostly duplicated from expand_powi in the backend.
802 We establish the "optimal power tree" lookup table with the defined size.
803 The items in the table are the exponents used to calculate the index
804 exponents. Any integer n less than the value can get an "addition chain",
805 with the first node being one. */
806 #define POWI_TABLE_SIZE 256
808 /* The table is from builtins.c. */
809 static const unsigned char powi_table[POWI_TABLE_SIZE] =
811 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
812 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
813 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
814 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
815 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
816 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
817 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
818 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
819 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
820 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
821 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
822 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
823 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
824 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
825 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
826 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
827 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
828 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
829 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
830 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
831 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
832 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
833 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
834 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
835 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
836 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
837 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
838 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
839 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
840 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
841 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
842 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
845 /* If n is larger than lookup table's max index, we use the "window
847 #define POWI_WINDOW_SIZE 3
849 /* Recursive function to expand the power operator. The temporary
850 values are put in tmpvar. The function returns tmpvar[1] ** n. */
852 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
859 if (n < POWI_TABLE_SIZE)
864 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
865 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
869 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
870 op0 = gfc_conv_powi (se, n - digit, tmpvar);
871 op1 = gfc_conv_powi (se, digit, tmpvar);
875 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
879 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
880 tmp = gfc_evaluate_now (tmp, &se->pre);
882 if (n < POWI_TABLE_SIZE)
889 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
890 return 1. Else return 0 and a call to runtime library functions
891 will have to be built. */
893 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
898 tree vartmp[POWI_TABLE_SIZE];
900 unsigned HOST_WIDE_INT n;
903 /* If exponent is too large, we won't expand it anyway, so don't bother
904 with large integer values. */
905 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
908 m = double_int_to_shwi (TREE_INT_CST (rhs));
909 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
910 of the asymmetric range of the integer type. */
911 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
913 type = TREE_TYPE (lhs);
914 sgn = tree_int_cst_sgn (rhs);
916 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
917 || optimize_size) && (m > 2 || m < -1))
923 se->expr = gfc_build_const (type, integer_one_node);
927 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
928 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
930 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
931 lhs, build_int_cst (TREE_TYPE (lhs), -1));
932 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
933 lhs, build_int_cst (TREE_TYPE (lhs), 1));
936 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
939 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
940 boolean_type_node, tmp, cond);
941 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
942 tmp, build_int_cst (type, 1),
943 build_int_cst (type, 0));
947 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
948 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
949 build_int_cst (type, -1),
950 build_int_cst (type, 0));
951 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
952 cond, build_int_cst (type, 1), tmp);
956 memset (vartmp, 0, sizeof (vartmp));
960 tmp = gfc_build_const (type, integer_one_node);
961 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
965 se->expr = gfc_conv_powi (se, n, vartmp);
971 /* Power op (**). Constant integer exponent has special handling. */
974 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
976 tree gfc_int4_type_node;
983 gfc_init_se (&lse, se);
984 gfc_conv_expr_val (&lse, expr->value.op.op1);
985 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
986 gfc_add_block_to_block (&se->pre, &lse.pre);
988 gfc_init_se (&rse, se);
989 gfc_conv_expr_val (&rse, expr->value.op.op2);
990 gfc_add_block_to_block (&se->pre, &rse.pre);
992 if (expr->value.op.op2->ts.type == BT_INTEGER
993 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
994 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
997 gfc_int4_type_node = gfc_get_int_type (4);
999 kind = expr->value.op.op1->ts.kind;
1000 switch (expr->value.op.op2->ts.type)
1003 ikind = expr->value.op.op2->ts.kind;
1008 rse.expr = convert (gfc_int4_type_node, rse.expr);
1030 if (expr->value.op.op1->ts.type == BT_INTEGER)
1031 lse.expr = convert (gfc_int4_type_node, lse.expr);
1056 switch (expr->value.op.op1->ts.type)
1059 if (kind == 3) /* Case 16 was not handled properly above. */
1061 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1065 /* Use builtins for real ** int4. */
1071 fndecl = built_in_decls[BUILT_IN_POWIF];
1075 fndecl = built_in_decls[BUILT_IN_POWI];
1079 fndecl = built_in_decls[BUILT_IN_POWIL];
1083 /* Use the __builtin_powil() only if real(kind=16) is
1084 actually the C long double type. */
1085 if (!gfc_real16_is_float128)
1086 fndecl = built_in_decls[BUILT_IN_POWIL];
1094 /* If we don't have a good builtin for this, go for the
1095 library function. */
1097 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1101 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1110 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1114 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1122 se->expr = build_call_expr_loc (input_location,
1123 fndecl, 2, lse.expr, rse.expr);
1127 /* Generate code to allocate a string temporary. */
1130 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1135 if (gfc_can_put_var_on_stack (len))
1137 /* Create a temporary variable to hold the result. */
1138 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1139 gfc_charlen_type_node, len,
1140 build_int_cst (gfc_charlen_type_node, 1));
1141 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1143 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1144 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1146 tmp = build_array_type (TREE_TYPE (type), tmp);
1148 var = gfc_create_var (tmp, "str");
1149 var = gfc_build_addr_expr (type, var);
1153 /* Allocate a temporary to hold the result. */
1154 var = gfc_create_var (type, "pstr");
1155 tmp = gfc_call_malloc (&se->pre, type,
1156 fold_build2_loc (input_location, MULT_EXPR,
1157 TREE_TYPE (len), len,
1158 fold_convert (TREE_TYPE (len),
1159 TYPE_SIZE (type))));
1160 gfc_add_modify (&se->pre, var, tmp);
1162 /* Free the temporary afterwards. */
1163 tmp = gfc_call_free (convert (pvoid_type_node, var));
1164 gfc_add_expr_to_block (&se->post, tmp);
1171 /* Handle a string concatenation operation. A temporary will be allocated to
1175 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1178 tree len, type, var, tmp, fndecl;
1180 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1181 && expr->value.op.op2->ts.type == BT_CHARACTER);
1182 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1184 gfc_init_se (&lse, se);
1185 gfc_conv_expr (&lse, expr->value.op.op1);
1186 gfc_conv_string_parameter (&lse);
1187 gfc_init_se (&rse, se);
1188 gfc_conv_expr (&rse, expr->value.op.op2);
1189 gfc_conv_string_parameter (&rse);
1191 gfc_add_block_to_block (&se->pre, &lse.pre);
1192 gfc_add_block_to_block (&se->pre, &rse.pre);
1194 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1195 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1196 if (len == NULL_TREE)
1198 len = fold_build2_loc (input_location, PLUS_EXPR,
1199 TREE_TYPE (lse.string_length),
1200 lse.string_length, rse.string_length);
1203 type = build_pointer_type (type);
1205 var = gfc_conv_string_tmp (se, type, len);
1207 /* Do the actual concatenation. */
1208 if (expr->ts.kind == 1)
1209 fndecl = gfor_fndecl_concat_string;
1210 else if (expr->ts.kind == 4)
1211 fndecl = gfor_fndecl_concat_string_char4;
1215 tmp = build_call_expr_loc (input_location,
1216 fndecl, 6, len, var, lse.string_length, lse.expr,
1217 rse.string_length, rse.expr);
1218 gfc_add_expr_to_block (&se->pre, tmp);
1220 /* Add the cleanup for the operands. */
1221 gfc_add_block_to_block (&se->pre, &rse.post);
1222 gfc_add_block_to_block (&se->pre, &lse.post);
1225 se->string_length = len;
1228 /* Translates an op expression. Common (binary) cases are handled by this
1229 function, others are passed on. Recursion is used in either case.
1230 We use the fact that (op1.ts == op2.ts) (except for the power
1232 Operators need no special handling for scalarized expressions as long as
1233 they call gfc_conv_simple_val to get their operands.
1234 Character strings get special handling. */
1237 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1239 enum tree_code code;
1248 switch (expr->value.op.op)
1250 case INTRINSIC_PARENTHESES:
1251 if ((expr->ts.type == BT_REAL
1252 || expr->ts.type == BT_COMPLEX)
1253 && gfc_option.flag_protect_parens)
1255 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1256 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1261 case INTRINSIC_UPLUS:
1262 gfc_conv_expr (se, expr->value.op.op1);
1265 case INTRINSIC_UMINUS:
1266 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1270 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1273 case INTRINSIC_PLUS:
1277 case INTRINSIC_MINUS:
1281 case INTRINSIC_TIMES:
1285 case INTRINSIC_DIVIDE:
1286 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1287 an integer, we must round towards zero, so we use a
1289 if (expr->ts.type == BT_INTEGER)
1290 code = TRUNC_DIV_EXPR;
1295 case INTRINSIC_POWER:
1296 gfc_conv_power_op (se, expr);
1299 case INTRINSIC_CONCAT:
1300 gfc_conv_concat_op (se, expr);
1304 code = TRUTH_ANDIF_EXPR;
1309 code = TRUTH_ORIF_EXPR;
1313 /* EQV and NEQV only work on logicals, but since we represent them
1314 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1316 case INTRINSIC_EQ_OS:
1324 case INTRINSIC_NE_OS:
1325 case INTRINSIC_NEQV:
1332 case INTRINSIC_GT_OS:
1339 case INTRINSIC_GE_OS:
1346 case INTRINSIC_LT_OS:
1353 case INTRINSIC_LE_OS:
1359 case INTRINSIC_USER:
1360 case INTRINSIC_ASSIGN:
1361 /* These should be converted into function calls by the frontend. */
1365 fatal_error ("Unknown intrinsic op");
1369 /* The only exception to this is **, which is handled separately anyway. */
1370 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1372 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1376 gfc_init_se (&lse, se);
1377 gfc_conv_expr (&lse, expr->value.op.op1);
1378 gfc_add_block_to_block (&se->pre, &lse.pre);
1381 gfc_init_se (&rse, se);
1382 gfc_conv_expr (&rse, expr->value.op.op2);
1383 gfc_add_block_to_block (&se->pre, &rse.pre);
1387 gfc_conv_string_parameter (&lse);
1388 gfc_conv_string_parameter (&rse);
1390 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1391 rse.string_length, rse.expr,
1392 expr->value.op.op1->ts.kind,
1394 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1395 gfc_add_block_to_block (&lse.post, &rse.post);
1398 type = gfc_typenode_for_spec (&expr->ts);
1402 /* The result of logical ops is always boolean_type_node. */
1403 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1404 lse.expr, rse.expr);
1405 se->expr = convert (type, tmp);
1408 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1410 /* Add the post blocks. */
1411 gfc_add_block_to_block (&se->post, &rse.post);
1412 gfc_add_block_to_block (&se->post, &lse.post);
1415 /* If a string's length is one, we convert it to a single character. */
1418 gfc_string_to_single_character (tree len, tree str, int kind)
1420 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1422 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1425 if (TREE_INT_CST_LOW (len) == 1)
1427 str = fold_convert (gfc_get_pchar_type (kind), str);
1428 return build_fold_indirect_ref_loc (input_location, str);
1432 && TREE_CODE (str) == ADDR_EXPR
1433 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1434 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1435 && array_ref_low_bound (TREE_OPERAND (str, 0))
1436 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1437 && TREE_INT_CST_LOW (len) > 1
1438 && TREE_INT_CST_LOW (len)
1439 == (unsigned HOST_WIDE_INT)
1440 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1442 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1443 ret = build_fold_indirect_ref_loc (input_location, ret);
1444 if (TREE_CODE (ret) == INTEGER_CST)
1446 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1447 int i, length = TREE_STRING_LENGTH (string_cst);
1448 const char *ptr = TREE_STRING_POINTER (string_cst);
1450 for (i = 1; i < length; i++)
1463 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1466 if (sym->backend_decl)
1468 /* This becomes the nominal_type in
1469 function.c:assign_parm_find_data_types. */
1470 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1471 /* This becomes the passed_type in
1472 function.c:assign_parm_find_data_types. C promotes char to
1473 integer for argument passing. */
1474 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1476 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1481 /* If we have a constant character expression, make it into an
1483 if ((*expr)->expr_type == EXPR_CONSTANT)
1488 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1489 (int)(*expr)->value.character.string[0]);
1490 if ((*expr)->ts.kind != gfc_c_int_kind)
1492 /* The expr needs to be compatible with a C int. If the
1493 conversion fails, then the 2 causes an ICE. */
1494 ts.type = BT_INTEGER;
1495 ts.kind = gfc_c_int_kind;
1496 gfc_convert_type (*expr, &ts, 2);
1499 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1501 if ((*expr)->ref == NULL)
1503 se->expr = gfc_string_to_single_character
1504 (build_int_cst (integer_type_node, 1),
1505 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1507 ((*expr)->symtree->n.sym)),
1512 gfc_conv_variable (se, *expr);
1513 se->expr = gfc_string_to_single_character
1514 (build_int_cst (integer_type_node, 1),
1515 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1523 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1524 if STR is a string literal, otherwise return -1. */
1527 gfc_optimize_len_trim (tree len, tree str, int kind)
1530 && TREE_CODE (str) == ADDR_EXPR
1531 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1532 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1533 && array_ref_low_bound (TREE_OPERAND (str, 0))
1534 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1535 && TREE_INT_CST_LOW (len) >= 1
1536 && TREE_INT_CST_LOW (len)
1537 == (unsigned HOST_WIDE_INT)
1538 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1540 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1541 folded = build_fold_indirect_ref_loc (input_location, folded);
1542 if (TREE_CODE (folded) == INTEGER_CST)
1544 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1545 int length = TREE_STRING_LENGTH (string_cst);
1546 const char *ptr = TREE_STRING_POINTER (string_cst);
1548 for (; length > 0; length--)
1549 if (ptr[length - 1] != ' ')
1558 /* Compare two strings. If they are all single characters, the result is the
1559 subtraction of them. Otherwise, we build a library call. */
1562 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1563 enum tree_code code)
1569 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1570 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1572 sc1 = gfc_string_to_single_character (len1, str1, kind);
1573 sc2 = gfc_string_to_single_character (len2, str2, kind);
1575 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1577 /* Deal with single character specially. */
1578 sc1 = fold_convert (integer_type_node, sc1);
1579 sc2 = fold_convert (integer_type_node, sc2);
1580 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1584 if ((code == EQ_EXPR || code == NE_EXPR)
1586 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1588 /* If one string is a string literal with LEN_TRIM longer
1589 than the length of the second string, the strings
1591 int len = gfc_optimize_len_trim (len1, str1, kind);
1592 if (len > 0 && compare_tree_int (len2, len) < 0)
1593 return integer_one_node;
1594 len = gfc_optimize_len_trim (len2, str2, kind);
1595 if (len > 0 && compare_tree_int (len1, len) < 0)
1596 return integer_one_node;
1599 /* Build a call for the comparison. */
1601 fndecl = gfor_fndecl_compare_string;
1603 fndecl = gfor_fndecl_compare_string_char4;
1607 return build_call_expr_loc (input_location, fndecl, 4,
1608 len1, str1, len2, str2);
1612 /* Return the backend_decl for a procedure pointer component. */
1615 get_proc_ptr_comp (gfc_expr *e)
1621 gfc_init_se (&comp_se, NULL);
1622 e2 = gfc_copy_expr (e);
1623 /* We have to restore the expr type later so that gfc_free_expr frees
1624 the exact same thing that was allocated.
1625 TODO: This is ugly. */
1626 old_type = e2->expr_type;
1627 e2->expr_type = EXPR_VARIABLE;
1628 gfc_conv_expr (&comp_se, e2);
1629 e2->expr_type = old_type;
1631 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1636 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1640 if (gfc_is_proc_ptr_comp (expr, NULL))
1641 tmp = get_proc_ptr_comp (expr);
1642 else if (sym->attr.dummy)
1644 tmp = gfc_get_symbol_decl (sym);
1645 if (sym->attr.proc_pointer)
1646 tmp = build_fold_indirect_ref_loc (input_location,
1648 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1649 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1653 if (!sym->backend_decl)
1654 sym->backend_decl = gfc_get_extern_function_decl (sym);
1656 tmp = sym->backend_decl;
1658 if (sym->attr.cray_pointee)
1660 /* TODO - make the cray pointee a pointer to a procedure,
1661 assign the pointer to it and use it for the call. This
1663 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1664 gfc_get_symbol_decl (sym->cp_pointer));
1665 tmp = gfc_evaluate_now (tmp, &se->pre);
1668 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1670 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1671 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1678 /* Initialize MAPPING. */
1681 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1683 mapping->syms = NULL;
1684 mapping->charlens = NULL;
1688 /* Free all memory held by MAPPING (but not MAPPING itself). */
1691 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1693 gfc_interface_sym_mapping *sym;
1694 gfc_interface_sym_mapping *nextsym;
1696 gfc_charlen *nextcl;
1698 for (sym = mapping->syms; sym; sym = nextsym)
1700 nextsym = sym->next;
1701 sym->new_sym->n.sym->formal = NULL;
1702 gfc_free_symbol (sym->new_sym->n.sym);
1703 gfc_free_expr (sym->expr);
1704 gfc_free (sym->new_sym);
1707 for (cl = mapping->charlens; cl; cl = nextcl)
1710 gfc_free_expr (cl->length);
1716 /* Return a copy of gfc_charlen CL. Add the returned structure to
1717 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1719 static gfc_charlen *
1720 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1723 gfc_charlen *new_charlen;
1725 new_charlen = gfc_get_charlen ();
1726 new_charlen->next = mapping->charlens;
1727 new_charlen->length = gfc_copy_expr (cl->length);
1729 mapping->charlens = new_charlen;
1734 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1735 array variable that can be used as the actual argument for dummy
1736 argument SYM. Add any initialization code to BLOCK. PACKED is as
1737 for gfc_get_nodesc_array_type and DATA points to the first element
1738 in the passed array. */
1741 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1742 gfc_packed packed, tree data)
1747 type = gfc_typenode_for_spec (&sym->ts);
1748 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1749 !sym->attr.target && !sym->attr.pointer
1750 && !sym->attr.proc_pointer);
1752 var = gfc_create_var (type, "ifm");
1753 gfc_add_modify (block, var, fold_convert (type, data));
1759 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1760 and offset of descriptorless array type TYPE given that it has the same
1761 size as DESC. Add any set-up code to BLOCK. */
1764 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1771 offset = gfc_index_zero_node;
1772 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1774 dim = gfc_rank_cst[n];
1775 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1776 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1778 GFC_TYPE_ARRAY_LBOUND (type, n)
1779 = gfc_conv_descriptor_lbound_get (desc, dim);
1780 GFC_TYPE_ARRAY_UBOUND (type, n)
1781 = gfc_conv_descriptor_ubound_get (desc, dim);
1783 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1785 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1786 gfc_array_index_type,
1787 gfc_conv_descriptor_ubound_get (desc, dim),
1788 gfc_conv_descriptor_lbound_get (desc, dim));
1789 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1790 gfc_array_index_type,
1791 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1792 tmp = gfc_evaluate_now (tmp, block);
1793 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1795 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1796 GFC_TYPE_ARRAY_LBOUND (type, n),
1797 GFC_TYPE_ARRAY_STRIDE (type, n));
1798 offset = fold_build2_loc (input_location, MINUS_EXPR,
1799 gfc_array_index_type, offset, tmp);
1801 offset = gfc_evaluate_now (offset, block);
1802 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1806 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1807 in SE. The caller may still use se->expr and se->string_length after
1808 calling this function. */
1811 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1812 gfc_symbol * sym, gfc_se * se,
1815 gfc_interface_sym_mapping *sm;
1819 gfc_symbol *new_sym;
1821 gfc_symtree *new_symtree;
1823 /* Create a new symbol to represent the actual argument. */
1824 new_sym = gfc_new_symbol (sym->name, NULL);
1825 new_sym->ts = sym->ts;
1826 new_sym->as = gfc_copy_array_spec (sym->as);
1827 new_sym->attr.referenced = 1;
1828 new_sym->attr.dimension = sym->attr.dimension;
1829 new_sym->attr.contiguous = sym->attr.contiguous;
1830 new_sym->attr.codimension = sym->attr.codimension;
1831 new_sym->attr.pointer = sym->attr.pointer;
1832 new_sym->attr.allocatable = sym->attr.allocatable;
1833 new_sym->attr.flavor = sym->attr.flavor;
1834 new_sym->attr.function = sym->attr.function;
1836 /* Ensure that the interface is available and that
1837 descriptors are passed for array actual arguments. */
1838 if (sym->attr.flavor == FL_PROCEDURE)
1840 new_sym->formal = expr->symtree->n.sym->formal;
1841 new_sym->attr.always_explicit
1842 = expr->symtree->n.sym->attr.always_explicit;
1845 /* Create a fake symtree for it. */
1847 new_symtree = gfc_new_symtree (&root, sym->name);
1848 new_symtree->n.sym = new_sym;
1849 gcc_assert (new_symtree == root);
1851 /* Create a dummy->actual mapping. */
1852 sm = XCNEW (gfc_interface_sym_mapping);
1853 sm->next = mapping->syms;
1855 sm->new_sym = new_symtree;
1856 sm->expr = gfc_copy_expr (expr);
1859 /* Stabilize the argument's value. */
1860 if (!sym->attr.function && se)
1861 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1863 if (sym->ts.type == BT_CHARACTER)
1865 /* Create a copy of the dummy argument's length. */
1866 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1867 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1869 /* If the length is specified as "*", record the length that
1870 the caller is passing. We should use the callee's length
1871 in all other cases. */
1872 if (!new_sym->ts.u.cl->length && se)
1874 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1875 new_sym->ts.u.cl->backend_decl = se->string_length;
1882 /* Use the passed value as-is if the argument is a function. */
1883 if (sym->attr.flavor == FL_PROCEDURE)
1886 /* If the argument is either a string or a pointer to a string,
1887 convert it to a boundless character type. */
1888 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1890 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1891 tmp = build_pointer_type (tmp);
1892 if (sym->attr.pointer)
1893 value = build_fold_indirect_ref_loc (input_location,
1897 value = fold_convert (tmp, value);
1900 /* If the argument is a scalar, a pointer to an array or an allocatable,
1902 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1903 value = build_fold_indirect_ref_loc (input_location,
1906 /* For character(*), use the actual argument's descriptor. */
1907 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1908 value = build_fold_indirect_ref_loc (input_location,
1911 /* If the argument is an array descriptor, use it to determine
1912 information about the actual argument's shape. */
1913 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1914 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1916 /* Get the actual argument's descriptor. */
1917 desc = build_fold_indirect_ref_loc (input_location,
1920 /* Create the replacement variable. */
1921 tmp = gfc_conv_descriptor_data_get (desc);
1922 value = gfc_get_interface_mapping_array (&se->pre, sym,
1925 /* Use DESC to work out the upper bounds, strides and offset. */
1926 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1929 /* Otherwise we have a packed array. */
1930 value = gfc_get_interface_mapping_array (&se->pre, sym,
1931 PACKED_FULL, se->expr);
1933 new_sym->backend_decl = value;
1937 /* Called once all dummy argument mappings have been added to MAPPING,
1938 but before the mapping is used to evaluate expressions. Pre-evaluate
1939 the length of each argument, adding any initialization code to PRE and
1940 any finalization code to POST. */
1943 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1944 stmtblock_t * pre, stmtblock_t * post)
1946 gfc_interface_sym_mapping *sym;
1950 for (sym = mapping->syms; sym; sym = sym->next)
1951 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1952 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1954 expr = sym->new_sym->n.sym->ts.u.cl->length;
1955 gfc_apply_interface_mapping_to_expr (mapping, expr);
1956 gfc_init_se (&se, NULL);
1957 gfc_conv_expr (&se, expr);
1958 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1959 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1960 gfc_add_block_to_block (pre, &se.pre);
1961 gfc_add_block_to_block (post, &se.post);
1963 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1968 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1972 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1973 gfc_constructor_base base)
1976 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1978 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1981 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1982 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1983 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1989 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1993 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1998 for (; ref; ref = ref->next)
2002 for (n = 0; n < ref->u.ar.dimen; n++)
2004 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2005 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2006 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2008 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2015 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2016 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2022 /* Convert intrinsic function calls into result expressions. */
2025 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2033 arg1 = expr->value.function.actual->expr;
2034 if (expr->value.function.actual->next)
2035 arg2 = expr->value.function.actual->next->expr;
2039 sym = arg1->symtree->n.sym;
2041 if (sym->attr.dummy)
2046 switch (expr->value.function.isym->id)
2049 /* TODO figure out why this condition is necessary. */
2050 if (sym->attr.function
2051 && (arg1->ts.u.cl->length == NULL
2052 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2053 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2056 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2060 if (!sym->as || sym->as->rank == 0)
2063 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2065 dup = mpz_get_si (arg2->value.integer);
2070 dup = sym->as->rank;
2074 for (; d < dup; d++)
2078 if (!sym->as->upper[d] || !sym->as->lower[d])
2080 gfc_free_expr (new_expr);
2084 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2085 gfc_get_int_expr (gfc_default_integer_kind,
2087 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2089 new_expr = gfc_multiply (new_expr, tmp);
2095 case GFC_ISYM_LBOUND:
2096 case GFC_ISYM_UBOUND:
2097 /* TODO These implementations of lbound and ubound do not limit if
2098 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2100 if (!sym->as || sym->as->rank == 0)
2103 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2104 d = mpz_get_si (arg2->value.integer) - 1;
2106 /* TODO: If the need arises, this could produce an array of
2110 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2112 if (sym->as->lower[d])
2113 new_expr = gfc_copy_expr (sym->as->lower[d]);
2117 if (sym->as->upper[d])
2118 new_expr = gfc_copy_expr (sym->as->upper[d]);
2126 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2130 gfc_replace_expr (expr, new_expr);
2136 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2137 gfc_interface_mapping * mapping)
2139 gfc_formal_arglist *f;
2140 gfc_actual_arglist *actual;
2142 actual = expr->value.function.actual;
2143 f = map_expr->symtree->n.sym->formal;
2145 for (; f && actual; f = f->next, actual = actual->next)
2150 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2153 if (map_expr->symtree->n.sym->attr.dimension)
2158 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2160 for (d = 0; d < as->rank; d++)
2162 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2163 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2166 expr->value.function.esym->as = as;
2169 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2171 expr->value.function.esym->ts.u.cl->length
2172 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2174 gfc_apply_interface_mapping_to_expr (mapping,
2175 expr->value.function.esym->ts.u.cl->length);
2180 /* EXPR is a copy of an expression that appeared in the interface
2181 associated with MAPPING. Walk it recursively looking for references to
2182 dummy arguments that MAPPING maps to actual arguments. Replace each such
2183 reference with a reference to the associated actual argument. */
2186 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2189 gfc_interface_sym_mapping *sym;
2190 gfc_actual_arglist *actual;
2195 /* Copying an expression does not copy its length, so do that here. */
2196 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2198 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2199 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2202 /* Apply the mapping to any references. */
2203 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2205 /* ...and to the expression's symbol, if it has one. */
2206 /* TODO Find out why the condition on expr->symtree had to be moved into
2207 the loop rather than being outside it, as originally. */
2208 for (sym = mapping->syms; sym; sym = sym->next)
2209 if (expr->symtree && sym->old == expr->symtree->n.sym)
2211 if (sym->new_sym->n.sym->backend_decl)
2212 expr->symtree = sym->new_sym;
2214 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2217 /* ...and to subexpressions in expr->value. */
2218 switch (expr->expr_type)
2223 case EXPR_SUBSTRING:
2227 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2228 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2232 for (actual = expr->value.function.actual; actual; actual = actual->next)
2233 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2235 if (expr->value.function.esym == NULL
2236 && expr->value.function.isym != NULL
2237 && expr->value.function.actual->expr->symtree
2238 && gfc_map_intrinsic_function (expr, mapping))
2241 for (sym = mapping->syms; sym; sym = sym->next)
2242 if (sym->old == expr->value.function.esym)
2244 expr->value.function.esym = sym->new_sym->n.sym;
2245 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2246 expr->value.function.esym->result = sym->new_sym->n.sym;
2251 case EXPR_STRUCTURE:
2252 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2265 /* Evaluate interface expression EXPR using MAPPING. Store the result
2269 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2270 gfc_se * se, gfc_expr * expr)
2272 expr = gfc_copy_expr (expr);
2273 gfc_apply_interface_mapping_to_expr (mapping, expr);
2274 gfc_conv_expr (se, expr);
2275 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2276 gfc_free_expr (expr);
2280 /* Returns a reference to a temporary array into which a component of
2281 an actual argument derived type array is copied and then returned
2282 after the function call. */
2284 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2285 sym_intent intent, bool formal_ptr)
2303 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2305 gfc_init_se (&lse, NULL);
2306 gfc_init_se (&rse, NULL);
2308 /* Walk the argument expression. */
2309 rss = gfc_walk_expr (expr);
2311 gcc_assert (rss != gfc_ss_terminator);
2313 /* Initialize the scalarizer. */
2314 gfc_init_loopinfo (&loop);
2315 gfc_add_ss_to_loop (&loop, rss);
2317 /* Calculate the bounds of the scalarization. */
2318 gfc_conv_ss_startstride (&loop);
2320 /* Build an ss for the temporary. */
2321 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2322 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2324 base_type = gfc_typenode_for_spec (&expr->ts);
2325 if (GFC_ARRAY_TYPE_P (base_type)
2326 || GFC_DESCRIPTOR_TYPE_P (base_type))
2327 base_type = gfc_get_element_type (base_type);
2329 loop.temp_ss = gfc_get_ss ();;
2330 loop.temp_ss->type = GFC_SS_TEMP;
2331 loop.temp_ss->data.temp.type = base_type;
2333 if (expr->ts.type == BT_CHARACTER)
2334 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2336 loop.temp_ss->string_length = NULL;
2338 parmse->string_length = loop.temp_ss->string_length;
2339 loop.temp_ss->data.temp.dimen = loop.dimen;
2340 loop.temp_ss->next = gfc_ss_terminator;
2342 /* Associate the SS with the loop. */
2343 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2345 /* Setup the scalarizing loops. */
2346 gfc_conv_loop_setup (&loop, &expr->where);
2348 /* Pass the temporary descriptor back to the caller. */
2349 info = &loop.temp_ss->data.info;
2350 parmse->expr = info->descriptor;
2352 /* Setup the gfc_se structures. */
2353 gfc_copy_loopinfo_to_se (&lse, &loop);
2354 gfc_copy_loopinfo_to_se (&rse, &loop);
2357 lse.ss = loop.temp_ss;
2358 gfc_mark_ss_chain_used (rss, 1);
2359 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2361 /* Start the scalarized loop body. */
2362 gfc_start_scalarized_body (&loop, &body);
2364 /* Translate the expression. */
2365 gfc_conv_expr (&rse, expr);
2367 gfc_conv_tmp_array_ref (&lse);
2369 if (intent != INTENT_OUT)
2371 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2372 gfc_add_expr_to_block (&body, tmp);
2373 gcc_assert (rse.ss == gfc_ss_terminator);
2374 gfc_trans_scalarizing_loops (&loop, &body);
2378 /* Make sure that the temporary declaration survives by merging
2379 all the loop declarations into the current context. */
2380 for (n = 0; n < loop.dimen; n++)
2382 gfc_merge_block_scope (&body);
2383 body = loop.code[loop.order[n]];
2385 gfc_merge_block_scope (&body);
2388 /* Add the post block after the second loop, so that any
2389 freeing of allocated memory is done at the right time. */
2390 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2392 /**********Copy the temporary back again.*********/
2394 gfc_init_se (&lse, NULL);
2395 gfc_init_se (&rse, NULL);
2397 /* Walk the argument expression. */
2398 lss = gfc_walk_expr (expr);
2399 rse.ss = loop.temp_ss;
2402 /* Initialize the scalarizer. */
2403 gfc_init_loopinfo (&loop2);
2404 gfc_add_ss_to_loop (&loop2, lss);
2406 /* Calculate the bounds of the scalarization. */
2407 gfc_conv_ss_startstride (&loop2);
2409 /* Setup the scalarizing loops. */
2410 gfc_conv_loop_setup (&loop2, &expr->where);
2412 gfc_copy_loopinfo_to_se (&lse, &loop2);
2413 gfc_copy_loopinfo_to_se (&rse, &loop2);
2415 gfc_mark_ss_chain_used (lss, 1);
2416 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2418 /* Declare the variable to hold the temporary offset and start the
2419 scalarized loop body. */
2420 offset = gfc_create_var (gfc_array_index_type, NULL);
2421 gfc_start_scalarized_body (&loop2, &body);
2423 /* Build the offsets for the temporary from the loop variables. The
2424 temporary array has lbounds of zero and strides of one in all
2425 dimensions, so this is very simple. The offset is only computed
2426 outside the innermost loop, so the overall transfer could be
2427 optimized further. */
2428 info = &rse.ss->data.info;
2429 dimen = info->dimen;
2431 tmp_index = gfc_index_zero_node;
2432 for (n = dimen - 1; n > 0; n--)
2435 tmp = rse.loop->loopvar[n];
2436 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2437 tmp, rse.loop->from[n]);
2438 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2441 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2442 gfc_array_index_type,
2443 rse.loop->to[n-1], rse.loop->from[n-1]);
2444 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2445 gfc_array_index_type,
2446 tmp_str, gfc_index_one_node);
2448 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2449 gfc_array_index_type, tmp, tmp_str);
2452 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2453 gfc_array_index_type,
2454 tmp_index, rse.loop->from[0]);
2455 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2457 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2458 gfc_array_index_type,
2459 rse.loop->loopvar[0], offset);
2461 /* Now use the offset for the reference. */
2462 tmp = build_fold_indirect_ref_loc (input_location,
2464 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2466 if (expr->ts.type == BT_CHARACTER)
2467 rse.string_length = expr->ts.u.cl->backend_decl;
2469 gfc_conv_expr (&lse, expr);
2471 gcc_assert (lse.ss == gfc_ss_terminator);
2473 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2474 gfc_add_expr_to_block (&body, tmp);
2476 /* Generate the copying loops. */
2477 gfc_trans_scalarizing_loops (&loop2, &body);
2479 /* Wrap the whole thing up by adding the second loop to the post-block
2480 and following it by the post-block of the first loop. In this way,
2481 if the temporary needs freeing, it is done after use! */
2482 if (intent != INTENT_IN)
2484 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2485 gfc_add_block_to_block (&parmse->post, &loop2.post);
2488 gfc_add_block_to_block (&parmse->post, &loop.post);
2490 gfc_cleanup_loop (&loop);
2491 gfc_cleanup_loop (&loop2);
2493 /* Pass the string length to the argument expression. */
2494 if (expr->ts.type == BT_CHARACTER)
2495 parmse->string_length = expr->ts.u.cl->backend_decl;
2497 /* Determine the offset for pointer formal arguments and set the
2501 size = gfc_index_one_node;
2502 offset = gfc_index_zero_node;
2503 for (n = 0; n < dimen; n++)
2505 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2507 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2508 gfc_array_index_type, tmp,
2509 gfc_index_one_node);
2510 gfc_conv_descriptor_ubound_set (&parmse->pre,
2514 gfc_conv_descriptor_lbound_set (&parmse->pre,
2517 gfc_index_one_node);
2518 size = gfc_evaluate_now (size, &parmse->pre);
2519 offset = fold_build2_loc (input_location, MINUS_EXPR,
2520 gfc_array_index_type,
2522 offset = gfc_evaluate_now (offset, &parmse->pre);
2523 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2524 gfc_array_index_type,
2525 rse.loop->to[n], rse.loop->from[n]);
2526 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2527 gfc_array_index_type,
2528 tmp, gfc_index_one_node);
2529 size = fold_build2_loc (input_location, MULT_EXPR,
2530 gfc_array_index_type, size, tmp);
2533 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2537 /* We want either the address for the data or the address of the descriptor,
2538 depending on the mode of passing array arguments. */
2540 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2542 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2548 /* Generate the code for argument list functions. */
2551 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2553 /* Pass by value for g77 %VAL(arg), pass the address
2554 indirectly for %LOC, else by reference. Thus %REF
2555 is a "do-nothing" and %LOC is the same as an F95
2557 if (strncmp (name, "%VAL", 4) == 0)
2558 gfc_conv_expr (se, expr);
2559 else if (strncmp (name, "%LOC", 4) == 0)
2561 gfc_conv_expr_reference (se, expr);
2562 se->expr = gfc_build_addr_expr (NULL, se->expr);
2564 else if (strncmp (name, "%REF", 4) == 0)
2565 gfc_conv_expr_reference (se, expr);
2567 gfc_error ("Unknown argument list function at %L", &expr->where);
2571 /* Takes a derived type expression and returns the address of a temporary
2572 class object of the 'declared' type. */
2574 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2575 gfc_typespec class_ts)
2579 gfc_symbol *declared = class_ts.u.derived;
2585 /* The derived type needs to be converted to a temporary
2587 tmp = gfc_typenode_for_spec (&class_ts);
2588 var = gfc_create_var (tmp, "class");
2591 cmp = gfc_find_component (declared, "_vptr", true, true);
2592 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2593 TREE_TYPE (cmp->backend_decl),
2594 var, cmp->backend_decl, NULL_TREE);
2596 /* Remember the vtab corresponds to the derived type
2597 not to the class declared type. */
2598 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2600 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2601 gfc_add_modify (&parmse->pre, ctree,
2602 fold_convert (TREE_TYPE (ctree), tmp));
2604 /* Now set the data field. */
2605 cmp = gfc_find_component (declared, "_data", true, true);
2606 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2607 TREE_TYPE (cmp->backend_decl),
2608 var, cmp->backend_decl, NULL_TREE);
2609 ss = gfc_walk_expr (e);
2610 if (ss == gfc_ss_terminator)
2613 gfc_conv_expr_reference (parmse, e);
2614 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2615 gfc_add_modify (&parmse->pre, ctree, tmp);
2620 gfc_conv_expr (parmse, e);
2621 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2624 /* Pass the address of the class object. */
2625 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2629 /* The following routine generates code for the intrinsic
2630 procedures from the ISO_C_BINDING module:
2632 * C_FUNLOC (function)
2633 * C_F_POINTER (subroutine)
2634 * C_F_PROCPOINTER (subroutine)
2635 * C_ASSOCIATED (function)
2636 One exception which is not handled here is C_F_POINTER with non-scalar
2637 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2640 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2641 gfc_actual_arglist * arg)
2646 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2648 if (arg->expr->rank == 0)
2649 gfc_conv_expr_reference (se, arg->expr);
2653 /* This is really the actual arg because no formal arglist is
2654 created for C_LOC. */
2655 fsym = arg->expr->symtree->n.sym;
2657 /* We should want it to do g77 calling convention. */
2659 && !(fsym->attr.pointer || fsym->attr.allocatable)
2660 && fsym->as->type != AS_ASSUMED_SHAPE;
2661 f = f || !sym->attr.always_explicit;
2663 argss = gfc_walk_expr (arg->expr);
2664 gfc_conv_array_parameter (se, arg->expr, argss, f,
2668 /* TODO -- the following two lines shouldn't be necessary, but if
2669 they're removed, a bug is exposed later in the code path.
2670 This workaround was thus introduced, but will have to be
2671 removed; please see PR 35150 for details about the issue. */
2672 se->expr = convert (pvoid_type_node, se->expr);
2673 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2677 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2679 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2680 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2681 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2682 gfc_conv_expr_reference (se, arg->expr);
2686 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2687 && arg->next->expr->rank == 0)
2688 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2690 /* Convert c_f_pointer if fptr is a scalar
2691 and convert c_f_procpointer. */
2695 gfc_init_se (&cptrse, NULL);
2696 gfc_conv_expr (&cptrse, arg->expr);
2697 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2698 gfc_add_block_to_block (&se->post, &cptrse.post);
2700 gfc_init_se (&fptrse, NULL);
2701 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2702 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2703 fptrse.want_pointer = 1;
2705 gfc_conv_expr (&fptrse, arg->next->expr);
2706 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2707 gfc_add_block_to_block (&se->post, &fptrse.post);
2709 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2710 && arg->next->expr->symtree->n.sym->attr.dummy)
2711 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2714 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2715 TREE_TYPE (fptrse.expr),
2717 fold_convert (TREE_TYPE (fptrse.expr),
2722 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2727 /* Build the addr_expr for the first argument. The argument is
2728 already an *address* so we don't need to set want_pointer in
2730 gfc_init_se (&arg1se, NULL);
2731 gfc_conv_expr (&arg1se, arg->expr);
2732 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2733 gfc_add_block_to_block (&se->post, &arg1se.post);
2735 /* See if we were given two arguments. */
2736 if (arg->next == NULL)
2737 /* Only given one arg so generate a null and do a
2738 not-equal comparison against the first arg. */
2739 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2741 fold_convert (TREE_TYPE (arg1se.expr),
2742 null_pointer_node));
2748 /* Given two arguments so build the arg2se from second arg. */
2749 gfc_init_se (&arg2se, NULL);
2750 gfc_conv_expr (&arg2se, arg->next->expr);
2751 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2752 gfc_add_block_to_block (&se->post, &arg2se.post);
2754 /* Generate test to compare that the two args are equal. */
2755 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2756 arg1se.expr, arg2se.expr);
2757 /* Generate test to ensure that the first arg is not null. */
2758 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2760 arg1se.expr, null_pointer_node);
2762 /* Finally, the generated test must check that both arg1 is not
2763 NULL and that it is equal to the second arg. */
2764 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2766 not_null_expr, eq_expr);
2772 /* Nothing was done. */
2776 /* Generate code for a procedure call. Note can return se->post != NULL.
2777 If se->direct_byref is set then se->expr contains the return parameter.
2778 Return nonzero, if the call has alternate specifiers.
2779 'expr' is only needed for procedure pointer components. */
2782 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2783 gfc_actual_arglist * args, gfc_expr * expr,
2784 VEC(tree,gc) *append_args)
2786 gfc_interface_mapping mapping;
2787 VEC(tree,gc) *arglist;
2788 VEC(tree,gc) *retargs;
2799 VEC(tree,gc) *stringargs;
2801 gfc_formal_arglist *formal;
2802 gfc_actual_arglist *arg;
2803 int has_alternate_specifier = 0;
2804 bool need_interface_mapping;
2811 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2812 gfc_component *comp = NULL;
2822 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2823 && conv_isocbinding_procedure (se, sym, args))
2826 gfc_is_proc_ptr_comp (expr, &comp);
2830 if (!sym->attr.elemental)
2832 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2833 if (se->ss->useflags)
2835 gcc_assert ((!comp && gfc_return_by_reference (sym)
2836 && sym->result->attr.dimension)
2837 || (comp && comp->attr.dimension));
2838 gcc_assert (se->loop != NULL);
2840 /* Access the previously obtained result. */
2841 gfc_conv_tmp_array_ref (se);
2845 info = &se->ss->data.info;
2850 gfc_init_block (&post);
2851 gfc_init_interface_mapping (&mapping);
2854 formal = sym->formal;
2855 need_interface_mapping = sym->attr.dimension ||
2856 (sym->ts.type == BT_CHARACTER
2857 && sym->ts.u.cl->length
2858 && sym->ts.u.cl->length->expr_type
2863 formal = comp->formal;
2864 need_interface_mapping = comp->attr.dimension ||
2865 (comp->ts.type == BT_CHARACTER
2866 && comp->ts.u.cl->length
2867 && comp->ts.u.cl->length->expr_type
2871 /* Evaluate the arguments. */
2872 for (arg = args; arg != NULL;
2873 arg = arg->next, formal = formal ? formal->next : NULL)
2876 fsym = formal ? formal->sym : NULL;
2877 parm_kind = MISSING;
2881 if (se->ignore_optional)
2883 /* Some intrinsics have already been resolved to the correct
2887 else if (arg->label)
2889 has_alternate_specifier = 1;
2894 /* Pass a NULL pointer for an absent arg. */
2895 gfc_init_se (&parmse, NULL);
2896 parmse.expr = null_pointer_node;
2897 if (arg->missing_arg_type == BT_CHARACTER)
2898 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2901 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2903 /* Pass a NULL pointer to denote an absent arg. */
2904 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2905 gfc_init_se (&parmse, NULL);
2906 parmse.expr = null_pointer_node;
2907 if (arg->missing_arg_type == BT_CHARACTER)
2908 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2910 else if (fsym && fsym->ts.type == BT_CLASS
2911 && e->ts.type == BT_DERIVED)
2913 /* The derived type needs to be converted to a temporary
2915 gfc_init_se (&parmse, se);
2916 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2918 else if (se->ss && se->ss->useflags)
2920 /* An elemental function inside a scalarized loop. */
2921 gfc_init_se (&parmse, se);
2922 gfc_conv_expr_reference (&parmse, e);
2923 parm_kind = ELEMENTAL;
2927 /* A scalar or transformational function. */
2928 gfc_init_se (&parmse, NULL);
2929 argss = gfc_walk_expr (e);
2931 if (argss == gfc_ss_terminator)
2933 if (e->expr_type == EXPR_VARIABLE
2934 && e->symtree->n.sym->attr.cray_pointee
2935 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2937 /* The Cray pointer needs to be converted to a pointer to
2938 a type given by the expression. */
2939 gfc_conv_expr (&parmse, e);
2940 type = build_pointer_type (TREE_TYPE (parmse.expr));
2941 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2942 parmse.expr = convert (type, tmp);
2944 else if (fsym && fsym->attr.value)
2946 if (fsym->ts.type == BT_CHARACTER
2947 && fsym->ts.is_c_interop
2948 && fsym->ns->proc_name != NULL
2949 && fsym->ns->proc_name->attr.is_bind_c)
2952 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2953 if (parmse.expr == NULL)
2954 gfc_conv_expr (&parmse, e);
2957 gfc_conv_expr (&parmse, e);
2959 else if (arg->name && arg->name[0] == '%')
2960 /* Argument list functions %VAL, %LOC and %REF are signalled
2961 through arg->name. */
2962 conv_arglist_function (&parmse, arg->expr, arg->name);
2963 else if ((e->expr_type == EXPR_FUNCTION)
2964 && ((e->value.function.esym
2965 && e->value.function.esym->result->attr.pointer)
2966 || (!e->value.function.esym
2967 && e->symtree->n.sym->attr.pointer))
2968 && fsym && fsym->attr.target)
2970 gfc_conv_expr (&parmse, e);
2971 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2973 else if (e->expr_type == EXPR_FUNCTION
2974 && e->symtree->n.sym->result
2975 && e->symtree->n.sym->result != e->symtree->n.sym
2976 && e->symtree->n.sym->result->attr.proc_pointer)
2978 /* Functions returning procedure pointers. */
2979 gfc_conv_expr (&parmse, e);
2980 if (fsym && fsym->attr.proc_pointer)
2981 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2985 gfc_conv_expr_reference (&parmse, e);
2987 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2988 allocated on entry, it must be deallocated. */
2989 if (fsym && fsym->attr.allocatable
2990 && fsym->attr.intent == INTENT_OUT)
2994 gfc_init_block (&block);
2995 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2997 gfc_add_expr_to_block (&block, tmp);
2998 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2999 void_type_node, parmse.expr,
3001 gfc_add_expr_to_block (&block, tmp);
3003 if (fsym->attr.optional
3004 && e->expr_type == EXPR_VARIABLE
3005 && e->symtree->n.sym->attr.optional)
3007 tmp = fold_build3_loc (input_location, COND_EXPR,
3009 gfc_conv_expr_present (e->symtree->n.sym),
3010 gfc_finish_block (&block),
3011 build_empty_stmt (input_location));
3014 tmp = gfc_finish_block (&block);
3016 gfc_add_expr_to_block (&se->pre, tmp);
3019 if (fsym && e->expr_type != EXPR_NULL
3020 && ((fsym->attr.pointer
3021 && fsym->attr.flavor != FL_PROCEDURE)
3022 || (fsym->attr.proc_pointer
3023 && !(e->expr_type == EXPR_VARIABLE
3024 && e->symtree->n.sym->attr.dummy))
3025 || (e->expr_type == EXPR_VARIABLE
3026 && gfc_is_proc_ptr_comp (e, NULL))
3027 || fsym->attr.allocatable))
3029 /* Scalar pointer dummy args require an extra level of
3030 indirection. The null pointer already contains
3031 this level of indirection. */
3032 parm_kind = SCALAR_POINTER;
3033 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3039 /* If the procedure requires an explicit interface, the actual
3040 argument is passed according to the corresponding formal
3041 argument. If the corresponding formal argument is a POINTER,
3042 ALLOCATABLE or assumed shape, we do not use g77's calling
3043 convention, and pass the address of the array descriptor
3044 instead. Otherwise we use g77's calling convention. */
3047 && !(fsym->attr.pointer || fsym->attr.allocatable)
3048 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3050 f = f || !comp->attr.always_explicit;
3052 f = f || !sym->attr.always_explicit;
3054 /* If the argument is a function call that may not create
3055 a temporary for the result, we have to check that we
3056 can do it, i.e. that there is no alias between this
3057 argument and another one. */
3058 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3063 intent = fsym->attr.intent;
3065 intent = INTENT_UNKNOWN;
3067 if (gfc_check_fncall_dependency (e, intent, sym, args,
3069 parmse.force_tmp = 1;
3072 if (e->expr_type == EXPR_VARIABLE
3073 && is_subref_array (e))
3074 /* The actual argument is a component reference to an
3075 array of derived types. In this case, the argument
3076 is converted to a temporary, which is passed and then
3077 written back after the procedure call. */
3078 gfc_conv_subref_array_arg (&parmse, e, f,
3079 fsym ? fsym->attr.intent : INTENT_INOUT,
3080 fsym && fsym->attr.pointer);
3082 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3085 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3086 allocated on entry, it must be deallocated. */
3087 if (fsym && fsym->attr.allocatable
3088 && fsym->attr.intent == INTENT_OUT)
3090 tmp = build_fold_indirect_ref_loc (input_location,
3092 tmp = gfc_trans_dealloc_allocated (tmp);
3093 if (fsym->attr.optional
3094 && e->expr_type == EXPR_VARIABLE
3095 && e->symtree->n.sym->attr.optional)
3096 tmp = fold_build3_loc (input_location, COND_EXPR,
3098 gfc_conv_expr_present (e->symtree->n.sym),
3099 tmp, build_empty_stmt (input_location));
3100 gfc_add_expr_to_block (&se->pre, tmp);
3105 /* The case with fsym->attr.optional is that of a user subroutine
3106 with an interface indicating an optional argument. When we call
3107 an intrinsic subroutine, however, fsym is NULL, but we might still
3108 have an optional argument, so we proceed to the substitution
3110 if (e && (fsym == NULL || fsym->attr.optional))
3112 /* If an optional argument is itself an optional dummy argument,
3113 check its presence and substitute a null if absent. This is
3114 only needed when passing an array to an elemental procedure
3115 as then array elements are accessed - or no NULL pointer is
3116 allowed and a "1" or "0" should be passed if not present.
3117 When passing a non-array-descriptor full array to a
3118 non-array-descriptor dummy, no check is needed. For
3119 array-descriptor actual to array-descriptor dummy, see
3120 PR 41911 for why a check has to be inserted.
3121 fsym == NULL is checked as intrinsics required the descriptor
3122 but do not always set fsym. */
3123 if (e->expr_type == EXPR_VARIABLE
3124 && e->symtree->n.sym->attr.optional
3125 && ((e->rank > 0 && sym->attr.elemental)
3126 || e->representation.length || e->ts.type == BT_CHARACTER
3130 && (fsym->as->type == AS_ASSUMED_SHAPE
3131 || fsym->as->type == AS_DEFERRED))))))
3132 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3133 e->representation.length);
3138 /* Obtain the character length of an assumed character length
3139 length procedure from the typespec. */
3140 if (fsym->ts.type == BT_CHARACTER
3141 && parmse.string_length == NULL_TREE
3142 && e->ts.type == BT_PROCEDURE
3143 && e->symtree->n.sym->ts.type == BT_CHARACTER
3144 && e->symtree->n.sym->ts.u.cl->length != NULL
3145 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3147 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3148 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3152 if (fsym && need_interface_mapping && e)
3153 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3155 gfc_add_block_to_block (&se->pre, &parmse.pre);
3156 gfc_add_block_to_block (&post, &parmse.post);
3158 /* Allocated allocatable components of derived types must be
3159 deallocated for non-variable scalars. Non-variable arrays are
3160 dealt with in trans-array.c(gfc_conv_array_parameter). */
3161 if (e && e->ts.type == BT_DERIVED
3162 && e->ts.u.derived->attr.alloc_comp
3163 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3164 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3167 tmp = build_fold_indirect_ref_loc (input_location,
3169 parm_rank = e->rank;
3177 case (SCALAR_POINTER):
3178 tmp = build_fold_indirect_ref_loc (input_location,
3183 if (e->expr_type == EXPR_OP
3184 && e->value.op.op == INTRINSIC_PARENTHESES
3185 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3188 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3189 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3190 gfc_add_expr_to_block (&se->post, local_tmp);
3193 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3195 gfc_add_expr_to_block (&se->post, tmp);
3198 /* Add argument checking of passing an unallocated/NULL actual to
3199 a nonallocatable/nonpointer dummy. */
3201 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3203 symbol_attribute attr;
3207 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3208 attr = gfc_expr_attr (e);
3210 goto end_pointer_check;
3214 /* If the actual argument is an optional pointer/allocatable and
3215 the formal argument takes an nonpointer optional value,
3216 it is invalid to pass a non-present argument on, even
3217 though there is no technical reason for this in gfortran.
3218 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3219 tree present, null_ptr, type;
3221 if (attr.allocatable
3222 && (fsym == NULL || !fsym->attr.allocatable))
3223 asprintf (&msg, "Allocatable actual argument '%s' is not "
3224 "allocated or not present", e->symtree->n.sym->name);
3225 else if (attr.pointer
3226 && (fsym == NULL || !fsym->attr.pointer))
3227 asprintf (&msg, "Pointer actual argument '%s' is not "
3228 "associated or not present",
3229 e->symtree->n.sym->name);
3230 else if (attr.proc_pointer
3231 && (fsym == NULL || !fsym->attr.proc_pointer))
3232 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3233 "associated or not present",
3234 e->symtree->n.sym->name);
3236 goto end_pointer_check;
3238 present = gfc_conv_expr_present (e->symtree->n.sym);
3239 type = TREE_TYPE (present);
3240 present = fold_build2_loc (input_location, EQ_EXPR,
3241 boolean_type_node, present,
3243 null_pointer_node));
3244 type = TREE_TYPE (parmse.expr);
3245 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3246 boolean_type_node, parmse.expr,
3248 null_pointer_node));
3249 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3250 boolean_type_node, present, null_ptr);
3254 if (attr.allocatable
3255 && (fsym == NULL || !fsym->attr.allocatable))
3256 asprintf (&msg, "Allocatable actual argument '%s' is not "
3257 "allocated", e->symtree->n.sym->name);
3258 else if (attr.pointer
3259 && (fsym == NULL || !fsym->attr.pointer))
3260 asprintf (&msg, "Pointer actual argument '%s' is not "
3261 "associated", e->symtree->n.sym->name);
3262 else if (attr.proc_pointer
3263 && (fsym == NULL || !fsym->attr.proc_pointer))
3264 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3265 "associated", e->symtree->n.sym->name);
3267 goto end_pointer_check;
3270 cond = fold_build2_loc (input_location, EQ_EXPR,
3271 boolean_type_node, parmse.expr,
3272 fold_convert (TREE_TYPE (parmse.expr),
3273 null_pointer_node));
3276 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3283 /* Character strings are passed as two parameters, a length and a
3284 pointer - except for Bind(c) which only passes the pointer. */
3285 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3286 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3288 VEC_safe_push (tree, gc, arglist, parmse.expr);
3290 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3297 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3298 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3299 else if (ts.type == BT_CHARACTER)
3301 if (ts.u.cl->length == NULL)
3303 /* Assumed character length results are not allowed by 5.1.1.5 of the
3304 standard and are trapped in resolve.c; except in the case of SPREAD
3305 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3306 we take the character length of the first argument for the result.
3307 For dummies, we have to look through the formal argument list for
3308 this function and use the character length found there.*/
3309 if (!sym->attr.dummy)
3310 cl.backend_decl = VEC_index (tree, stringargs, 0);
3313 formal = sym->ns->proc_name->formal;
3314 for (; formal; formal = formal->next)
3315 if (strcmp (formal->sym->name, sym->name) == 0)
3316 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3323 /* Calculate the length of the returned string. */
3324 gfc_init_se (&parmse, NULL);
3325 if (need_interface_mapping)
3326 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3328 gfc_conv_expr (&parmse, ts.u.cl->length);
3329 gfc_add_block_to_block (&se->pre, &parmse.pre);
3330 gfc_add_block_to_block (&se->post, &parmse.post);
3332 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3333 tmp = fold_build2_loc (input_location, MAX_EXPR,
3334 gfc_charlen_type_node, tmp,
3335 build_int_cst (gfc_charlen_type_node, 0));
3336 cl.backend_decl = tmp;
3339 /* Set up a charlen structure for it. */
3344 len = cl.backend_decl;
3347 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3348 || (!comp && gfc_return_by_reference (sym));
3351 if (se->direct_byref)
3353 /* Sometimes, too much indirection can be applied; e.g. for
3354 function_result = array_valued_recursive_function. */
3355 if (TREE_TYPE (TREE_TYPE (se->expr))
3356 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3357 && GFC_DESCRIPTOR_TYPE_P
3358 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3359 se->expr = build_fold_indirect_ref_loc (input_location,
3362 /* If the lhs of an assignment x = f(..) is allocatable and
3363 f2003 is allowed, we must do the automatic reallocation.
3364 TODO - deal with instrinsics, without using a temporary. */
3365 if (gfc_option.flag_realloc_lhs
3366 && se->ss && se->ss->loop_chain
3367 && se->ss->loop_chain->is_alloc_lhs
3368 && !expr->value.function.isym
3369 && sym->result->as != NULL)
3371 /* Evaluate the bounds of the result, if known. */
3372 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3375 /* Perform the automatic reallocation. */
3376 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3378 gfc_add_expr_to_block (&se->pre, tmp);
3380 /* Pass the temporary as the first argument. */
3381 result = info->descriptor;
3384 result = build_fold_indirect_ref_loc (input_location,
3386 VEC_safe_push (tree, gc, retargs, se->expr);
3388 else if (comp && comp->attr.dimension)
3390 gcc_assert (se->loop && info);
3392 /* Set the type of the array. */
3393 tmp = gfc_typenode_for_spec (&comp->ts);
3394 info->dimen = se->loop->dimen;
3396 /* Evaluate the bounds of the result, if known. */
3397 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3399 /* If the lhs of an assignment x = f(..) is allocatable and
3400 f2003 is allowed, we must not generate the function call
3401 here but should just send back the results of the mapping.
3402 This is signalled by the function ss being flagged. */
3403 if (gfc_option.flag_realloc_lhs
3404 && se->ss && se->ss->is_alloc_lhs)
3406 gfc_free_interface_mapping (&mapping);
3407 return has_alternate_specifier;
3410 /* Create a temporary to store the result. In case the function
3411 returns a pointer, the temporary will be a shallow copy and
3412 mustn't be deallocated. */
3413 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3414 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3415 NULL_TREE, false, !comp->attr.pointer,
3416 callee_alloc, &se->ss->expr->where);
3418 /* Pass the temporary as the first argument. */
3419 result = info->descriptor;
3420 tmp = gfc_build_addr_expr (NULL_TREE, result);
3421 VEC_safe_push (tree, gc, retargs, tmp);
3423 else if (!comp && sym->result->attr.dimension)
3425 gcc_assert (se->loop && info);
3427 /* Set the type of the array. */
3428 tmp = gfc_typenode_for_spec (&ts);
3429 info->dimen = se->loop->dimen;
3431 /* Evaluate the bounds of the result, if known. */
3432 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3434 /* If the lhs of an assignment x = f(..) is allocatable and
3435 f2003 is allowed, we must not generate the function call
3436 here but should just send back the results of the mapping.
3437 This is signalled by the function ss being flagged. */
3438 if (gfc_option.flag_realloc_lhs
3439 && se->ss && se->ss->is_alloc_lhs)
3441 gfc_free_interface_mapping (&mapping);
3442 return has_alternate_specifier;
3445 /* Create a temporary to store the result. In case the function
3446 returns a pointer, the temporary will be a shallow copy and
3447 mustn't be deallocated. */
3448 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3449 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3450 NULL_TREE, false, !sym->attr.pointer,
3451 callee_alloc, &se->ss->expr->where);
3453 /* Pass the temporary as the first argument. */
3454 result = info->descriptor;
3455 tmp = gfc_build_addr_expr (NULL_TREE, result);
3456 VEC_safe_push (tree, gc, retargs, tmp);
3458 else if (ts.type == BT_CHARACTER)
3460 /* Pass the string length. */
3461 type = gfc_get_character_type (ts.kind, ts.u.cl);
3462 type = build_pointer_type (type);
3464 /* Return an address to a char[0:len-1]* temporary for
3465 character pointers. */
3466 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3467 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3469 var = gfc_create_var (type, "pstr");
3471 if ((!comp && sym->attr.allocatable)
3472 || (comp && comp->attr.allocatable))
3473 gfc_add_modify (&se->pre, var,
3474 fold_convert (TREE_TYPE (var),
3475 null_pointer_node));
3477 /* Provide an address expression for the function arguments. */
3478 var = gfc_build_addr_expr (NULL_TREE, var);
3481 var = gfc_conv_string_tmp (se, type, len);
3483 VEC_safe_push (tree, gc, retargs, var);
3487 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3489 type = gfc_get_complex_type (ts.kind);
3490 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3491 VEC_safe_push (tree, gc, retargs, var);
3494 /* Add the string length to the argument list. */
3495 if (ts.type == BT_CHARACTER)
3496 VEC_safe_push (tree, gc, retargs, len);
3498 gfc_free_interface_mapping (&mapping);
3500 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3501 arglen = (VEC_length (tree, arglist)
3502 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3503 VEC_reserve_exact (tree, gc, retargs, arglen);
3505 /* Add the return arguments. */
3506 VEC_splice (tree, retargs, arglist);
3508 /* Add the hidden string length parameters to the arguments. */
3509 VEC_splice (tree, retargs, stringargs);
3511 /* We may want to append extra arguments here. This is used e.g. for
3512 calls to libgfortran_matmul_??, which need extra information. */
3513 if (!VEC_empty (tree, append_args))
3514 VEC_splice (tree, retargs, append_args);
3517 /* Generate the actual call. */
3518 conv_function_val (se, sym, expr);
3520 /* If there are alternate return labels, function type should be
3521 integer. Can't modify the type in place though, since it can be shared
3522 with other functions. For dummy arguments, the typing is done to
3523 to this result, even if it has to be repeated for each call. */
3524 if (has_alternate_specifier
3525 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3527 if (!sym->attr.dummy)
3529 TREE_TYPE (sym->backend_decl)
3530 = build_function_type (integer_type_node,
3531 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3532 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3535 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3538 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3539 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3541 /* If we have a pointer function, but we don't want a pointer, e.g.
3544 where f is pointer valued, we have to dereference the result. */
3545 if (!se->want_pointer && !byref
3546 && (sym->attr.pointer || sym->attr.allocatable)
3547 && !gfc_is_proc_ptr_comp (expr, NULL))
3548 se->expr = build_fold_indirect_ref_loc (input_location,
3551 /* f2c calling conventions require a scalar default real function to
3552 return a double precision result. Convert this back to default
3553 real. We only care about the cases that can happen in Fortran 77.
3555 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3556 && sym->ts.kind == gfc_default_real_kind
3557 && !sym->attr.always_explicit)
3558 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3560 /* A pure function may still have side-effects - it may modify its
3562 TREE_SIDE_EFFECTS (se->expr) = 1;
3564 if (!sym->attr.pure)
3565 TREE_SIDE_EFFECTS (se->expr) = 1;
3570 /* Add the function call to the pre chain. There is no expression. */
3571 gfc_add_expr_to_block (&se->pre, se->expr);
3572 se->expr = NULL_TREE;
3574 if (!se->direct_byref)
3576 if (sym->attr.dimension || (comp && comp->attr.dimension))
3578 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3580 /* Check the data pointer hasn't been modified. This would
3581 happen in a function returning a pointer. */
3582 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3583 tmp = fold_build2_loc (input_location, NE_EXPR,
3586 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3589 se->expr = info->descriptor;
3590 /* Bundle in the string length. */
3591 se->string_length = len;
3593 else if (ts.type == BT_CHARACTER)
3595 /* Dereference for character pointer results. */
3596 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3597 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3598 se->expr = build_fold_indirect_ref_loc (input_location, var);
3602 se->string_length = len;
3606 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3607 se->expr = build_fold_indirect_ref_loc (input_location, var);
3612 /* Follow the function call with the argument post block. */
3615 gfc_add_block_to_block (&se->pre, &post);
3617 /* Transformational functions of derived types with allocatable
3618 components must have the result allocatable components copied. */
3619 arg = expr->value.function.actual;
3620 if (result && arg && expr->rank
3621 && expr->value.function.isym
3622 && expr->value.function.isym->transformational
3623 && arg->expr->ts.type == BT_DERIVED
3624 && arg->expr->ts.u.derived->attr.alloc_comp)
3627 /* Copy the allocatable components. We have to use a
3628 temporary here to prevent source allocatable components
3629 from being corrupted. */
3630 tmp2 = gfc_evaluate_now (result, &se->pre);
3631 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3632 result, tmp2, expr->rank);
3633 gfc_add_expr_to_block (&se->pre, tmp);
3634 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3636 gfc_add_expr_to_block (&se->pre, tmp);
3638 /* Finally free the temporary's data field. */
3639 tmp = gfc_conv_descriptor_data_get (tmp2);
3640 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3641 gfc_add_expr_to_block (&se->pre, tmp);
3645 gfc_add_block_to_block (&se->post, &post);
3647 return has_alternate_specifier;
3651 /* Fill a character string with spaces. */
3654 fill_with_spaces (tree start, tree type, tree size)
3656 stmtblock_t block, loop;
3657 tree i, el, exit_label, cond, tmp;
3659 /* For a simple char type, we can call memset(). */
3660 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3661 return build_call_expr_loc (input_location,
3662 built_in_decls[BUILT_IN_MEMSET], 3, start,
3663 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3664 lang_hooks.to_target_charset (' ')),
3667 /* Otherwise, we use a loop:
3668 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3672 /* Initialize variables. */
3673 gfc_init_block (&block);
3674 i = gfc_create_var (sizetype, "i");
3675 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3676 el = gfc_create_var (build_pointer_type (type), "el");
3677 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3678 exit_label = gfc_build_label_decl (NULL_TREE);
3679 TREE_USED (exit_label) = 1;
3683 gfc_init_block (&loop);
3685 /* Exit condition. */
3686 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3687 build_zero_cst (sizetype));
3688 tmp = build1_v (GOTO_EXPR, exit_label);
3689 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3690 build_empty_stmt (input_location));
3691 gfc_add_expr_to_block (&loop, tmp);
3694 gfc_add_modify (&loop,
3695 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3696 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3698 /* Increment loop variables. */
3699 gfc_add_modify (&loop, i,
3700 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3701 TYPE_SIZE_UNIT (type)));
3702 gfc_add_modify (&loop, el,
3703 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3704 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3706 /* Making the loop... actually loop! */
3707 tmp = gfc_finish_block (&loop);
3708 tmp = build1_v (LOOP_EXPR, tmp);
3709 gfc_add_expr_to_block (&block, tmp);
3711 /* The exit label. */
3712 tmp = build1_v (LABEL_EXPR, exit_label);
3713 gfc_add_expr_to_block (&block, tmp);
3716 return gfc_finish_block (&block);
3720 /* Generate code to copy a string. */
3723 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3724 int dkind, tree slength, tree src, int skind)
3726 tree tmp, dlen, slen;
3735 stmtblock_t tempblock;
3737 gcc_assert (dkind == skind);
3739 if (slength != NULL_TREE)
3741 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3742 ssc = gfc_string_to_single_character (slen, src, skind);
3746 slen = build_int_cst (size_type_node, 1);
3750 if (dlength != NULL_TREE)
3752 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3753 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3757 dlen = build_int_cst (size_type_node, 1);
3761 /* Assign directly if the types are compatible. */
3762 if (dsc != NULL_TREE && ssc != NULL_TREE
3763 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3765 gfc_add_modify (block, dsc, ssc);
3769 /* Do nothing if the destination length is zero. */
3770 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3771 build_int_cst (size_type_node, 0));
3773 /* The following code was previously in _gfortran_copy_string:
3775 // The two strings may overlap so we use memmove.
3777 copy_string (GFC_INTEGER_4 destlen, char * dest,
3778 GFC_INTEGER_4 srclen, const char * src)
3780 if (srclen >= destlen)
3782 // This will truncate if too long.
3783 memmove (dest, src, destlen);
3787 memmove (dest, src, srclen);
3789 memset (&dest[srclen], ' ', destlen - srclen);
3793 We're now doing it here for better optimization, but the logic
3796 /* For non-default character kinds, we have to multiply the string
3797 length by the base type size. */
3798 chartype = gfc_get_char_type (dkind);
3799 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3800 fold_convert (size_type_node, slen),
3801 fold_convert (size_type_node,
3802 TYPE_SIZE_UNIT (chartype)));
3803 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3804 fold_convert (size_type_node, dlen),
3805 fold_convert (size_type_node,
3806 TYPE_SIZE_UNIT (chartype)));
3809 dest = fold_convert (pvoid_type_node, dest);
3811 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3814 src = fold_convert (pvoid_type_node, src);
3816 src = gfc_build_addr_expr (pvoid_type_node, src);
3818 /* Truncate string if source is too long. */
3819 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3821 tmp2 = build_call_expr_loc (input_location,
3822 built_in_decls[BUILT_IN_MEMMOVE],
3823 3, dest, src, dlen);
3825 /* Else copy and pad with spaces. */
3826 tmp3 = build_call_expr_loc (input_location,
3827 built_in_decls[BUILT_IN_MEMMOVE],
3828 3, dest, src, slen);
3830 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3831 dest, fold_convert (sizetype, slen));
3832 tmp4 = fill_with_spaces (tmp4, chartype,
3833 fold_build2_loc (input_location, MINUS_EXPR,
3834 TREE_TYPE(dlen), dlen, slen));
3836 gfc_init_block (&tempblock);
3837 gfc_add_expr_to_block (&tempblock, tmp3);
3838 gfc_add_expr_to_block (&tempblock, tmp4);
3839 tmp3 = gfc_finish_block (&tempblock);
3841 /* The whole copy_string function is there. */
3842 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3844 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3845 build_empty_stmt (input_location));
3846 gfc_add_expr_to_block (block, tmp);
3850 /* Translate a statement function.
3851 The value of a statement function reference is obtained by evaluating the
3852 expression using the values of the actual arguments for the values of the
3853 corresponding dummy arguments. */
3856 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3860 gfc_formal_arglist *fargs;
3861 gfc_actual_arglist *args;
3864 gfc_saved_var *saved_vars;
3870 sym = expr->symtree->n.sym;
3871 args = expr->value.function.actual;
3872 gfc_init_se (&lse, NULL);
3873 gfc_init_se (&rse, NULL);
3876 for (fargs = sym->formal; fargs; fargs = fargs->next)
3878 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3879 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3881 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3883 /* Each dummy shall be specified, explicitly or implicitly, to be
3885 gcc_assert (fargs->sym->attr.dimension == 0);
3888 /* Create a temporary to hold the value. */
3889 type = gfc_typenode_for_spec (&fsym->ts);
3890 temp_vars[n] = gfc_create_var (type, fsym->name);
3892 if (fsym->ts.type == BT_CHARACTER)
3894 /* Copy string arguments. */
3897 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3898 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3900 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3901 tmp = gfc_build_addr_expr (build_pointer_type (type),
3904 gfc_conv_expr (&rse, args->expr);
3905 gfc_conv_string_parameter (&rse);
3906 gfc_add_block_to_block (&se->pre, &lse.pre);
3907 gfc_add_block_to_block (&se->pre, &rse.pre);
3909 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3910 rse.string_length, rse.expr, fsym->ts.kind);
3911 gfc_add_block_to_block (&se->pre, &lse.post);
3912 gfc_add_block_to_block (&se->pre, &rse.post);
3916 /* For everything else, just evaluate the expression. */
3917 gfc_conv_expr (&lse, args->expr);
3919 gfc_add_block_to_block (&se->pre, &lse.pre);
3920 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3921 gfc_add_block_to_block (&se->pre, &lse.post);
3927 /* Use the temporary variables in place of the real ones. */
3928 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3929 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3931 gfc_conv_expr (se, sym->value);
3933 if (sym->ts.type == BT_CHARACTER)
3935 gfc_conv_const_charlen (sym->ts.u.cl);
3937 /* Force the expression to the correct length. */
3938 if (!INTEGER_CST_P (se->string_length)
3939 || tree_int_cst_lt (se->string_length,
3940 sym->ts.u.cl->backend_decl))
3942 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3943 tmp = gfc_create_var (type, sym->name);
3944 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3945 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3946 sym->ts.kind, se->string_length, se->expr,
3950 se->string_length = sym->ts.u.cl->backend_decl;
3953 /* Restore the original variables. */
3954 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3955 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3956 gfc_free (saved_vars);
3960 /* Translate a function expression. */
3963 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3967 if (expr->value.function.isym)
3969 gfc_conv_intrinsic_function (se, expr);
3973 /* We distinguish statement functions from general functions to improve
3974 runtime performance. */
3975 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3977 gfc_conv_statement_function (se, expr);
3981 /* expr.value.function.esym is the resolved (specific) function symbol for
3982 most functions. However this isn't set for dummy procedures. */
3983 sym = expr->value.function.esym;
3985 sym = expr->symtree->n.sym;
3987 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3991 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3994 is_zero_initializer_p (gfc_expr * expr)
3996 if (expr->expr_type != EXPR_CONSTANT)
3999 /* We ignore constants with prescribed memory representations for now. */
4000 if (expr->representation.string)
4003 switch (expr->ts.type)
4006 return mpz_cmp_si (expr->value.integer, 0) == 0;
4009 return mpfr_zero_p (expr->value.real)
4010 && MPFR_SIGN (expr->value.real) >= 0;
4013 return expr->value.logical == 0;
4016 return mpfr_zero_p (mpc_realref (expr->value.complex))
4017 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4018 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4019 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4029 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4031 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4032 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4034 gfc_conv_tmp_array_ref (se);
4038 /* Build a static initializer. EXPR is the expression for the initial value.
4039 The other parameters describe the variable of the component being
4040 initialized. EXPR may be null. */
4043 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4044 bool array, bool pointer, bool procptr)
4048 if (!(expr || pointer || procptr))
4051 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4052 (these are the only two iso_c_binding derived types that can be
4053 used as initialization expressions). If so, we need to modify
4054 the 'expr' to be that for a (void *). */
4055 if (expr != NULL && expr->ts.type == BT_DERIVED
4056 && expr->ts.is_iso_c && expr->ts.u.derived)
4058 gfc_symbol *derived = expr->ts.u.derived;
4060 /* The derived symbol has already been converted to a (void *). Use
4062 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4063 expr->ts.f90_type = derived->ts.f90_type;
4065 gfc_init_se (&se, NULL);
4066 gfc_conv_constant (&se, expr);
4067 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4071 if (array && !procptr)
4074 /* Arrays need special handling. */
4076 ctor = gfc_build_null_descriptor (type);
4077 /* Special case assigning an array to zero. */
4078 else if (is_zero_initializer_p (expr))
4079 ctor = build_constructor (type, NULL);
4081 ctor = gfc_conv_array_initializer (type, expr);
4082 TREE_STATIC (ctor) = 1;
4085 else if (pointer || procptr)
4087 if (!expr || expr->expr_type == EXPR_NULL)
4088 return fold_convert (type, null_pointer_node);
4091 gfc_init_se (&se, NULL);
4092 se.want_pointer = 1;
4093 gfc_conv_expr (&se, expr);
4094 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4104 gfc_init_se (&se, NULL);
4105 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4106 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4108 gfc_conv_structure (&se, expr, 1);
4109 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4110 TREE_STATIC (se.expr) = 1;
4115 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4116 TREE_STATIC (ctor) = 1;
4121 gfc_init_se (&se, NULL);
4122 gfc_conv_constant (&se, expr);
4123 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4130 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4142 gfc_start_block (&block);
4144 /* Initialize the scalarizer. */
4145 gfc_init_loopinfo (&loop);
4147 gfc_init_se (&lse, NULL);
4148 gfc_init_se (&rse, NULL);
4151 rss = gfc_walk_expr (expr);
4152 if (rss == gfc_ss_terminator)
4154 /* The rhs is scalar. Add a ss for the expression. */
4155 rss = gfc_get_ss ();
4156 rss->next = gfc_ss_terminator;
4157 rss->type = GFC_SS_SCALAR;
4161 /* Create a SS for the destination. */
4162 lss = gfc_get_ss ();
4163 lss->type = GFC_SS_COMPONENT;
4165 lss->shape = gfc_get_shape (cm->as->rank);
4166 lss->next = gfc_ss_terminator;
4167 lss->data.info.dimen = cm->as->rank;
4168 lss->data.info.descriptor = dest;
4169 lss->data.info.data = gfc_conv_array_data (dest);
4170 lss->data.info.offset = gfc_conv_array_offset (dest);
4171 for (n = 0; n < cm->as->rank; n++)
4173 lss->data.info.dim[n] = n;
4174 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4175 lss->data.info.stride[n] = gfc_index_one_node;
4177 mpz_init (lss->shape[n]);
4178 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4179 cm->as->lower[n]->value.integer);
4180 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4183 /* Associate the SS with the loop. */
4184 gfc_add_ss_to_loop (&loop, lss);
4185 gfc_add_ss_to_loop (&loop, rss);
4187 /* Calculate the bounds of the scalarization. */
4188 gfc_conv_ss_startstride (&loop);
4190 /* Setup the scalarizing loops. */
4191 gfc_conv_loop_setup (&loop, &expr->where);
4193 /* Setup the gfc_se structures. */
4194 gfc_copy_loopinfo_to_se (&lse, &loop);
4195 gfc_copy_loopinfo_to_se (&rse, &loop);
4198 gfc_mark_ss_chain_used (rss, 1);
4200 gfc_mark_ss_chain_used (lss, 1);
4202 /* Start the scalarized loop body. */
4203 gfc_start_scalarized_body (&loop, &body);
4205 gfc_conv_tmp_array_ref (&lse);
4206 if (cm->ts.type == BT_CHARACTER)
4207 lse.string_length = cm->ts.u.cl->backend_decl;
4209 gfc_conv_expr (&rse, expr);
4211 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4212 gfc_add_expr_to_block (&body, tmp);
4214 gcc_assert (rse.ss == gfc_ss_terminator);
4216 /* Generate the copying loops. */
4217 gfc_trans_scalarizing_loops (&loop, &body);
4219 /* Wrap the whole thing up. */
4220 gfc_add_block_to_block (&block, &loop.pre);
4221 gfc_add_block_to_block (&block, &loop.post);
4223 for (n = 0; n < cm->as->rank; n++)
4224 mpz_clear (lss->shape[n]);
4225 gfc_free (lss->shape);
4227 gfc_cleanup_loop (&loop);
4229 return gfc_finish_block (&block);
4234 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4245 gfc_expr *arg = NULL;
4247 gfc_start_block (&block);
4248 gfc_init_se (&se, NULL);
4250 /* Get the descriptor for the expressions. */
4251 rss = gfc_walk_expr (expr);
4252 se.want_pointer = 0;
4253 gfc_conv_expr_descriptor (&se, expr, rss);
4254 gfc_add_block_to_block (&block, &se.pre);
4255 gfc_add_modify (&block, dest, se.expr);
4257 /* Deal with arrays of derived types with allocatable components. */
4258 if (cm->ts.type == BT_DERIVED
4259 && cm->ts.u.derived->attr.alloc_comp)
4260 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4264 tmp = gfc_duplicate_allocatable (dest, se.expr,
4265 TREE_TYPE(cm->backend_decl),
4268 gfc_add_expr_to_block (&block, tmp);
4269 gfc_add_block_to_block (&block, &se.post);
4271 if (expr->expr_type != EXPR_VARIABLE)
4272 gfc_conv_descriptor_data_set (&block, se.expr,
4275 /* We need to know if the argument of a conversion function is a
4276 variable, so that the correct lower bound can be used. */
4277 if (expr->expr_type == EXPR_FUNCTION
4278 && expr->value.function.isym
4279 && expr->value.function.isym->conversion
4280 && expr->value.function.actual->expr
4281 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4282 arg = expr->value.function.actual->expr;
4284 /* Obtain the array spec of full array references. */
4286 as = gfc_get_full_arrayspec_from_expr (arg);
4288 as = gfc_get_full_arrayspec_from_expr (expr);
4290 /* Shift the lbound and ubound of temporaries to being unity,
4291 rather than zero, based. Always calculate the offset. */
4292 offset = gfc_conv_descriptor_offset_get (dest);
4293 gfc_add_modify (&block, offset, gfc_index_zero_node);
4294 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4296 for (n = 0; n < expr->rank; n++)
4301 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4302 TODO It looks as if gfc_conv_expr_descriptor should return
4303 the correct bounds and that the following should not be
4304 necessary. This would simplify gfc_conv_intrinsic_bound
4306 if (as && as->lower[n])
4309 gfc_init_se (&lbse, NULL);
4310 gfc_conv_expr (&lbse, as->lower[n]);
4311 gfc_add_block_to_block (&block, &lbse.pre);
4312 lbound = gfc_evaluate_now (lbse.expr, &block);
4316 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4317 lbound = gfc_conv_descriptor_lbound_get (tmp,
4321 lbound = gfc_conv_descriptor_lbound_get (dest,
4324 lbound = gfc_index_one_node;
4326 lbound = fold_convert (gfc_array_index_type, lbound);
4328 /* Shift the bounds and set the offset accordingly. */
4329 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4330 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4331 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4332 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4334 gfc_conv_descriptor_ubound_set (&block, dest,
4335 gfc_rank_cst[n], tmp);
4336 gfc_conv_descriptor_lbound_set (&block, dest,
4337 gfc_rank_cst[n], lbound);
4339 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4340 gfc_conv_descriptor_lbound_get (dest,
4342 gfc_conv_descriptor_stride_get (dest,
4344 gfc_add_modify (&block, tmp2, tmp);
4345 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4347 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4352 /* If a conversion expression has a null data pointer
4353 argument, nullify the allocatable component. */
4357 if (arg->symtree->n.sym->attr.allocatable
4358 || arg->symtree->n.sym->attr.pointer)
4360 non_null_expr = gfc_finish_block (&block);
4361 gfc_start_block (&block);
4362 gfc_conv_descriptor_data_set (&block, dest,
4364 null_expr = gfc_finish_block (&block);
4365 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4366 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4367 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4368 return build3_v (COND_EXPR, tmp,
4369 null_expr, non_null_expr);
4373 return gfc_finish_block (&block);
4377 /* Assign a single component of a derived type constructor. */
4380 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4388 gfc_start_block (&block);
4390 if (cm->attr.pointer)
4392 gfc_init_se (&se, NULL);
4393 /* Pointer component. */
4394 if (cm->attr.dimension)
4396 /* Array pointer. */
4397 if (expr->expr_type == EXPR_NULL)
4398 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4401 rss = gfc_walk_expr (expr);
4402 se.direct_byref = 1;
4404 gfc_conv_expr_descriptor (&se, expr, rss);
4405 gfc_add_block_to_block (&block, &se.pre);
4406 gfc_add_block_to_block (&block, &se.post);
4411 /* Scalar pointers. */
4412 se.want_pointer = 1;
4413 gfc_conv_expr (&se, expr);
4414 gfc_add_block_to_block (&block, &se.pre);
4415 gfc_add_modify (&block, dest,
4416 fold_convert (TREE_TYPE (dest), se.expr));
4417 gfc_add_block_to_block (&block, &se.post);
4420 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4422 /* NULL initialization for CLASS components. */
4423 tmp = gfc_trans_structure_assign (dest,
4424 gfc_class_null_initializer (&cm->ts));
4425 gfc_add_expr_to_block (&block, tmp);
4427 else if (cm->attr.dimension)
4429 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4430 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4431 else if (cm->attr.allocatable)
4433 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4434 gfc_add_expr_to_block (&block, tmp);
4438 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4439 gfc_add_expr_to_block (&block, tmp);
4442 else if (expr->ts.type == BT_DERIVED)
4444 if (expr->expr_type != EXPR_STRUCTURE)
4446 gfc_init_se (&se, NULL);
4447 gfc_conv_expr (&se, expr);
4448 gfc_add_block_to_block (&block, &se.pre);
4449 gfc_add_modify (&block, dest,
4450 fold_convert (TREE_TYPE (dest), se.expr));
4451 gfc_add_block_to_block (&block, &se.post);
4455 /* Nested constructors. */
4456 tmp = gfc_trans_structure_assign (dest, expr);
4457 gfc_add_expr_to_block (&block, tmp);
4462 /* Scalar component. */
4463 gfc_init_se (&se, NULL);
4464 gfc_init_se (&lse, NULL);
4466 gfc_conv_expr (&se, expr);
4467 if (cm->ts.type == BT_CHARACTER)
4468 lse.string_length = cm->ts.u.cl->backend_decl;
4470 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4471 gfc_add_expr_to_block (&block, tmp);
4473 return gfc_finish_block (&block);
4476 /* Assign a derived type constructor to a variable. */
4479 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4487 gfc_start_block (&block);
4488 cm = expr->ts.u.derived->components;
4489 for (c = gfc_constructor_first (expr->value.constructor);
4490 c; c = gfc_constructor_next (c), cm = cm->next)
4492 /* Skip absent members in default initializers. */
4496 /* Handle c_null_(fun)ptr. */
4497 if (c && c->expr && c->expr->ts.is_iso_c)
4499 field = cm->backend_decl;
4500 tmp = fold_build3_loc (input_location, COMPONENT_REF,
4502 dest, field, NULL_TREE);
4503 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
4504 tmp, fold_convert (TREE_TYPE (tmp),
4505 null_pointer_node));
4506 gfc_add_expr_to_block (&block, tmp);
4510 field = cm->backend_decl;
4511 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4512 dest, field, NULL_TREE);
4513 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4514 gfc_add_expr_to_block (&block, tmp);
4516 return gfc_finish_block (&block);
4519 /* Build an expression for a constructor. If init is nonzero then
4520 this is part of a static variable initializer. */
4523 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4530 VEC(constructor_elt,gc) *v = NULL;
4532 gcc_assert (se->ss == NULL);
4533 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4534 type = gfc_typenode_for_spec (&expr->ts);
4538 /* Create a temporary variable and fill it in. */
4539 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4540 tmp = gfc_trans_structure_assign (se->expr, expr);
4541 gfc_add_expr_to_block (&se->pre, tmp);
4545 cm = expr->ts.u.derived->components;
4547 for (c = gfc_constructor_first (expr->value.constructor);
4548 c; c = gfc_constructor_next (c), cm = cm->next)
4550 /* Skip absent members in default initializers and allocatable
4551 components. Although the latter have a default initializer
4552 of EXPR_NULL,... by default, the static nullify is not needed
4553 since this is done every time we come into scope. */
4554 if (!c->expr || cm->attr.allocatable)
4557 if (strcmp (cm->name, "_size") == 0)
4559 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4560 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4562 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4563 && strcmp (cm->name, "_extends") == 0)
4567 vtabs = cm->initializer->symtree->n.sym;
4568 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4569 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4573 val = gfc_conv_initializer (c->expr, &cm->ts,
4574 TREE_TYPE (cm->backend_decl),
4575 cm->attr.dimension, cm->attr.pointer,
4576 cm->attr.proc_pointer);
4578 /* Append it to the constructor list. */
4579 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4582 se->expr = build_constructor (type, v);
4584 TREE_CONSTANT (se->expr) = 1;
4588 /* Translate a substring expression. */
4591 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4597 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4599 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4600 expr->value.character.length,
4601 expr->value.character.string);
4603 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4604 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4607 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4611 /* Entry point for expression translation. Evaluates a scalar quantity.
4612 EXPR is the expression to be translated, and SE is the state structure if
4613 called from within the scalarized. */
4616 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4618 if (se->ss && se->ss->expr == expr
4619 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4621 /* Substitute a scalar expression evaluated outside the scalarization
4623 se->expr = se->ss->data.scalar.expr;
4624 if (se->ss->type == GFC_SS_REFERENCE)
4625 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4626 se->string_length = se->ss->string_length;
4627 gfc_advance_se_ss_chain (se);
4631 /* We need to convert the expressions for the iso_c_binding derived types.
4632 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4633 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4634 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4635 updated to be an integer with a kind equal to the size of a (void *). */
4636 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4637 && expr->ts.u.derived->attr.is_iso_c)
4639 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4640 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4642 /* Set expr_type to EXPR_NULL, which will result in
4643 null_pointer_node being used below. */
4644 expr->expr_type = EXPR_NULL;
4648 /* Update the type/kind of the expression to be what the new
4649 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4650 expr->ts.type = expr->ts.u.derived->ts.type;
4651 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4652 expr->ts.kind = expr->ts.u.derived->ts.kind;
4656 switch (expr->expr_type)
4659 gfc_conv_expr_op (se, expr);
4663 gfc_conv_function_expr (se, expr);
4667 gfc_conv_constant (se, expr);
4671 gfc_conv_variable (se, expr);
4675 se->expr = null_pointer_node;
4678 case EXPR_SUBSTRING:
4679 gfc_conv_substring_expr (se, expr);
4682 case EXPR_STRUCTURE:
4683 gfc_conv_structure (se, expr, 0);
4687 gfc_conv_array_constructor_expr (se, expr);
4696 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4697 of an assignment. */
4699 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4701 gfc_conv_expr (se, expr);
4702 /* All numeric lvalues should have empty post chains. If not we need to
4703 figure out a way of rewriting an lvalue so that it has no post chain. */
4704 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4707 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4708 numeric expressions. Used for scalar values where inserting cleanup code
4711 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4715 gcc_assert (expr->ts.type != BT_CHARACTER);
4716 gfc_conv_expr (se, expr);
4719 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4720 gfc_add_modify (&se->pre, val, se->expr);
4722 gfc_add_block_to_block (&se->pre, &se->post);
4726 /* Helper to translate an expression and convert it to a particular type. */
4728 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4730 gfc_conv_expr_val (se, expr);
4731 se->expr = convert (type, se->expr);
4735 /* Converts an expression so that it can be passed by reference. Scalar
4739 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4743 if (se->ss && se->ss->expr == expr
4744 && se->ss->type == GFC_SS_REFERENCE)
4746 /* Returns a reference to the scalar evaluated outside the loop
4748 gfc_conv_expr (se, expr);
4752 if (expr->ts.type == BT_CHARACTER)
4754 gfc_conv_expr (se, expr);
4755 gfc_conv_string_parameter (se);
4759 if (expr->expr_type == EXPR_VARIABLE)
4761 se->want_pointer = 1;
4762 gfc_conv_expr (se, expr);
4765 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4766 gfc_add_modify (&se->pre, var, se->expr);
4767 gfc_add_block_to_block (&se->pre, &se->post);
4773 if (expr->expr_type == EXPR_FUNCTION
4774 && ((expr->value.function.esym
4775 && expr->value.function.esym->result->attr.pointer
4776 && !expr->value.function.esym->result->attr.dimension)
4777 || (!expr->value.function.esym
4778 && expr->symtree->n.sym->attr.pointer
4779 && !expr->symtree->n.sym->attr.dimension)))
4781 se->want_pointer = 1;
4782 gfc_conv_expr (se, expr);
4783 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4784 gfc_add_modify (&se->pre, var, se->expr);
4790 gfc_conv_expr (se, expr);
4792 /* Create a temporary var to hold the value. */
4793 if (TREE_CONSTANT (se->expr))
4795 tree tmp = se->expr;
4796 STRIP_TYPE_NOPS (tmp);
4797 var = build_decl (input_location,
4798 CONST_DECL, NULL, TREE_TYPE (tmp));
4799 DECL_INITIAL (var) = tmp;
4800 TREE_STATIC (var) = 1;
4805 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4806 gfc_add_modify (&se->pre, var, se->expr);
4808 gfc_add_block_to_block (&se->pre, &se->post);
4810 /* Take the address of that value. */
4811 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4816 gfc_trans_pointer_assign (gfc_code * code)
4818 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4822 /* Generate code for a pointer assignment. */
4825 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4836 gfc_start_block (&block);
4838 gfc_init_se (&lse, NULL);
4840 lss = gfc_walk_expr (expr1);
4841 rss = gfc_walk_expr (expr2);
4842 if (lss == gfc_ss_terminator)
4844 /* Scalar pointers. */
4845 lse.want_pointer = 1;
4846 gfc_conv_expr (&lse, expr1);
4847 gcc_assert (rss == gfc_ss_terminator);
4848 gfc_init_se (&rse, NULL);
4849 rse.want_pointer = 1;
4850 gfc_conv_expr (&rse, expr2);
4852 if (expr1->symtree->n.sym->attr.proc_pointer
4853 && expr1->symtree->n.sym->attr.dummy)
4854 lse.expr = build_fold_indirect_ref_loc (input_location,
4857 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4858 && expr2->symtree->n.sym->attr.dummy)
4859 rse.expr = build_fold_indirect_ref_loc (input_location,
4862 gfc_add_block_to_block (&block, &lse.pre);
4863 gfc_add_block_to_block (&block, &rse.pre);
4865 /* Check character lengths if character expression. The test is only
4866 really added if -fbounds-check is enabled. */
4867 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4868 && !expr1->symtree->n.sym->attr.proc_pointer
4869 && !gfc_is_proc_ptr_comp (expr1, NULL))
4871 gcc_assert (expr2->ts.type == BT_CHARACTER);
4872 gcc_assert (lse.string_length && rse.string_length);
4873 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4874 lse.string_length, rse.string_length,
4878 gfc_add_modify (&block, lse.expr,
4879 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4881 gfc_add_block_to_block (&block, &rse.post);
4882 gfc_add_block_to_block (&block, &lse.post);
4889 tree strlen_rhs = NULL_TREE;
4891 /* Array pointer. Find the last reference on the LHS and if it is an
4892 array section ref, we're dealing with bounds remapping. In this case,
4893 set it to AR_FULL so that gfc_conv_expr_descriptor does
4894 not see it and process the bounds remapping afterwards explicitely. */
4895 for (remap = expr1->ref; remap; remap = remap->next)
4896 if (!remap->next && remap->type == REF_ARRAY
4897 && remap->u.ar.type == AR_SECTION)
4899 remap->u.ar.type = AR_FULL;
4902 rank_remap = (remap && remap->u.ar.end[0]);
4904 gfc_conv_expr_descriptor (&lse, expr1, lss);
4905 strlen_lhs = lse.string_length;
4908 if (expr2->expr_type == EXPR_NULL)
4910 /* Just set the data pointer to null. */
4911 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4913 else if (rank_remap)
4915 /* If we are rank-remapping, just get the RHS's descriptor and
4916 process this later on. */
4917 gfc_init_se (&rse, NULL);
4918 rse.direct_byref = 1;
4919 rse.byref_noassign = 1;
4920 gfc_conv_expr_descriptor (&rse, expr2, rss);
4921 strlen_rhs = rse.string_length;
4923 else if (expr2->expr_type == EXPR_VARIABLE)
4925 /* Assign directly to the LHS's descriptor. */
4926 lse.direct_byref = 1;
4927 gfc_conv_expr_descriptor (&lse, expr2, rss);
4928 strlen_rhs = lse.string_length;
4930 /* If this is a subreference array pointer assignment, use the rhs
4931 descriptor element size for the lhs span. */
4932 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4934 decl = expr1->symtree->n.sym->backend_decl;
4935 gfc_init_se (&rse, NULL);
4936 rse.descriptor_only = 1;
4937 gfc_conv_expr (&rse, expr2);
4938 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4939 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4940 if (!INTEGER_CST_P (tmp))
4941 gfc_add_block_to_block (&lse.post, &rse.pre);
4942 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4947 /* Assign to a temporary descriptor and then copy that
4948 temporary to the pointer. */
4949 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4952 lse.direct_byref = 1;
4953 gfc_conv_expr_descriptor (&lse, expr2, rss);
4954 strlen_rhs = lse.string_length;
4955 gfc_add_modify (&lse.pre, desc, tmp);
4958 gfc_add_block_to_block (&block, &lse.pre);
4960 gfc_add_block_to_block (&block, &rse.pre);
4962 /* If we do bounds remapping, update LHS descriptor accordingly. */
4966 gcc_assert (remap->u.ar.dimen == expr1->rank);
4970 /* Do rank remapping. We already have the RHS's descriptor
4971 converted in rse and now have to build the correct LHS
4972 descriptor for it. */
4976 tree lbound, ubound;
4979 dtype = gfc_conv_descriptor_dtype (desc);
4980 tmp = gfc_get_dtype (TREE_TYPE (desc));
4981 gfc_add_modify (&block, dtype, tmp);
4983 /* Copy data pointer. */
4984 data = gfc_conv_descriptor_data_get (rse.expr);
4985 gfc_conv_descriptor_data_set (&block, desc, data);
4987 /* Copy offset but adjust it such that it would correspond
4988 to a lbound of zero. */
4989 offs = gfc_conv_descriptor_offset_get (rse.expr);
4990 for (dim = 0; dim < expr2->rank; ++dim)
4992 stride = gfc_conv_descriptor_stride_get (rse.expr,
4994 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
4996 tmp = fold_build2_loc (input_location, MULT_EXPR,
4997 gfc_array_index_type, stride, lbound);
4998 offs = fold_build2_loc (input_location, PLUS_EXPR,
4999 gfc_array_index_type, offs, tmp);
5001 gfc_conv_descriptor_offset_set (&block, desc, offs);
5003 /* Set the bounds as declared for the LHS and calculate strides as
5004 well as another offset update accordingly. */
5005 stride = gfc_conv_descriptor_stride_get (rse.expr,
5007 for (dim = 0; dim < expr1->rank; ++dim)
5012 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5014 /* Convert declared bounds. */
5015 gfc_init_se (&lower_se, NULL);
5016 gfc_init_se (&upper_se, NULL);
5017 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5018 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5020 gfc_add_block_to_block (&block, &lower_se.pre);
5021 gfc_add_block_to_block (&block, &upper_se.pre);
5023 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5024 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5026 lbound = gfc_evaluate_now (lbound, &block);
5027 ubound = gfc_evaluate_now (ubound, &block);
5029 gfc_add_block_to_block (&block, &lower_se.post);
5030 gfc_add_block_to_block (&block, &upper_se.post);
5032 /* Set bounds in descriptor. */
5033 gfc_conv_descriptor_lbound_set (&block, desc,
5034 gfc_rank_cst[dim], lbound);
5035 gfc_conv_descriptor_ubound_set (&block, desc,
5036 gfc_rank_cst[dim], ubound);
5039 stride = gfc_evaluate_now (stride, &block);
5040 gfc_conv_descriptor_stride_set (&block, desc,
5041 gfc_rank_cst[dim], stride);
5043 /* Update offset. */
5044 offs = gfc_conv_descriptor_offset_get (desc);
5045 tmp = fold_build2_loc (input_location, MULT_EXPR,
5046 gfc_array_index_type, lbound, stride);
5047 offs = fold_build2_loc (input_location, MINUS_EXPR,
5048 gfc_array_index_type, offs, tmp);
5049 offs = gfc_evaluate_now (offs, &block);
5050 gfc_conv_descriptor_offset_set (&block, desc, offs);
5052 /* Update stride. */
5053 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5054 stride = fold_build2_loc (input_location, MULT_EXPR,
5055 gfc_array_index_type, stride, tmp);
5060 /* Bounds remapping. Just shift the lower bounds. */
5062 gcc_assert (expr1->rank == expr2->rank);
5064 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5068 gcc_assert (remap->u.ar.start[dim]);
5069 gcc_assert (!remap->u.ar.end[dim]);
5070 gfc_init_se (&lbound_se, NULL);
5071 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5073 gfc_add_block_to_block (&block, &lbound_se.pre);
5074 gfc_conv_shift_descriptor_lbound (&block, desc,
5075 dim, lbound_se.expr);
5076 gfc_add_block_to_block (&block, &lbound_se.post);
5081 /* Check string lengths if applicable. The check is only really added
5082 to the output code if -fbounds-check is enabled. */
5083 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5085 gcc_assert (expr2->ts.type == BT_CHARACTER);
5086 gcc_assert (strlen_lhs && strlen_rhs);
5087 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5088 strlen_lhs, strlen_rhs, &block);
5091 /* If rank remapping was done, check with -fcheck=bounds that
5092 the target is at least as large as the pointer. */
5093 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5099 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5100 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5102 lsize = gfc_evaluate_now (lsize, &block);
5103 rsize = gfc_evaluate_now (rsize, &block);
5104 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5107 msg = _("Target of rank remapping is too small (%ld < %ld)");
5108 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5112 gfc_add_block_to_block (&block, &lse.post);
5114 gfc_add_block_to_block (&block, &rse.post);
5117 return gfc_finish_block (&block);
5121 /* Makes sure se is suitable for passing as a function string parameter. */
5122 /* TODO: Need to check all callers of this function. It may be abused. */
5125 gfc_conv_string_parameter (gfc_se * se)
5129 if (TREE_CODE (se->expr) == STRING_CST)
5131 type = TREE_TYPE (TREE_TYPE (se->expr));
5132 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5136 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5138 if (TREE_CODE (se->expr) != INDIRECT_REF)
5140 type = TREE_TYPE (se->expr);
5141 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5145 type = gfc_get_character_type_len (gfc_default_character_kind,
5147 type = build_pointer_type (type);
5148 se->expr = gfc_build_addr_expr (type, se->expr);
5152 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5153 gcc_assert (se->string_length
5154 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
5158 /* Generate code for assignment of scalar variables. Includes character
5159 strings and derived types with allocatable components.
5160 If you know that the LHS has no allocations, set dealloc to false. */
5163 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5164 bool l_is_temp, bool r_is_var, bool dealloc)
5170 gfc_init_block (&block);
5172 if (ts.type == BT_CHARACTER)
5177 if (lse->string_length != NULL_TREE)
5179 gfc_conv_string_parameter (lse);
5180 gfc_add_block_to_block (&block, &lse->pre);
5181 llen = lse->string_length;
5184 if (rse->string_length != NULL_TREE)
5186 gcc_assert (rse->string_length != NULL_TREE);
5187 gfc_conv_string_parameter (rse);
5188 gfc_add_block_to_block (&block, &rse->pre);
5189 rlen = rse->string_length;
5192 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5193 rse->expr, ts.kind);
5195 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5199 /* Are the rhs and the lhs the same? */
5202 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5203 gfc_build_addr_expr (NULL_TREE, lse->expr),
5204 gfc_build_addr_expr (NULL_TREE, rse->expr));
5205 cond = gfc_evaluate_now (cond, &lse->pre);
5208 /* Deallocate the lhs allocated components as long as it is not
5209 the same as the rhs. This must be done following the assignment
5210 to prevent deallocating data that could be used in the rhs
5212 if (!l_is_temp && dealloc)
5214 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5215 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5217 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5219 gfc_add_expr_to_block (&lse->post, tmp);
5222 gfc_add_block_to_block (&block, &rse->pre);
5223 gfc_add_block_to_block (&block, &lse->pre);
5225 gfc_add_modify (&block, lse->expr,
5226 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5228 /* Do a deep copy if the rhs is a variable, if it is not the
5232 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5233 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5235 gfc_add_expr_to_block (&block, tmp);
5238 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5240 gfc_add_block_to_block (&block, &lse->pre);
5241 gfc_add_block_to_block (&block, &rse->pre);
5242 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5243 TREE_TYPE (lse->expr), rse->expr);
5244 gfc_add_modify (&block, lse->expr, tmp);
5248 gfc_add_block_to_block (&block, &lse->pre);
5249 gfc_add_block_to_block (&block, &rse->pre);
5251 gfc_add_modify (&block, lse->expr,
5252 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5255 gfc_add_block_to_block (&block, &lse->post);
5256 gfc_add_block_to_block (&block, &rse->post);
5258 return gfc_finish_block (&block);
5262 /* There are quite a lot of restrictions on the optimisation in using an
5263 array function assign without a temporary. */
5266 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5269 bool seen_array_ref;
5271 gfc_symbol *sym = expr1->symtree->n.sym;
5273 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5274 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5277 /* Elemental functions are scalarized so that they don't need a
5278 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5279 they would need special treatment in gfc_trans_arrayfunc_assign. */
5280 if (expr2->value.function.esym != NULL
5281 && expr2->value.function.esym->attr.elemental)
5284 /* Need a temporary if rhs is not FULL or a contiguous section. */
5285 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5288 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5289 if (gfc_ref_needs_temporary_p (expr1->ref))
5292 /* Functions returning pointers need temporaries. */
5293 if (expr2->symtree->n.sym->attr.pointer
5294 || expr2->symtree->n.sym->attr.allocatable)
5297 /* Character array functions need temporaries unless the
5298 character lengths are the same. */
5299 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5301 if (expr1->ts.u.cl->length == NULL
5302 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5305 if (expr2->ts.u.cl->length == NULL
5306 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5309 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5310 expr2->ts.u.cl->length->value.integer) != 0)
5314 /* Check that no LHS component references appear during an array
5315 reference. This is needed because we do not have the means to
5316 span any arbitrary stride with an array descriptor. This check
5317 is not needed for the rhs because the function result has to be
5319 seen_array_ref = false;
5320 for (ref = expr1->ref; ref; ref = ref->next)
5322 if (ref->type == REF_ARRAY)
5323 seen_array_ref= true;
5324 else if (ref->type == REF_COMPONENT && seen_array_ref)
5328 /* Check for a dependency. */
5329 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5330 expr2->value.function.esym,
5331 expr2->value.function.actual,
5335 /* If we have reached here with an intrinsic function, we do not
5336 need a temporary. */
5337 if (expr2->value.function.isym)
5340 /* If the LHS is a dummy, we need a temporary if it is not
5342 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5345 /* A PURE function can unconditionally be called without a temporary. */
5346 if (expr2->value.function.esym != NULL
5347 && expr2->value.function.esym->attr.pure)
5350 /* TODO a function that could correctly be declared PURE but is not
5351 could do with returning false as well. */
5353 if (!sym->attr.use_assoc
5354 && !sym->attr.in_common
5355 && !sym->attr.pointer
5356 && !sym->attr.target
5357 && expr2->value.function.esym)
5359 /* A temporary is not needed if the function is not contained and
5360 the variable is local or host associated and not a pointer or
5362 if (!expr2->value.function.esym->attr.contained)
5365 /* A temporary is not needed if the lhs has never been host
5366 associated and the procedure is contained. */
5367 else if (!sym->attr.host_assoc)
5370 /* A temporary is not needed if the variable is local and not
5371 a pointer, a target or a result. */
5373 && expr2->value.function.esym->ns == sym->ns->parent)
5377 /* Default to temporary use. */
5382 /* Provide the loop info so that the lhs descriptor can be built for
5383 reallocatable assignments from extrinsic function calls. */
5386 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
5389 /* Signal that the function call should not be made by
5390 gfc_conv_loop_setup. */
5391 se->ss->is_alloc_lhs = 1;
5392 gfc_init_loopinfo (&loop);
5393 gfc_add_ss_to_loop (&loop, *ss);
5394 gfc_add_ss_to_loop (&loop, se->ss);
5395 gfc_conv_ss_startstride (&loop);
5396 gfc_conv_loop_setup (&loop, where);
5397 gfc_copy_loopinfo_to_se (se, &loop);
5398 gfc_add_block_to_block (&se->pre, &loop.pre);
5399 gfc_add_block_to_block (&se->pre, &loop.post);
5400 se->ss->is_alloc_lhs = 0;
5405 realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
5412 /* Use the allocation done by the library. */
5413 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5414 tmp = gfc_conv_descriptor_data_get (desc);
5415 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5416 gfc_add_expr_to_block (&se->pre, tmp);
5417 gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
5418 /* Unallocated, the descriptor does not have a dtype. */
5419 tmp = gfc_conv_descriptor_dtype (desc);
5420 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5422 offset = gfc_index_zero_node;
5423 tmp = gfc_index_one_node;
5424 /* Now reset the bounds from zero based to unity based. */
5425 for (n = 0 ; n < rank; n++)
5427 /* Accumulate the offset. */
5428 offset = fold_build2_loc (input_location, MINUS_EXPR,
5429 gfc_array_index_type,
5431 /* Now do the bounds. */
5432 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5433 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5434 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5435 gfc_array_index_type,
5436 tmp, gfc_index_one_node);
5437 gfc_conv_descriptor_lbound_set (&se->post, desc,
5439 gfc_index_one_node);
5440 gfc_conv_descriptor_ubound_set (&se->post, desc,
5441 gfc_rank_cst[n], tmp);
5443 /* The extent for the next contribution to offset. */
5444 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5445 gfc_array_index_type,
5446 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5447 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5448 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5449 gfc_array_index_type,
5450 tmp, gfc_index_one_node);
5452 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5457 /* Try to translate array(:) = func (...), where func is a transformational
5458 array function, without using a temporary. Returns NULL if this isn't the
5462 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5466 gfc_component *comp = NULL;
5468 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5471 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5473 gcc_assert (expr2->value.function.isym
5474 || (gfc_is_proc_ptr_comp (expr2, &comp)
5475 && comp && comp->attr.dimension)
5476 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5477 && expr2->value.function.esym->result->attr.dimension));
5479 ss = gfc_walk_expr (expr1);
5480 gcc_assert (ss != gfc_ss_terminator);
5481 gfc_init_se (&se, NULL);
5482 gfc_start_block (&se.pre);
5483 se.want_pointer = 1;
5485 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5487 if (expr1->ts.type == BT_DERIVED
5488 && expr1->ts.u.derived->attr.alloc_comp)
5491 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5493 gfc_add_expr_to_block (&se.pre, tmp);
5496 se.direct_byref = 1;
5497 se.ss = gfc_walk_expr (expr2);
5498 gcc_assert (se.ss != gfc_ss_terminator);
5500 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5501 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5502 Clearly, this cannot be done for an allocatable function result, since
5503 the shape of the result is unknown and, in any case, the function must
5504 correctly take care of the reallocation internally. For intrinsic
5505 calls, the array data is freed and the library takes care of allocation.
5506 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5508 if (gfc_option.flag_realloc_lhs
5509 && gfc_is_reallocatable_lhs (expr1)
5510 && !gfc_expr_attr (expr1).codimension
5511 && !gfc_is_coindexed (expr1)
5512 && !(expr2->value.function.esym
5513 && expr2->value.function.esym->result->attr.allocatable))
5515 if (!expr2->value.function.isym)
5517 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
5518 ss->is_alloc_lhs = 1;
5521 realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
5524 gfc_conv_function_expr (&se, expr2);
5525 gfc_add_block_to_block (&se.pre, &se.post);
5527 return gfc_finish_block (&se.pre);
5531 /* Try to efficiently translate array(:) = 0. Return NULL if this
5535 gfc_trans_zero_assign (gfc_expr * expr)
5537 tree dest, len, type;
5541 sym = expr->symtree->n.sym;
5542 dest = gfc_get_symbol_decl (sym);
5544 type = TREE_TYPE (dest);
5545 if (POINTER_TYPE_P (type))
5546 type = TREE_TYPE (type);
5547 if (!GFC_ARRAY_TYPE_P (type))
5550 /* Determine the length of the array. */
5551 len = GFC_TYPE_ARRAY_SIZE (type);
5552 if (!len || TREE_CODE (len) != INTEGER_CST)
5555 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5556 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5557 fold_convert (gfc_array_index_type, tmp));
5559 /* If we are zeroing a local array avoid taking its address by emitting
5561 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5562 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5563 dest, build_constructor (TREE_TYPE (dest), NULL));
5565 /* Convert arguments to the correct types. */
5566 dest = fold_convert (pvoid_type_node, dest);
5567 len = fold_convert (size_type_node, len);
5569 /* Construct call to __builtin_memset. */
5570 tmp = build_call_expr_loc (input_location,
5571 built_in_decls[BUILT_IN_MEMSET],
5572 3, dest, integer_zero_node, len);
5573 return fold_convert (void_type_node, tmp);
5577 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5578 that constructs the call to __builtin_memcpy. */
5581 gfc_build_memcpy_call (tree dst, tree src, tree len)
5585 /* Convert arguments to the correct types. */
5586 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5587 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5589 dst = fold_convert (pvoid_type_node, dst);
5591 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5592 src = gfc_build_addr_expr (pvoid_type_node, src);
5594 src = fold_convert (pvoid_type_node, src);
5596 len = fold_convert (size_type_node, len);
5598 /* Construct call to __builtin_memcpy. */
5599 tmp = build_call_expr_loc (input_location,
5600 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5601 return fold_convert (void_type_node, tmp);
5605 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5606 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5607 source/rhs, both are gfc_full_array_ref_p which have been checked for
5611 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5613 tree dst, dlen, dtype;
5614 tree src, slen, stype;
5617 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5618 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5620 dtype = TREE_TYPE (dst);
5621 if (POINTER_TYPE_P (dtype))
5622 dtype = TREE_TYPE (dtype);
5623 stype = TREE_TYPE (src);
5624 if (POINTER_TYPE_P (stype))
5625 stype = TREE_TYPE (stype);
5627 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5630 /* Determine the lengths of the arrays. */
5631 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5632 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5634 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5635 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5636 dlen, fold_convert (gfc_array_index_type, tmp));
5638 slen = GFC_TYPE_ARRAY_SIZE (stype);
5639 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5641 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5642 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5643 slen, fold_convert (gfc_array_index_type, tmp));
5645 /* Sanity check that they are the same. This should always be
5646 the case, as we should already have checked for conformance. */
5647 if (!tree_int_cst_equal (slen, dlen))
5650 return gfc_build_memcpy_call (dst, src, dlen);
5654 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5655 this can't be done. EXPR1 is the destination/lhs for which
5656 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5659 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5661 unsigned HOST_WIDE_INT nelem;
5667 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5671 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5672 dtype = TREE_TYPE (dst);
5673 if (POINTER_TYPE_P (dtype))
5674 dtype = TREE_TYPE (dtype);
5675 if (!GFC_ARRAY_TYPE_P (dtype))
5678 /* Determine the lengths of the array. */
5679 len = GFC_TYPE_ARRAY_SIZE (dtype);
5680 if (!len || TREE_CODE (len) != INTEGER_CST)
5683 /* Confirm that the constructor is the same size. */
5684 if (compare_tree_int (len, nelem) != 0)
5687 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5688 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5689 fold_convert (gfc_array_index_type, tmp));
5691 stype = gfc_typenode_for_spec (&expr2->ts);
5692 src = gfc_build_constant_array_constructor (expr2, stype);
5694 stype = TREE_TYPE (src);
5695 if (POINTER_TYPE_P (stype))
5696 stype = TREE_TYPE (stype);
5698 return gfc_build_memcpy_call (dst, src, len);
5702 /* Tells whether the expression is to be treated as a variable reference. */
5705 expr_is_variable (gfc_expr *expr)
5709 if (expr->expr_type == EXPR_VARIABLE)
5712 arg = gfc_get_noncopying_intrinsic_argument (expr);
5715 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5716 return expr_is_variable (arg);
5723 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5724 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5725 init_flag indicates initialization expressions and dealloc that no
5726 deallocate prior assignment is needed (if in doubt, set true). */
5729 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5735 gfc_ss *lss_section;
5742 bool scalar_to_array;
5746 /* Assignment of the form lhs = rhs. */
5747 gfc_start_block (&block);
5749 gfc_init_se (&lse, NULL);
5750 gfc_init_se (&rse, NULL);
5753 lss = gfc_walk_expr (expr1);
5754 if (gfc_is_reallocatable_lhs (expr1)
5755 && !(expr2->expr_type == EXPR_FUNCTION
5756 && expr2->value.function.isym != NULL))
5757 lss->is_alloc_lhs = 1;
5759 if (lss != gfc_ss_terminator)
5761 /* Allow the scalarizer to workshare array assignments. */
5762 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5763 ompws_flags |= OMPWS_SCALARIZER_WS;
5765 /* The assignment needs scalarization. */
5768 /* Find a non-scalar SS from the lhs. */
5769 while (lss_section != gfc_ss_terminator
5770 && lss_section->type != GFC_SS_SECTION)
5771 lss_section = lss_section->next;
5773 gcc_assert (lss_section != gfc_ss_terminator);
5775 /* Initialize the scalarizer. */
5776 gfc_init_loopinfo (&loop);
5779 rss = gfc_walk_expr (expr2);
5780 if (rss == gfc_ss_terminator)
5782 /* The rhs is scalar. Add a ss for the expression. */
5783 rss = gfc_get_ss ();
5784 rss->next = gfc_ss_terminator;
5785 rss->type = GFC_SS_SCALAR;
5788 /* Associate the SS with the loop. */
5789 gfc_add_ss_to_loop (&loop, lss);
5790 gfc_add_ss_to_loop (&loop, rss);
5792 /* Calculate the bounds of the scalarization. */
5793 gfc_conv_ss_startstride (&loop);
5794 /* Enable loop reversal. */
5795 for (n = 0; n < loop.dimen; n++)
5796 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5797 /* Resolve any data dependencies in the statement. */
5798 gfc_conv_resolve_dependencies (&loop, lss, rss);
5799 /* Setup the scalarizing loops. */
5800 gfc_conv_loop_setup (&loop, &expr2->where);
5802 /* Setup the gfc_se structures. */
5803 gfc_copy_loopinfo_to_se (&lse, &loop);
5804 gfc_copy_loopinfo_to_se (&rse, &loop);
5807 gfc_mark_ss_chain_used (rss, 1);
5808 if (loop.temp_ss == NULL)
5811 gfc_mark_ss_chain_used (lss, 1);
5815 lse.ss = loop.temp_ss;
5816 gfc_mark_ss_chain_used (lss, 3);
5817 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5820 /* Start the scalarized loop body. */
5821 gfc_start_scalarized_body (&loop, &body);
5824 gfc_init_block (&body);
5826 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5828 /* Translate the expression. */
5829 gfc_conv_expr (&rse, expr2);
5831 /* Stabilize a string length for temporaries. */
5832 if (expr2->ts.type == BT_CHARACTER)
5833 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5835 string_length = NULL_TREE;
5839 gfc_conv_tmp_array_ref (&lse);
5840 if (expr2->ts.type == BT_CHARACTER)
5841 lse.string_length = string_length;
5844 gfc_conv_expr (&lse, expr1);
5846 /* Assignments of scalar derived types with allocatable components
5847 to arrays must be done with a deep copy and the rhs temporary
5848 must have its components deallocated afterwards. */
5849 scalar_to_array = (expr2->ts.type == BT_DERIVED
5850 && expr2->ts.u.derived->attr.alloc_comp
5851 && !expr_is_variable (expr2)
5852 && !gfc_is_constant_expr (expr2)
5853 && expr1->rank && !expr2->rank);
5854 if (scalar_to_array && dealloc)
5856 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5857 gfc_add_expr_to_block (&loop.post, tmp);
5860 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5861 l_is_temp || init_flag,
5862 expr_is_variable (expr2) || scalar_to_array,
5864 gfc_add_expr_to_block (&body, tmp);
5866 if (lss == gfc_ss_terminator)
5868 /* Use the scalar assignment as is. */
5869 gfc_add_block_to_block (&block, &body);
5873 gcc_assert (lse.ss == gfc_ss_terminator
5874 && rse.ss == gfc_ss_terminator);
5878 gfc_trans_scalarized_loop_boundary (&loop, &body);
5880 /* We need to copy the temporary to the actual lhs. */
5881 gfc_init_se (&lse, NULL);
5882 gfc_init_se (&rse, NULL);
5883 gfc_copy_loopinfo_to_se (&lse, &loop);
5884 gfc_copy_loopinfo_to_se (&rse, &loop);
5886 rse.ss = loop.temp_ss;
5889 gfc_conv_tmp_array_ref (&rse);
5890 gfc_conv_expr (&lse, expr1);
5892 gcc_assert (lse.ss == gfc_ss_terminator
5893 && rse.ss == gfc_ss_terminator);
5895 if (expr2->ts.type == BT_CHARACTER)
5896 rse.string_length = string_length;
5898 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5899 false, false, dealloc);
5900 gfc_add_expr_to_block (&body, tmp);
5903 /* Allocate or reallocate lhs of allocatable array. */
5904 if (gfc_option.flag_realloc_lhs
5905 && gfc_is_reallocatable_lhs (expr1)
5906 && !gfc_expr_attr (expr1).codimension
5907 && !gfc_is_coindexed (expr1))
5909 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
5910 if (tmp != NULL_TREE)
5911 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
5914 /* Generate the copying loops. */
5915 gfc_trans_scalarizing_loops (&loop, &body);
5917 /* Wrap the whole thing up. */
5918 gfc_add_block_to_block (&block, &loop.pre);
5919 gfc_add_block_to_block (&block, &loop.post);
5921 gfc_cleanup_loop (&loop);
5924 return gfc_finish_block (&block);
5928 /* Check whether EXPR is a copyable array. */
5931 copyable_array_p (gfc_expr * expr)
5933 if (expr->expr_type != EXPR_VARIABLE)
5936 /* First check it's an array. */
5937 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5940 if (!gfc_full_array_ref_p (expr->ref, NULL))
5943 /* Next check that it's of a simple enough type. */
5944 switch (expr->ts.type)
5956 return !expr->ts.u.derived->attr.alloc_comp;
5965 /* Translate an assignment. */
5968 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5973 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
5975 gfc_error ("Assignment to deferred-length character variable at %L "
5976 "not implemented", &expr1->where);
5980 /* Special case a single function returning an array. */
5981 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5983 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5988 /* Special case assigning an array to zero. */
5989 if (copyable_array_p (expr1)
5990 && is_zero_initializer_p (expr2))
5992 tmp = gfc_trans_zero_assign (expr1);
5997 /* Special case copying one array to another. */
5998 if (copyable_array_p (expr1)
5999 && copyable_array_p (expr2)
6000 && gfc_compare_types (&expr1->ts, &expr2->ts)
6001 && !gfc_check_dependency (expr1, expr2, 0))
6003 tmp = gfc_trans_array_copy (expr1, expr2);
6008 /* Special case initializing an array from a constant array constructor. */
6009 if (copyable_array_p (expr1)
6010 && expr2->expr_type == EXPR_ARRAY
6011 && gfc_compare_types (&expr1->ts, &expr2->ts))
6013 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6018 /* Fallback to the scalarizer to generate explicit loops. */
6019 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6023 gfc_trans_init_assign (gfc_code * code)
6025 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6029 gfc_trans_assign (gfc_code * code)
6031 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6035 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6036 A MEMCPY is needed to copy the full data from the default initializer
6037 of the dynamic type. */
6040 gfc_trans_class_init_assign (gfc_code *code)
6044 gfc_se dst,src,memsz;
6045 gfc_expr *lhs,*rhs,*sz;
6047 gfc_start_block (&block);
6049 lhs = gfc_copy_expr (code->expr1);
6050 gfc_add_data_component (lhs);
6052 rhs = gfc_copy_expr (code->expr1);
6053 gfc_add_vptr_component (rhs);
6054 gfc_add_def_init_component (rhs);
6056 sz = gfc_copy_expr (code->expr1);
6057 gfc_add_vptr_component (sz);
6058 gfc_add_size_component (sz);
6060 gfc_init_se (&dst, NULL);
6061 gfc_init_se (&src, NULL);
6062 gfc_init_se (&memsz, NULL);
6063 gfc_conv_expr (&dst, lhs);
6064 gfc_conv_expr (&src, rhs);
6065 gfc_conv_expr (&memsz, sz);
6066 gfc_add_block_to_block (&block, &src.pre);
6067 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6068 gfc_add_expr_to_block (&block, tmp);
6070 return gfc_finish_block (&block);
6074 /* Translate an assignment to a CLASS object
6075 (pointer or ordinary assignment). */
6078 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6085 gfc_start_block (&block);
6087 if (expr2->ts.type != BT_CLASS)
6089 /* Insert an additional assignment which sets the '_vptr' field. */
6090 lhs = gfc_copy_expr (expr1);
6091 gfc_add_vptr_component (lhs);
6092 if (expr2->ts.type == BT_DERIVED)
6096 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6098 rhs = gfc_get_expr ();
6099 rhs->expr_type = EXPR_VARIABLE;
6100 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6104 else if (expr2->expr_type == EXPR_NULL)
6105 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
6109 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6110 gfc_add_expr_to_block (&block, tmp);
6112 gfc_free_expr (lhs);
6113 gfc_free_expr (rhs);
6116 /* Do the actual CLASS assignment. */
6117 if (expr2->ts.type == BT_CLASS)
6120 gfc_add_data_component (expr1);
6122 if (op == EXEC_ASSIGN)
6123 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6124 else if (op == EXEC_POINTER_ASSIGN)
6125 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6129 gfc_add_expr_to_block (&block, tmp);
6131 return gfc_finish_block (&block);