1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se * se, gfc_se * parent)
66 memset (se, 0, sizeof (gfc_se));
67 gfc_init_block (&se->pre);
68 gfc_init_block (&se->post);
73 gfc_copy_se_loopvars (se, parent);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se * se)
110 if (CONSTANT_CLASS_P (se->expr))
113 /* We need a temporary for this result. */
114 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115 gfc_add_modify (&se->pre, var, se->expr);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol * sym)
128 gcc_assert (sym->attr.dummy);
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
140 cond = fold_build2 (NE_EXPR, boolean_type_node, decl,
141 fold_convert (TREE_TYPE (decl), null_pointer_node));
143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
144 as actual argument to denote absent dummies. For array descriptors,
145 we thus also need to check the array descriptor. */
146 if (!sym->attr.pointer && !sym->attr.allocatable
147 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
148 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
151 tmp = build_fold_indirect_ref_loc (input_location, decl);
152 tmp = gfc_conv_array_data (tmp);
153 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
154 fold_convert (TREE_TYPE (tmp), null_pointer_node));
155 cond = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, tmp);
162 /* Converts a missing, dummy argument into a null or zero. */
165 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
170 present = gfc_conv_expr_present (arg->symtree->n.sym);
174 /* Create a temporary and convert it to the correct type. */
175 tmp = gfc_get_int_type (kind);
176 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
179 /* Test for a NULL value. */
180 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
181 fold_convert (TREE_TYPE (tmp), integer_one_node));
182 tmp = gfc_evaluate_now (tmp, &se->pre);
183 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
187 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
188 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
189 tmp = gfc_evaluate_now (tmp, &se->pre);
193 if (ts.type == BT_CHARACTER)
195 tmp = build_int_cst (gfc_charlen_type_node, 0);
196 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
197 present, se->string_length, tmp);
198 tmp = gfc_evaluate_now (tmp, &se->pre);
199 se->string_length = tmp;
205 /* Get the character length of an expression, looking through gfc_refs
209 gfc_get_expr_charlen (gfc_expr *e)
214 gcc_assert (e->expr_type == EXPR_VARIABLE
215 && e->ts.type == BT_CHARACTER);
217 length = NULL; /* To silence compiler warning. */
219 if (is_subref_array (e) && e->ts.u.cl->length)
222 gfc_init_se (&tmpse, NULL);
223 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
224 e->ts.u.cl->backend_decl = tmpse.expr;
228 /* First candidate: if the variable is of type CHARACTER, the
229 expression's length could be the length of the character
231 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
232 length = e->symtree->n.sym->ts.u.cl->backend_decl;
234 /* Look through the reference chain for component references. */
235 for (r = e->ref; r; r = r->next)
240 if (r->u.c.component->ts.type == BT_CHARACTER)
241 length = r->u.c.component->ts.u.cl->backend_decl;
249 /* We should never got substring references here. These will be
250 broken down by the scalarizer. */
256 gcc_assert (length != NULL);
261 /* For each character array constructor subexpression without a ts.u.cl->length,
262 replace it by its first element (if there aren't any elements, the length
263 should already be set to zero). */
266 flatten_array_ctors_without_strlen (gfc_expr* e)
268 gfc_actual_arglist* arg;
274 switch (e->expr_type)
278 flatten_array_ctors_without_strlen (e->value.op.op1);
279 flatten_array_ctors_without_strlen (e->value.op.op2);
283 /* TODO: Implement as with EXPR_FUNCTION when needed. */
287 for (arg = e->value.function.actual; arg; arg = arg->next)
288 flatten_array_ctors_without_strlen (arg->expr);
293 /* We've found what we're looking for. */
294 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
299 gcc_assert (e->value.constructor);
301 c = gfc_constructor_first (e->value.constructor);
305 flatten_array_ctors_without_strlen (new_expr);
306 gfc_replace_expr (e, new_expr);
310 /* Otherwise, fall through to handle constructor elements. */
312 for (c = gfc_constructor_first (e->value.constructor);
313 c; c = gfc_constructor_next (c))
314 flatten_array_ctors_without_strlen (c->expr);
324 /* Generate code to initialize a string length variable. Returns the
325 value. For array constructors, cl->length might be NULL and in this case,
326 the first element of the constructor is needed. expr is the original
327 expression so we can access it but can be NULL if this is not needed. */
330 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
334 gfc_init_se (&se, NULL);
336 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
337 "flatten" array constructors by taking their first element; all elements
338 should be the same length or a cl->length should be present. */
344 expr_flat = gfc_copy_expr (expr);
345 flatten_array_ctors_without_strlen (expr_flat);
346 gfc_resolve_expr (expr_flat);
348 gfc_conv_expr (&se, expr_flat);
349 gfc_add_block_to_block (pblock, &se.pre);
350 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
352 gfc_free_expr (expr_flat);
356 /* Convert cl->length. */
358 gcc_assert (cl->length);
360 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
361 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
362 build_int_cst (gfc_charlen_type_node, 0));
363 gfc_add_block_to_block (pblock, &se.pre);
365 if (cl->backend_decl)
366 gfc_add_modify (pblock, cl->backend_decl, se.expr);
368 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
373 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
374 const char *name, locus *where)
383 type = gfc_get_character_type (kind, ref->u.ss.length);
384 type = build_pointer_type (type);
386 gfc_init_se (&start, se);
387 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
388 gfc_add_block_to_block (&se->pre, &start.pre);
390 if (integer_onep (start.expr))
391 gfc_conv_string_parameter (se);
396 /* Avoid multiple evaluation of substring start. */
397 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
398 start.expr = gfc_evaluate_now (start.expr, &se->pre);
400 /* Change the start of the string. */
401 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
404 tmp = build_fold_indirect_ref_loc (input_location,
406 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
407 se->expr = gfc_build_addr_expr (type, tmp);
410 /* Length = end + 1 - start. */
411 gfc_init_se (&end, se);
412 if (ref->u.ss.end == NULL)
413 end.expr = se->string_length;
416 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
417 gfc_add_block_to_block (&se->pre, &end.pre);
421 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
422 end.expr = gfc_evaluate_now (end.expr, &se->pre);
424 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
426 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
427 start.expr, end.expr);
429 /* Check lower bound. */
430 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
431 build_int_cst (gfc_charlen_type_node, 1));
432 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
435 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
436 "is less than one", name);
438 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
440 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
441 fold_convert (long_integer_type_node,
445 /* Check upper bound. */
446 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
448 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
451 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
452 "exceeds string length (%%ld)", name);
454 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
455 "exceeds string length (%%ld)");
456 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
457 fold_convert (long_integer_type_node, end.expr),
458 fold_convert (long_integer_type_node,
463 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
464 end.expr, start.expr);
465 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
466 build_int_cst (gfc_charlen_type_node, 1), tmp);
467 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
468 build_int_cst (gfc_charlen_type_node, 0));
469 se->string_length = tmp;
473 /* Convert a derived type component reference. */
476 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
483 c = ref->u.c.component;
485 gcc_assert (c->backend_decl);
487 field = c->backend_decl;
488 gcc_assert (TREE_CODE (field) == FIELD_DECL);
490 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
494 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
496 tmp = c->ts.u.cl->backend_decl;
497 /* Components must always be constant length. */
498 gcc_assert (tmp && INTEGER_CST_P (tmp));
499 se->string_length = tmp;
502 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
503 && c->ts.type != BT_CHARACTER)
504 || c->attr.proc_pointer)
505 se->expr = build_fold_indirect_ref_loc (input_location,
510 /* This function deals with component references to components of the
511 parent type for derived type extensons. */
513 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
521 c = ref->u.c.component;
523 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
524 parent.type = REF_COMPONENT;
527 parent.u.c.component = dt->components;
529 if (dt->backend_decl == NULL)
530 gfc_get_derived_type (dt);
532 if (dt->attr.extension && dt->components)
534 if (dt->attr.is_class)
535 cmp = dt->components;
537 cmp = dt->components->next;
538 /* Return if the component is not in the parent type. */
539 for (; cmp; cmp = cmp->next)
540 if (strcmp (c->name, cmp->name) == 0)
543 /* Otherwise build the reference and call self. */
544 gfc_conv_component_ref (se, &parent);
545 parent.u.c.sym = dt->components->ts.u.derived;
546 parent.u.c.component = c;
547 conv_parent_component_references (se, &parent);
551 /* Return the contents of a variable. Also handles reference/pointer
552 variables (all Fortran pointer references are implicit). */
555 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
559 tree parent_decl = NULL_TREE;
562 bool alternate_entry;
565 sym = expr->symtree->n.sym;
568 /* Check that something hasn't gone horribly wrong. */
569 gcc_assert (se->ss != gfc_ss_terminator);
570 gcc_assert (se->ss->expr == expr);
572 /* A scalarized term. We already know the descriptor. */
573 se->expr = se->ss->data.info.descriptor;
574 se->string_length = se->ss->string_length;
575 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
576 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
581 tree se_expr = NULL_TREE;
583 se->expr = gfc_get_symbol_decl (sym);
585 /* Deal with references to a parent results or entries by storing
586 the current_function_decl and moving to the parent_decl. */
587 return_value = sym->attr.function && sym->result == sym;
588 alternate_entry = sym->attr.function && sym->attr.entry
589 && sym->result == sym;
590 entry_master = sym->attr.result
591 && sym->ns->proc_name->attr.entry_master
592 && !gfc_return_by_reference (sym->ns->proc_name);
593 if (current_function_decl)
594 parent_decl = DECL_CONTEXT (current_function_decl);
596 if ((se->expr == parent_decl && return_value)
597 || (sym->ns && sym->ns->proc_name
599 && sym->ns->proc_name->backend_decl == parent_decl
600 && (alternate_entry || entry_master)))
605 /* Special case for assigning the return value of a function.
606 Self recursive functions must have an explicit return value. */
607 if (return_value && (se->expr == current_function_decl || parent_flag))
608 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
610 /* Similarly for alternate entry points. */
611 else if (alternate_entry
612 && (sym->ns->proc_name->backend_decl == current_function_decl
615 gfc_entry_list *el = NULL;
617 for (el = sym->ns->entries; el; el = el->next)
620 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
625 else if (entry_master
626 && (sym->ns->proc_name->backend_decl == current_function_decl
628 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
633 /* Procedure actual arguments. */
634 else if (sym->attr.flavor == FL_PROCEDURE
635 && se->expr != current_function_decl)
637 if (!sym->attr.dummy && !sym->attr.proc_pointer)
639 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
640 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
646 /* Dereference the expression, where needed. Since characters
647 are entirely different from other types, they are treated
649 if (sym->ts.type == BT_CHARACTER)
651 /* Dereference character pointer dummy arguments
653 if ((sym->attr.pointer || sym->attr.allocatable)
655 || sym->attr.function
656 || sym->attr.result))
657 se->expr = build_fold_indirect_ref_loc (input_location,
661 else if (!sym->attr.value)
663 /* Dereference non-character scalar dummy arguments. */
664 if (sym->attr.dummy && !sym->attr.dimension)
665 se->expr = build_fold_indirect_ref_loc (input_location,
668 /* Dereference scalar hidden result. */
669 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
670 && (sym->attr.function || sym->attr.result)
671 && !sym->attr.dimension && !sym->attr.pointer
672 && !sym->attr.always_explicit)
673 se->expr = build_fold_indirect_ref_loc (input_location,
676 /* Dereference non-character pointer variables.
677 These must be dummies, results, or scalars. */
678 if ((sym->attr.pointer || sym->attr.allocatable
679 || gfc_is_associate_pointer (sym))
681 || sym->attr.function
683 || !sym->attr.dimension))
684 se->expr = build_fold_indirect_ref_loc (input_location,
691 /* For character variables, also get the length. */
692 if (sym->ts.type == BT_CHARACTER)
694 /* If the character length of an entry isn't set, get the length from
695 the master function instead. */
696 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
697 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
699 se->string_length = sym->ts.u.cl->backend_decl;
700 gcc_assert (se->string_length);
708 /* Return the descriptor if that's what we want and this is an array
709 section reference. */
710 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
712 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
713 /* Return the descriptor for array pointers and allocations. */
715 && ref->next == NULL && (se->descriptor_only))
718 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
719 /* Return a pointer to an element. */
723 if (ref->u.c.sym->attr.extension)
724 conv_parent_component_references (se, ref);
726 gfc_conv_component_ref (se, ref);
730 gfc_conv_substring (se, ref, expr->ts.kind,
731 expr->symtree->name, &expr->where);
740 /* Pointer assignment, allocation or pass by reference. Arrays are handled
742 if (se->want_pointer)
744 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
745 gfc_conv_string_parameter (se);
747 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
752 /* Unary ops are easy... Or they would be if ! was a valid op. */
755 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
760 gcc_assert (expr->ts.type != BT_CHARACTER);
761 /* Initialize the operand. */
762 gfc_init_se (&operand, se);
763 gfc_conv_expr_val (&operand, expr->value.op.op1);
764 gfc_add_block_to_block (&se->pre, &operand.pre);
766 type = gfc_typenode_for_spec (&expr->ts);
768 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
769 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
770 All other unary operators have an equivalent GIMPLE unary operator. */
771 if (code == TRUTH_NOT_EXPR)
772 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
773 build_int_cst (type, 0));
775 se->expr = fold_build1 (code, type, operand.expr);
779 /* Expand power operator to optimal multiplications when a value is raised
780 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
781 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
782 Programming", 3rd Edition, 1998. */
784 /* This code is mostly duplicated from expand_powi in the backend.
785 We establish the "optimal power tree" lookup table with the defined size.
786 The items in the table are the exponents used to calculate the index
787 exponents. Any integer n less than the value can get an "addition chain",
788 with the first node being one. */
789 #define POWI_TABLE_SIZE 256
791 /* The table is from builtins.c. */
792 static const unsigned char powi_table[POWI_TABLE_SIZE] =
794 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
795 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
796 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
797 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
798 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
799 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
800 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
801 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
802 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
803 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
804 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
805 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
806 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
807 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
808 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
809 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
810 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
811 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
812 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
813 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
814 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
815 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
816 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
817 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
818 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
819 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
820 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
821 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
822 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
823 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
824 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
825 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
828 /* If n is larger than lookup table's max index, we use the "window
830 #define POWI_WINDOW_SIZE 3
832 /* Recursive function to expand the power operator. The temporary
833 values are put in tmpvar. The function returns tmpvar[1] ** n. */
835 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
842 if (n < POWI_TABLE_SIZE)
847 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
848 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
852 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
853 op0 = gfc_conv_powi (se, n - digit, tmpvar);
854 op1 = gfc_conv_powi (se, digit, tmpvar);
858 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
862 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
863 tmp = gfc_evaluate_now (tmp, &se->pre);
865 if (n < POWI_TABLE_SIZE)
872 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
873 return 1. Else return 0 and a call to runtime library functions
874 will have to be built. */
876 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
881 tree vartmp[POWI_TABLE_SIZE];
883 unsigned HOST_WIDE_INT n;
886 /* If exponent is too large, we won't expand it anyway, so don't bother
887 with large integer values. */
888 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
891 m = double_int_to_shwi (TREE_INT_CST (rhs));
892 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
893 of the asymmetric range of the integer type. */
894 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
896 type = TREE_TYPE (lhs);
897 sgn = tree_int_cst_sgn (rhs);
899 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
900 || optimize_size) && (m > 2 || m < -1))
906 se->expr = gfc_build_const (type, integer_one_node);
910 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
911 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
913 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
914 lhs, build_int_cst (TREE_TYPE (lhs), -1));
915 cond = fold_build2 (EQ_EXPR, boolean_type_node,
916 lhs, build_int_cst (TREE_TYPE (lhs), 1));
919 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
922 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
923 se->expr = fold_build3 (COND_EXPR, type,
924 tmp, build_int_cst (type, 1),
925 build_int_cst (type, 0));
929 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
930 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
931 build_int_cst (type, 0));
932 se->expr = fold_build3 (COND_EXPR, type,
933 cond, build_int_cst (type, 1), tmp);
937 memset (vartmp, 0, sizeof (vartmp));
941 tmp = gfc_build_const (type, integer_one_node);
942 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
945 se->expr = gfc_conv_powi (se, n, vartmp);
951 /* Power op (**). Constant integer exponent has special handling. */
954 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
956 tree gfc_int4_type_node;
963 gfc_init_se (&lse, se);
964 gfc_conv_expr_val (&lse, expr->value.op.op1);
965 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
966 gfc_add_block_to_block (&se->pre, &lse.pre);
968 gfc_init_se (&rse, se);
969 gfc_conv_expr_val (&rse, expr->value.op.op2);
970 gfc_add_block_to_block (&se->pre, &rse.pre);
972 if (expr->value.op.op2->ts.type == BT_INTEGER
973 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
974 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
977 gfc_int4_type_node = gfc_get_int_type (4);
979 kind = expr->value.op.op1->ts.kind;
980 switch (expr->value.op.op2->ts.type)
983 ikind = expr->value.op.op2->ts.kind;
988 rse.expr = convert (gfc_int4_type_node, rse.expr);
1010 if (expr->value.op.op1->ts.type == BT_INTEGER)
1011 lse.expr = convert (gfc_int4_type_node, lse.expr);
1036 switch (expr->value.op.op1->ts.type)
1039 if (kind == 3) /* Case 16 was not handled properly above. */
1041 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1045 /* Use builtins for real ** int4. */
1051 fndecl = built_in_decls[BUILT_IN_POWIF];
1055 fndecl = built_in_decls[BUILT_IN_POWI];
1059 fndecl = built_in_decls[BUILT_IN_POWIL];
1063 /* Use the __builtin_powil() only if real(kind=16) is
1064 actually the C long double type. */
1065 if (!gfc_real16_is_float128)
1066 fndecl = built_in_decls[BUILT_IN_POWIL];
1074 /* If we don't have a good builtin for this, go for the
1075 library function. */
1077 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1081 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1090 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1094 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1102 se->expr = build_call_expr_loc (input_location,
1103 fndecl, 2, lse.expr, rse.expr);
1107 /* Generate code to allocate a string temporary. */
1110 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1115 if (gfc_can_put_var_on_stack (len))
1117 /* Create a temporary variable to hold the result. */
1118 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1119 build_int_cst (gfc_charlen_type_node, 1));
1120 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1122 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1123 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1125 tmp = build_array_type (TREE_TYPE (type), tmp);
1127 var = gfc_create_var (tmp, "str");
1128 var = gfc_build_addr_expr (type, var);
1132 /* Allocate a temporary to hold the result. */
1133 var = gfc_create_var (type, "pstr");
1134 tmp = gfc_call_malloc (&se->pre, type,
1135 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1136 fold_convert (TREE_TYPE (len),
1137 TYPE_SIZE (type))));
1138 gfc_add_modify (&se->pre, var, tmp);
1140 /* Free the temporary afterwards. */
1141 tmp = gfc_call_free (convert (pvoid_type_node, var));
1142 gfc_add_expr_to_block (&se->post, tmp);
1149 /* Handle a string concatenation operation. A temporary will be allocated to
1153 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1156 tree len, type, var, tmp, fndecl;
1158 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1159 && expr->value.op.op2->ts.type == BT_CHARACTER);
1160 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1162 gfc_init_se (&lse, se);
1163 gfc_conv_expr (&lse, expr->value.op.op1);
1164 gfc_conv_string_parameter (&lse);
1165 gfc_init_se (&rse, se);
1166 gfc_conv_expr (&rse, expr->value.op.op2);
1167 gfc_conv_string_parameter (&rse);
1169 gfc_add_block_to_block (&se->pre, &lse.pre);
1170 gfc_add_block_to_block (&se->pre, &rse.pre);
1172 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1173 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1174 if (len == NULL_TREE)
1176 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1177 lse.string_length, rse.string_length);
1180 type = build_pointer_type (type);
1182 var = gfc_conv_string_tmp (se, type, len);
1184 /* Do the actual concatenation. */
1185 if (expr->ts.kind == 1)
1186 fndecl = gfor_fndecl_concat_string;
1187 else if (expr->ts.kind == 4)
1188 fndecl = gfor_fndecl_concat_string_char4;
1192 tmp = build_call_expr_loc (input_location,
1193 fndecl, 6, len, var, lse.string_length, lse.expr,
1194 rse.string_length, rse.expr);
1195 gfc_add_expr_to_block (&se->pre, tmp);
1197 /* Add the cleanup for the operands. */
1198 gfc_add_block_to_block (&se->pre, &rse.post);
1199 gfc_add_block_to_block (&se->pre, &lse.post);
1202 se->string_length = len;
1205 /* Translates an op expression. Common (binary) cases are handled by this
1206 function, others are passed on. Recursion is used in either case.
1207 We use the fact that (op1.ts == op2.ts) (except for the power
1209 Operators need no special handling for scalarized expressions as long as
1210 they call gfc_conv_simple_val to get their operands.
1211 Character strings get special handling. */
1214 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1216 enum tree_code code;
1225 switch (expr->value.op.op)
1227 case INTRINSIC_PARENTHESES:
1228 if ((expr->ts.type == BT_REAL
1229 || expr->ts.type == BT_COMPLEX)
1230 && gfc_option.flag_protect_parens)
1232 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1233 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1238 case INTRINSIC_UPLUS:
1239 gfc_conv_expr (se, expr->value.op.op1);
1242 case INTRINSIC_UMINUS:
1243 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1247 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1250 case INTRINSIC_PLUS:
1254 case INTRINSIC_MINUS:
1258 case INTRINSIC_TIMES:
1262 case INTRINSIC_DIVIDE:
1263 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1264 an integer, we must round towards zero, so we use a
1266 if (expr->ts.type == BT_INTEGER)
1267 code = TRUNC_DIV_EXPR;
1272 case INTRINSIC_POWER:
1273 gfc_conv_power_op (se, expr);
1276 case INTRINSIC_CONCAT:
1277 gfc_conv_concat_op (se, expr);
1281 code = TRUTH_ANDIF_EXPR;
1286 code = TRUTH_ORIF_EXPR;
1290 /* EQV and NEQV only work on logicals, but since we represent them
1291 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1293 case INTRINSIC_EQ_OS:
1301 case INTRINSIC_NE_OS:
1302 case INTRINSIC_NEQV:
1309 case INTRINSIC_GT_OS:
1316 case INTRINSIC_GE_OS:
1323 case INTRINSIC_LT_OS:
1330 case INTRINSIC_LE_OS:
1336 case INTRINSIC_USER:
1337 case INTRINSIC_ASSIGN:
1338 /* These should be converted into function calls by the frontend. */
1342 fatal_error ("Unknown intrinsic op");
1346 /* The only exception to this is **, which is handled separately anyway. */
1347 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1349 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1353 gfc_init_se (&lse, se);
1354 gfc_conv_expr (&lse, expr->value.op.op1);
1355 gfc_add_block_to_block (&se->pre, &lse.pre);
1358 gfc_init_se (&rse, se);
1359 gfc_conv_expr (&rse, expr->value.op.op2);
1360 gfc_add_block_to_block (&se->pre, &rse.pre);
1364 gfc_conv_string_parameter (&lse);
1365 gfc_conv_string_parameter (&rse);
1367 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1368 rse.string_length, rse.expr,
1369 expr->value.op.op1->ts.kind,
1371 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1372 gfc_add_block_to_block (&lse.post, &rse.post);
1375 type = gfc_typenode_for_spec (&expr->ts);
1379 /* The result of logical ops is always boolean_type_node. */
1380 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1381 se->expr = convert (type, tmp);
1384 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1386 /* Add the post blocks. */
1387 gfc_add_block_to_block (&se->post, &rse.post);
1388 gfc_add_block_to_block (&se->post, &lse.post);
1391 /* If a string's length is one, we convert it to a single character. */
1394 gfc_string_to_single_character (tree len, tree str, int kind)
1396 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1398 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1401 if (TREE_INT_CST_LOW (len) == 1)
1403 str = fold_convert (gfc_get_pchar_type (kind), str);
1404 return build_fold_indirect_ref_loc (input_location, str);
1408 && TREE_CODE (str) == ADDR_EXPR
1409 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1410 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1411 && array_ref_low_bound (TREE_OPERAND (str, 0))
1412 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1413 && TREE_INT_CST_LOW (len) > 1
1414 && TREE_INT_CST_LOW (len)
1415 == (unsigned HOST_WIDE_INT)
1416 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1418 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1419 ret = build_fold_indirect_ref_loc (input_location, ret);
1420 if (TREE_CODE (ret) == INTEGER_CST)
1422 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1423 int i, length = TREE_STRING_LENGTH (string_cst);
1424 const char *ptr = TREE_STRING_POINTER (string_cst);
1426 for (i = 1; i < length; i++)
1439 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1442 if (sym->backend_decl)
1444 /* This becomes the nominal_type in
1445 function.c:assign_parm_find_data_types. */
1446 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1447 /* This becomes the passed_type in
1448 function.c:assign_parm_find_data_types. C promotes char to
1449 integer for argument passing. */
1450 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1452 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1457 /* If we have a constant character expression, make it into an
1459 if ((*expr)->expr_type == EXPR_CONSTANT)
1464 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1465 (int)(*expr)->value.character.string[0]);
1466 if ((*expr)->ts.kind != gfc_c_int_kind)
1468 /* The expr needs to be compatible with a C int. If the
1469 conversion fails, then the 2 causes an ICE. */
1470 ts.type = BT_INTEGER;
1471 ts.kind = gfc_c_int_kind;
1472 gfc_convert_type (*expr, &ts, 2);
1475 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1477 if ((*expr)->ref == NULL)
1479 se->expr = gfc_string_to_single_character
1480 (build_int_cst (integer_type_node, 1),
1481 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1483 ((*expr)->symtree->n.sym)),
1488 gfc_conv_variable (se, *expr);
1489 se->expr = gfc_string_to_single_character
1490 (build_int_cst (integer_type_node, 1),
1491 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1499 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1500 if STR is a string literal, otherwise return -1. */
1503 gfc_optimize_len_trim (tree len, tree str, int kind)
1506 && TREE_CODE (str) == ADDR_EXPR
1507 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1508 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1509 && array_ref_low_bound (TREE_OPERAND (str, 0))
1510 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1511 && TREE_INT_CST_LOW (len) >= 1
1512 && TREE_INT_CST_LOW (len)
1513 == (unsigned HOST_WIDE_INT)
1514 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1516 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1517 folded = build_fold_indirect_ref_loc (input_location, folded);
1518 if (TREE_CODE (folded) == INTEGER_CST)
1520 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1521 int length = TREE_STRING_LENGTH (string_cst);
1522 const char *ptr = TREE_STRING_POINTER (string_cst);
1524 for (; length > 0; length--)
1525 if (ptr[length - 1] != ' ')
1534 /* Compare two strings. If they are all single characters, the result is the
1535 subtraction of them. Otherwise, we build a library call. */
1538 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1539 enum tree_code code)
1545 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1546 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1548 sc1 = gfc_string_to_single_character (len1, str1, kind);
1549 sc2 = gfc_string_to_single_character (len2, str2, kind);
1551 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1553 /* Deal with single character specially. */
1554 sc1 = fold_convert (integer_type_node, sc1);
1555 sc2 = fold_convert (integer_type_node, sc2);
1556 return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1559 if ((code == EQ_EXPR || code == NE_EXPR)
1561 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1563 /* If one string is a string literal with LEN_TRIM longer
1564 than the length of the second string, the strings
1566 int len = gfc_optimize_len_trim (len1, str1, kind);
1567 if (len > 0 && compare_tree_int (len2, len) < 0)
1568 return integer_one_node;
1569 len = gfc_optimize_len_trim (len2, str2, kind);
1570 if (len > 0 && compare_tree_int (len1, len) < 0)
1571 return integer_one_node;
1574 /* Build a call for the comparison. */
1576 fndecl = gfor_fndecl_compare_string;
1578 fndecl = gfor_fndecl_compare_string_char4;
1582 return build_call_expr_loc (input_location, fndecl, 4,
1583 len1, str1, len2, str2);
1587 /* Return the backend_decl for a procedure pointer component. */
1590 get_proc_ptr_comp (gfc_expr *e)
1594 gfc_init_se (&comp_se, NULL);
1595 e2 = gfc_copy_expr (e);
1596 e2->expr_type = EXPR_VARIABLE;
1597 gfc_conv_expr (&comp_se, e2);
1599 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1604 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1608 if (gfc_is_proc_ptr_comp (expr, NULL))
1609 tmp = get_proc_ptr_comp (expr);
1610 else if (sym->attr.dummy)
1612 tmp = gfc_get_symbol_decl (sym);
1613 if (sym->attr.proc_pointer)
1614 tmp = build_fold_indirect_ref_loc (input_location,
1616 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1617 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1621 if (!sym->backend_decl)
1622 sym->backend_decl = gfc_get_extern_function_decl (sym);
1624 tmp = sym->backend_decl;
1626 if (sym->attr.cray_pointee)
1628 /* TODO - make the cray pointee a pointer to a procedure,
1629 assign the pointer to it and use it for the call. This
1631 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1632 gfc_get_symbol_decl (sym->cp_pointer));
1633 tmp = gfc_evaluate_now (tmp, &se->pre);
1636 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1638 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1639 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1646 /* Initialize MAPPING. */
1649 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1651 mapping->syms = NULL;
1652 mapping->charlens = NULL;
1656 /* Free all memory held by MAPPING (but not MAPPING itself). */
1659 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1661 gfc_interface_sym_mapping *sym;
1662 gfc_interface_sym_mapping *nextsym;
1664 gfc_charlen *nextcl;
1666 for (sym = mapping->syms; sym; sym = nextsym)
1668 nextsym = sym->next;
1669 sym->new_sym->n.sym->formal = NULL;
1670 gfc_free_symbol (sym->new_sym->n.sym);
1671 gfc_free_expr (sym->expr);
1672 gfc_free (sym->new_sym);
1675 for (cl = mapping->charlens; cl; cl = nextcl)
1678 gfc_free_expr (cl->length);
1684 /* Return a copy of gfc_charlen CL. Add the returned structure to
1685 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1687 static gfc_charlen *
1688 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1691 gfc_charlen *new_charlen;
1693 new_charlen = gfc_get_charlen ();
1694 new_charlen->next = mapping->charlens;
1695 new_charlen->length = gfc_copy_expr (cl->length);
1697 mapping->charlens = new_charlen;
1702 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1703 array variable that can be used as the actual argument for dummy
1704 argument SYM. Add any initialization code to BLOCK. PACKED is as
1705 for gfc_get_nodesc_array_type and DATA points to the first element
1706 in the passed array. */
1709 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1710 gfc_packed packed, tree data)
1715 type = gfc_typenode_for_spec (&sym->ts);
1716 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1717 !sym->attr.target && !sym->attr.pointer
1718 && !sym->attr.proc_pointer);
1720 var = gfc_create_var (type, "ifm");
1721 gfc_add_modify (block, var, fold_convert (type, data));
1727 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1728 and offset of descriptorless array type TYPE given that it has the same
1729 size as DESC. Add any set-up code to BLOCK. */
1732 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1739 offset = gfc_index_zero_node;
1740 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1742 dim = gfc_rank_cst[n];
1743 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1744 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1746 GFC_TYPE_ARRAY_LBOUND (type, n)
1747 = gfc_conv_descriptor_lbound_get (desc, dim);
1748 GFC_TYPE_ARRAY_UBOUND (type, n)
1749 = gfc_conv_descriptor_ubound_get (desc, dim);
1751 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1753 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1754 gfc_conv_descriptor_ubound_get (desc, dim),
1755 gfc_conv_descriptor_lbound_get (desc, dim));
1756 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1757 GFC_TYPE_ARRAY_LBOUND (type, n),
1759 tmp = gfc_evaluate_now (tmp, block);
1760 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1762 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1763 GFC_TYPE_ARRAY_LBOUND (type, n),
1764 GFC_TYPE_ARRAY_STRIDE (type, n));
1765 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1767 offset = gfc_evaluate_now (offset, block);
1768 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1772 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1773 in SE. The caller may still use se->expr and se->string_length after
1774 calling this function. */
1777 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1778 gfc_symbol * sym, gfc_se * se,
1781 gfc_interface_sym_mapping *sm;
1785 gfc_symbol *new_sym;
1787 gfc_symtree *new_symtree;
1789 /* Create a new symbol to represent the actual argument. */
1790 new_sym = gfc_new_symbol (sym->name, NULL);
1791 new_sym->ts = sym->ts;
1792 new_sym->as = gfc_copy_array_spec (sym->as);
1793 new_sym->attr.referenced = 1;
1794 new_sym->attr.dimension = sym->attr.dimension;
1795 new_sym->attr.contiguous = sym->attr.contiguous;
1796 new_sym->attr.codimension = sym->attr.codimension;
1797 new_sym->attr.pointer = sym->attr.pointer;
1798 new_sym->attr.allocatable = sym->attr.allocatable;
1799 new_sym->attr.flavor = sym->attr.flavor;
1800 new_sym->attr.function = sym->attr.function;
1802 /* Ensure that the interface is available and that
1803 descriptors are passed for array actual arguments. */
1804 if (sym->attr.flavor == FL_PROCEDURE)
1806 new_sym->formal = expr->symtree->n.sym->formal;
1807 new_sym->attr.always_explicit
1808 = expr->symtree->n.sym->attr.always_explicit;
1811 /* Create a fake symtree for it. */
1813 new_symtree = gfc_new_symtree (&root, sym->name);
1814 new_symtree->n.sym = new_sym;
1815 gcc_assert (new_symtree == root);
1817 /* Create a dummy->actual mapping. */
1818 sm = XCNEW (gfc_interface_sym_mapping);
1819 sm->next = mapping->syms;
1821 sm->new_sym = new_symtree;
1822 sm->expr = gfc_copy_expr (expr);
1825 /* Stabilize the argument's value. */
1826 if (!sym->attr.function && se)
1827 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1829 if (sym->ts.type == BT_CHARACTER)
1831 /* Create a copy of the dummy argument's length. */
1832 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1833 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1835 /* If the length is specified as "*", record the length that
1836 the caller is passing. We should use the callee's length
1837 in all other cases. */
1838 if (!new_sym->ts.u.cl->length && se)
1840 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1841 new_sym->ts.u.cl->backend_decl = se->string_length;
1848 /* Use the passed value as-is if the argument is a function. */
1849 if (sym->attr.flavor == FL_PROCEDURE)
1852 /* If the argument is either a string or a pointer to a string,
1853 convert it to a boundless character type. */
1854 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1856 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1857 tmp = build_pointer_type (tmp);
1858 if (sym->attr.pointer)
1859 value = build_fold_indirect_ref_loc (input_location,
1863 value = fold_convert (tmp, value);
1866 /* If the argument is a scalar, a pointer to an array or an allocatable,
1868 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1869 value = build_fold_indirect_ref_loc (input_location,
1872 /* For character(*), use the actual argument's descriptor. */
1873 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1874 value = build_fold_indirect_ref_loc (input_location,
1877 /* If the argument is an array descriptor, use it to determine
1878 information about the actual argument's shape. */
1879 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1880 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1882 /* Get the actual argument's descriptor. */
1883 desc = build_fold_indirect_ref_loc (input_location,
1886 /* Create the replacement variable. */
1887 tmp = gfc_conv_descriptor_data_get (desc);
1888 value = gfc_get_interface_mapping_array (&se->pre, sym,
1891 /* Use DESC to work out the upper bounds, strides and offset. */
1892 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1895 /* Otherwise we have a packed array. */
1896 value = gfc_get_interface_mapping_array (&se->pre, sym,
1897 PACKED_FULL, se->expr);
1899 new_sym->backend_decl = value;
1903 /* Called once all dummy argument mappings have been added to MAPPING,
1904 but before the mapping is used to evaluate expressions. Pre-evaluate
1905 the length of each argument, adding any initialization code to PRE and
1906 any finalization code to POST. */
1909 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1910 stmtblock_t * pre, stmtblock_t * post)
1912 gfc_interface_sym_mapping *sym;
1916 for (sym = mapping->syms; sym; sym = sym->next)
1917 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1918 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1920 expr = sym->new_sym->n.sym->ts.u.cl->length;
1921 gfc_apply_interface_mapping_to_expr (mapping, expr);
1922 gfc_init_se (&se, NULL);
1923 gfc_conv_expr (&se, expr);
1924 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1925 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1926 gfc_add_block_to_block (pre, &se.pre);
1927 gfc_add_block_to_block (post, &se.post);
1929 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1934 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1938 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1939 gfc_constructor_base base)
1942 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1944 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1947 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1948 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1949 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1955 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1959 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1964 for (; ref; ref = ref->next)
1968 for (n = 0; n < ref->u.ar.dimen; n++)
1970 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1971 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1972 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1974 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1981 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1982 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1988 /* Convert intrinsic function calls into result expressions. */
1991 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1999 arg1 = expr->value.function.actual->expr;
2000 if (expr->value.function.actual->next)
2001 arg2 = expr->value.function.actual->next->expr;
2005 sym = arg1->symtree->n.sym;
2007 if (sym->attr.dummy)
2012 switch (expr->value.function.isym->id)
2015 /* TODO figure out why this condition is necessary. */
2016 if (sym->attr.function
2017 && (arg1->ts.u.cl->length == NULL
2018 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2019 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2022 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2026 if (!sym->as || sym->as->rank == 0)
2029 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2031 dup = mpz_get_si (arg2->value.integer);
2036 dup = sym->as->rank;
2040 for (; d < dup; d++)
2044 if (!sym->as->upper[d] || !sym->as->lower[d])
2046 gfc_free_expr (new_expr);
2050 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2051 gfc_get_int_expr (gfc_default_integer_kind,
2053 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2055 new_expr = gfc_multiply (new_expr, tmp);
2061 case GFC_ISYM_LBOUND:
2062 case GFC_ISYM_UBOUND:
2063 /* TODO These implementations of lbound and ubound do not limit if
2064 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2066 if (!sym->as || sym->as->rank == 0)
2069 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2070 d = mpz_get_si (arg2->value.integer) - 1;
2072 /* TODO: If the need arises, this could produce an array of
2076 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2078 if (sym->as->lower[d])
2079 new_expr = gfc_copy_expr (sym->as->lower[d]);
2083 if (sym->as->upper[d])
2084 new_expr = gfc_copy_expr (sym->as->upper[d]);
2092 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2096 gfc_replace_expr (expr, new_expr);
2102 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2103 gfc_interface_mapping * mapping)
2105 gfc_formal_arglist *f;
2106 gfc_actual_arglist *actual;
2108 actual = expr->value.function.actual;
2109 f = map_expr->symtree->n.sym->formal;
2111 for (; f && actual; f = f->next, actual = actual->next)
2116 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2119 if (map_expr->symtree->n.sym->attr.dimension)
2124 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2126 for (d = 0; d < as->rank; d++)
2128 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2129 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2132 expr->value.function.esym->as = as;
2135 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2137 expr->value.function.esym->ts.u.cl->length
2138 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2140 gfc_apply_interface_mapping_to_expr (mapping,
2141 expr->value.function.esym->ts.u.cl->length);
2146 /* EXPR is a copy of an expression that appeared in the interface
2147 associated with MAPPING. Walk it recursively looking for references to
2148 dummy arguments that MAPPING maps to actual arguments. Replace each such
2149 reference with a reference to the associated actual argument. */
2152 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2155 gfc_interface_sym_mapping *sym;
2156 gfc_actual_arglist *actual;
2161 /* Copying an expression does not copy its length, so do that here. */
2162 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2164 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2165 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2168 /* Apply the mapping to any references. */
2169 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2171 /* ...and to the expression's symbol, if it has one. */
2172 /* TODO Find out why the condition on expr->symtree had to be moved into
2173 the loop rather than being outside it, as originally. */
2174 for (sym = mapping->syms; sym; sym = sym->next)
2175 if (expr->symtree && sym->old == expr->symtree->n.sym)
2177 if (sym->new_sym->n.sym->backend_decl)
2178 expr->symtree = sym->new_sym;
2180 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2183 /* ...and to subexpressions in expr->value. */
2184 switch (expr->expr_type)
2189 case EXPR_SUBSTRING:
2193 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2194 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2198 for (actual = expr->value.function.actual; actual; actual = actual->next)
2199 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2201 if (expr->value.function.esym == NULL
2202 && expr->value.function.isym != NULL
2203 && expr->value.function.actual->expr->symtree
2204 && gfc_map_intrinsic_function (expr, mapping))
2207 for (sym = mapping->syms; sym; sym = sym->next)
2208 if (sym->old == expr->value.function.esym)
2210 expr->value.function.esym = sym->new_sym->n.sym;
2211 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2212 expr->value.function.esym->result = sym->new_sym->n.sym;
2217 case EXPR_STRUCTURE:
2218 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2231 /* Evaluate interface expression EXPR using MAPPING. Store the result
2235 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2236 gfc_se * se, gfc_expr * expr)
2238 expr = gfc_copy_expr (expr);
2239 gfc_apply_interface_mapping_to_expr (mapping, expr);
2240 gfc_conv_expr (se, expr);
2241 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2242 gfc_free_expr (expr);
2246 /* Returns a reference to a temporary array into which a component of
2247 an actual argument derived type array is copied and then returned
2248 after the function call. */
2250 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2251 sym_intent intent, bool formal_ptr)
2269 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2271 gfc_init_se (&lse, NULL);
2272 gfc_init_se (&rse, NULL);
2274 /* Walk the argument expression. */
2275 rss = gfc_walk_expr (expr);
2277 gcc_assert (rss != gfc_ss_terminator);
2279 /* Initialize the scalarizer. */
2280 gfc_init_loopinfo (&loop);
2281 gfc_add_ss_to_loop (&loop, rss);
2283 /* Calculate the bounds of the scalarization. */
2284 gfc_conv_ss_startstride (&loop);
2286 /* Build an ss for the temporary. */
2287 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2288 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2290 base_type = gfc_typenode_for_spec (&expr->ts);
2291 if (GFC_ARRAY_TYPE_P (base_type)
2292 || GFC_DESCRIPTOR_TYPE_P (base_type))
2293 base_type = gfc_get_element_type (base_type);
2295 loop.temp_ss = gfc_get_ss ();;
2296 loop.temp_ss->type = GFC_SS_TEMP;
2297 loop.temp_ss->data.temp.type = base_type;
2299 if (expr->ts.type == BT_CHARACTER)
2300 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2302 loop.temp_ss->string_length = NULL;
2304 parmse->string_length = loop.temp_ss->string_length;
2305 loop.temp_ss->data.temp.dimen = loop.dimen;
2306 loop.temp_ss->next = gfc_ss_terminator;
2308 /* Associate the SS with the loop. */
2309 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2311 /* Setup the scalarizing loops. */
2312 gfc_conv_loop_setup (&loop, &expr->where);
2314 /* Pass the temporary descriptor back to the caller. */
2315 info = &loop.temp_ss->data.info;
2316 parmse->expr = info->descriptor;
2318 /* Setup the gfc_se structures. */
2319 gfc_copy_loopinfo_to_se (&lse, &loop);
2320 gfc_copy_loopinfo_to_se (&rse, &loop);
2323 lse.ss = loop.temp_ss;
2324 gfc_mark_ss_chain_used (rss, 1);
2325 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2327 /* Start the scalarized loop body. */
2328 gfc_start_scalarized_body (&loop, &body);
2330 /* Translate the expression. */
2331 gfc_conv_expr (&rse, expr);
2333 gfc_conv_tmp_array_ref (&lse);
2334 gfc_advance_se_ss_chain (&lse);
2336 if (intent != INTENT_OUT)
2338 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2339 gfc_add_expr_to_block (&body, tmp);
2340 gcc_assert (rse.ss == gfc_ss_terminator);
2341 gfc_trans_scalarizing_loops (&loop, &body);
2345 /* Make sure that the temporary declaration survives by merging
2346 all the loop declarations into the current context. */
2347 for (n = 0; n < loop.dimen; n++)
2349 gfc_merge_block_scope (&body);
2350 body = loop.code[loop.order[n]];
2352 gfc_merge_block_scope (&body);
2355 /* Add the post block after the second loop, so that any
2356 freeing of allocated memory is done at the right time. */
2357 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2359 /**********Copy the temporary back again.*********/
2361 gfc_init_se (&lse, NULL);
2362 gfc_init_se (&rse, NULL);
2364 /* Walk the argument expression. */
2365 lss = gfc_walk_expr (expr);
2366 rse.ss = loop.temp_ss;
2369 /* Initialize the scalarizer. */
2370 gfc_init_loopinfo (&loop2);
2371 gfc_add_ss_to_loop (&loop2, lss);
2373 /* Calculate the bounds of the scalarization. */
2374 gfc_conv_ss_startstride (&loop2);
2376 /* Setup the scalarizing loops. */
2377 gfc_conv_loop_setup (&loop2, &expr->where);
2379 gfc_copy_loopinfo_to_se (&lse, &loop2);
2380 gfc_copy_loopinfo_to_se (&rse, &loop2);
2382 gfc_mark_ss_chain_used (lss, 1);
2383 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2385 /* Declare the variable to hold the temporary offset and start the
2386 scalarized loop body. */
2387 offset = gfc_create_var (gfc_array_index_type, NULL);
2388 gfc_start_scalarized_body (&loop2, &body);
2390 /* Build the offsets for the temporary from the loop variables. The
2391 temporary array has lbounds of zero and strides of one in all
2392 dimensions, so this is very simple. The offset is only computed
2393 outside the innermost loop, so the overall transfer could be
2394 optimized further. */
2395 info = &rse.ss->data.info;
2396 dimen = info->dimen;
2398 tmp_index = gfc_index_zero_node;
2399 for (n = dimen - 1; n > 0; n--)
2402 tmp = rse.loop->loopvar[n];
2403 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2404 tmp, rse.loop->from[n]);
2405 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2408 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2409 rse.loop->to[n-1], rse.loop->from[n-1]);
2410 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2411 tmp_str, gfc_index_one_node);
2413 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2417 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2418 tmp_index, rse.loop->from[0]);
2419 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2421 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2422 rse.loop->loopvar[0], offset);
2424 /* Now use the offset for the reference. */
2425 tmp = build_fold_indirect_ref_loc (input_location,
2427 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2429 if (expr->ts.type == BT_CHARACTER)
2430 rse.string_length = expr->ts.u.cl->backend_decl;
2432 gfc_conv_expr (&lse, expr);
2434 gcc_assert (lse.ss == gfc_ss_terminator);
2436 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2437 gfc_add_expr_to_block (&body, tmp);
2439 /* Generate the copying loops. */
2440 gfc_trans_scalarizing_loops (&loop2, &body);
2442 /* Wrap the whole thing up by adding the second loop to the post-block
2443 and following it by the post-block of the first loop. In this way,
2444 if the temporary needs freeing, it is done after use! */
2445 if (intent != INTENT_IN)
2447 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2448 gfc_add_block_to_block (&parmse->post, &loop2.post);
2451 gfc_add_block_to_block (&parmse->post, &loop.post);
2453 gfc_cleanup_loop (&loop);
2454 gfc_cleanup_loop (&loop2);
2456 /* Pass the string length to the argument expression. */
2457 if (expr->ts.type == BT_CHARACTER)
2458 parmse->string_length = expr->ts.u.cl->backend_decl;
2460 /* Determine the offset for pointer formal arguments and set the
2464 size = gfc_index_one_node;
2465 offset = gfc_index_zero_node;
2466 for (n = 0; n < dimen; n++)
2468 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2470 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2471 tmp, gfc_index_one_node);
2472 gfc_conv_descriptor_ubound_set (&parmse->pre,
2476 gfc_conv_descriptor_lbound_set (&parmse->pre,
2479 gfc_index_one_node);
2480 size = gfc_evaluate_now (size, &parmse->pre);
2481 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2483 offset = gfc_evaluate_now (offset, &parmse->pre);
2484 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2485 rse.loop->to[n], rse.loop->from[n]);
2486 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2487 tmp, gfc_index_one_node);
2488 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2492 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2496 /* We want either the address for the data or the address of the descriptor,
2497 depending on the mode of passing array arguments. */
2499 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2501 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2507 /* Generate the code for argument list functions. */
2510 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2512 /* Pass by value for g77 %VAL(arg), pass the address
2513 indirectly for %LOC, else by reference. Thus %REF
2514 is a "do-nothing" and %LOC is the same as an F95
2516 if (strncmp (name, "%VAL", 4) == 0)
2517 gfc_conv_expr (se, expr);
2518 else if (strncmp (name, "%LOC", 4) == 0)
2520 gfc_conv_expr_reference (se, expr);
2521 se->expr = gfc_build_addr_expr (NULL, se->expr);
2523 else if (strncmp (name, "%REF", 4) == 0)
2524 gfc_conv_expr_reference (se, expr);
2526 gfc_error ("Unknown argument list function at %L", &expr->where);
2530 /* Takes a derived type expression and returns the address of a temporary
2531 class object of the 'declared' type. */
2533 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2534 gfc_typespec class_ts)
2538 gfc_symbol *declared = class_ts.u.derived;
2544 /* The derived type needs to be converted to a temporary
2546 tmp = gfc_typenode_for_spec (&class_ts);
2547 var = gfc_create_var (tmp, "class");
2550 cmp = gfc_find_component (declared, "$vptr", true, true);
2551 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2552 var, cmp->backend_decl, NULL_TREE);
2554 /* Remember the vtab corresponds to the derived type
2555 not to the class declared type. */
2556 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2558 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2559 gfc_add_modify (&parmse->pre, ctree,
2560 fold_convert (TREE_TYPE (ctree), tmp));
2562 /* Now set the data field. */
2563 cmp = gfc_find_component (declared, "$data", true, true);
2564 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2565 var, cmp->backend_decl, NULL_TREE);
2566 ss = gfc_walk_expr (e);
2567 if (ss == gfc_ss_terminator)
2570 gfc_conv_expr_reference (parmse, e);
2571 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2572 gfc_add_modify (&parmse->pre, ctree, tmp);
2577 gfc_conv_expr (parmse, e);
2578 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2581 /* Pass the address of the class object. */
2582 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2586 /* The following routine generates code for the intrinsic
2587 procedures from the ISO_C_BINDING module:
2589 * C_FUNLOC (function)
2590 * C_F_POINTER (subroutine)
2591 * C_F_PROCPOINTER (subroutine)
2592 * C_ASSOCIATED (function)
2593 One exception which is not handled here is C_F_POINTER with non-scalar
2594 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2597 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2598 gfc_actual_arglist * arg)
2603 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2605 if (arg->expr->rank == 0)
2606 gfc_conv_expr_reference (se, arg->expr);
2610 /* This is really the actual arg because no formal arglist is
2611 created for C_LOC. */
2612 fsym = arg->expr->symtree->n.sym;
2614 /* We should want it to do g77 calling convention. */
2616 && !(fsym->attr.pointer || fsym->attr.allocatable)
2617 && fsym->as->type != AS_ASSUMED_SHAPE;
2618 f = f || !sym->attr.always_explicit;
2620 argss = gfc_walk_expr (arg->expr);
2621 gfc_conv_array_parameter (se, arg->expr, argss, f,
2625 /* TODO -- the following two lines shouldn't be necessary, but if
2626 they're removed, a bug is exposed later in the code path.
2627 This workaround was thus introduced, but will have to be
2628 removed; please see PR 35150 for details about the issue. */
2629 se->expr = convert (pvoid_type_node, se->expr);
2630 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2634 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2636 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2637 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2638 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2639 gfc_conv_expr_reference (se, arg->expr);
2643 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2644 && arg->next->expr->rank == 0)
2645 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2647 /* Convert c_f_pointer if fptr is a scalar
2648 and convert c_f_procpointer. */
2652 gfc_init_se (&cptrse, NULL);
2653 gfc_conv_expr (&cptrse, arg->expr);
2654 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2655 gfc_add_block_to_block (&se->post, &cptrse.post);
2657 gfc_init_se (&fptrse, NULL);
2658 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2659 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2660 fptrse.want_pointer = 1;
2662 gfc_conv_expr (&fptrse, arg->next->expr);
2663 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2664 gfc_add_block_to_block (&se->post, &fptrse.post);
2666 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2667 && arg->next->expr->symtree->n.sym->attr.dummy)
2668 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2671 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2673 fold_convert (TREE_TYPE (fptrse.expr),
2678 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2683 /* Build the addr_expr for the first argument. The argument is
2684 already an *address* so we don't need to set want_pointer in
2686 gfc_init_se (&arg1se, NULL);
2687 gfc_conv_expr (&arg1se, arg->expr);
2688 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2689 gfc_add_block_to_block (&se->post, &arg1se.post);
2691 /* See if we were given two arguments. */
2692 if (arg->next == NULL)
2693 /* Only given one arg so generate a null and do a
2694 not-equal comparison against the first arg. */
2695 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2696 fold_convert (TREE_TYPE (arg1se.expr),
2697 null_pointer_node));
2703 /* Given two arguments so build the arg2se from second arg. */
2704 gfc_init_se (&arg2se, NULL);
2705 gfc_conv_expr (&arg2se, arg->next->expr);
2706 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2707 gfc_add_block_to_block (&se->post, &arg2se.post);
2709 /* Generate test to compare that the two args are equal. */
2710 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2711 arg1se.expr, arg2se.expr);
2712 /* Generate test to ensure that the first arg is not null. */
2713 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2714 arg1se.expr, null_pointer_node);
2716 /* Finally, the generated test must check that both arg1 is not
2717 NULL and that it is equal to the second arg. */
2718 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2719 not_null_expr, eq_expr);
2725 /* Nothing was done. */
2729 /* Generate code for a procedure call. Note can return se->post != NULL.
2730 If se->direct_byref is set then se->expr contains the return parameter.
2731 Return nonzero, if the call has alternate specifiers.
2732 'expr' is only needed for procedure pointer components. */
2735 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2736 gfc_actual_arglist * arg, gfc_expr * expr,
2737 VEC(tree,gc) *append_args)
2739 gfc_interface_mapping mapping;
2740 VEC(tree,gc) *arglist;
2741 VEC(tree,gc) *retargs;
2752 VEC(tree,gc) *stringargs;
2754 gfc_formal_arglist *formal;
2755 int has_alternate_specifier = 0;
2756 bool need_interface_mapping;
2763 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2764 gfc_component *comp = NULL;
2774 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2775 && conv_isocbinding_procedure (se, sym, arg))
2778 gfc_is_proc_ptr_comp (expr, &comp);
2782 if (!sym->attr.elemental)
2784 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2785 if (se->ss->useflags)
2787 gcc_assert ((!comp && gfc_return_by_reference (sym)
2788 && sym->result->attr.dimension)
2789 || (comp && comp->attr.dimension));
2790 gcc_assert (se->loop != NULL);
2792 /* Access the previously obtained result. */
2793 gfc_conv_tmp_array_ref (se);
2794 gfc_advance_se_ss_chain (se);
2798 info = &se->ss->data.info;
2803 gfc_init_block (&post);
2804 gfc_init_interface_mapping (&mapping);
2807 formal = sym->formal;
2808 need_interface_mapping = sym->attr.dimension ||
2809 (sym->ts.type == BT_CHARACTER
2810 && sym->ts.u.cl->length
2811 && sym->ts.u.cl->length->expr_type
2816 formal = comp->formal;
2817 need_interface_mapping = comp->attr.dimension ||
2818 (comp->ts.type == BT_CHARACTER
2819 && comp->ts.u.cl->length
2820 && comp->ts.u.cl->length->expr_type
2824 /* Evaluate the arguments. */
2825 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2828 fsym = formal ? formal->sym : NULL;
2829 parm_kind = MISSING;
2833 if (se->ignore_optional)
2835 /* Some intrinsics have already been resolved to the correct
2839 else if (arg->label)
2841 has_alternate_specifier = 1;
2846 /* Pass a NULL pointer for an absent arg. */
2847 gfc_init_se (&parmse, NULL);
2848 parmse.expr = null_pointer_node;
2849 if (arg->missing_arg_type == BT_CHARACTER)
2850 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2853 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2855 /* Pass a NULL pointer to denote an absent arg. */
2856 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2857 gfc_init_se (&parmse, NULL);
2858 parmse.expr = null_pointer_node;
2859 if (arg->missing_arg_type == BT_CHARACTER)
2860 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2862 else if (fsym && fsym->ts.type == BT_CLASS
2863 && e->ts.type == BT_DERIVED)
2865 /* The derived type needs to be converted to a temporary
2867 gfc_init_se (&parmse, se);
2868 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2870 else if (se->ss && se->ss->useflags)
2872 /* An elemental function inside a scalarized loop. */
2873 gfc_init_se (&parmse, se);
2874 gfc_conv_expr_reference (&parmse, e);
2875 parm_kind = ELEMENTAL;
2879 /* A scalar or transformational function. */
2880 gfc_init_se (&parmse, NULL);
2881 argss = gfc_walk_expr (e);
2883 if (argss == gfc_ss_terminator)
2885 if (e->expr_type == EXPR_VARIABLE
2886 && e->symtree->n.sym->attr.cray_pointee
2887 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2889 /* The Cray pointer needs to be converted to a pointer to
2890 a type given by the expression. */
2891 gfc_conv_expr (&parmse, e);
2892 type = build_pointer_type (TREE_TYPE (parmse.expr));
2893 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2894 parmse.expr = convert (type, tmp);
2896 else if (fsym && fsym->attr.value)
2898 if (fsym->ts.type == BT_CHARACTER
2899 && fsym->ts.is_c_interop
2900 && fsym->ns->proc_name != NULL
2901 && fsym->ns->proc_name->attr.is_bind_c)
2904 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2905 if (parmse.expr == NULL)
2906 gfc_conv_expr (&parmse, e);
2909 gfc_conv_expr (&parmse, e);
2911 else if (arg->name && arg->name[0] == '%')
2912 /* Argument list functions %VAL, %LOC and %REF are signalled
2913 through arg->name. */
2914 conv_arglist_function (&parmse, arg->expr, arg->name);
2915 else if ((e->expr_type == EXPR_FUNCTION)
2916 && ((e->value.function.esym
2917 && e->value.function.esym->result->attr.pointer)
2918 || (!e->value.function.esym
2919 && e->symtree->n.sym->attr.pointer))
2920 && fsym && fsym->attr.target)
2922 gfc_conv_expr (&parmse, e);
2923 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2925 else if (e->expr_type == EXPR_FUNCTION
2926 && e->symtree->n.sym->result
2927 && e->symtree->n.sym->result != e->symtree->n.sym
2928 && e->symtree->n.sym->result->attr.proc_pointer)
2930 /* Functions returning procedure pointers. */
2931 gfc_conv_expr (&parmse, e);
2932 if (fsym && fsym->attr.proc_pointer)
2933 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2937 gfc_conv_expr_reference (&parmse, e);
2939 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2940 allocated on entry, it must be deallocated. */
2941 if (fsym && fsym->attr.allocatable
2942 && fsym->attr.intent == INTENT_OUT)
2946 gfc_init_block (&block);
2947 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2949 gfc_add_expr_to_block (&block, tmp);
2950 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2951 parmse.expr, null_pointer_node);
2952 gfc_add_expr_to_block (&block, tmp);
2954 if (fsym->attr.optional
2955 && e->expr_type == EXPR_VARIABLE
2956 && e->symtree->n.sym->attr.optional)
2958 tmp = fold_build3 (COND_EXPR, void_type_node,
2959 gfc_conv_expr_present (e->symtree->n.sym),
2960 gfc_finish_block (&block),
2961 build_empty_stmt (input_location));
2964 tmp = gfc_finish_block (&block);
2966 gfc_add_expr_to_block (&se->pre, tmp);
2969 if (fsym && e->expr_type != EXPR_NULL
2970 && ((fsym->attr.pointer
2971 && fsym->attr.flavor != FL_PROCEDURE)
2972 || (fsym->attr.proc_pointer
2973 && !(e->expr_type == EXPR_VARIABLE
2974 && e->symtree->n.sym->attr.dummy))
2975 || (e->expr_type == EXPR_VARIABLE
2976 && gfc_is_proc_ptr_comp (e, NULL))
2977 || fsym->attr.allocatable))
2979 /* Scalar pointer dummy args require an extra level of
2980 indirection. The null pointer already contains
2981 this level of indirection. */
2982 parm_kind = SCALAR_POINTER;
2983 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2989 /* If the procedure requires an explicit interface, the actual
2990 argument is passed according to the corresponding formal
2991 argument. If the corresponding formal argument is a POINTER,
2992 ALLOCATABLE or assumed shape, we do not use g77's calling
2993 convention, and pass the address of the array descriptor
2994 instead. Otherwise we use g77's calling convention. */
2997 && !(fsym->attr.pointer || fsym->attr.allocatable)
2998 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3000 f = f || !comp->attr.always_explicit;
3002 f = f || !sym->attr.always_explicit;
3004 if (e->expr_type == EXPR_VARIABLE
3005 && is_subref_array (e))
3006 /* The actual argument is a component reference to an
3007 array of derived types. In this case, the argument
3008 is converted to a temporary, which is passed and then
3009 written back after the procedure call. */
3010 gfc_conv_subref_array_arg (&parmse, e, f,
3011 fsym ? fsym->attr.intent : INTENT_INOUT,
3012 fsym && fsym->attr.pointer);
3014 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3017 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3018 allocated on entry, it must be deallocated. */
3019 if (fsym && fsym->attr.allocatable
3020 && fsym->attr.intent == INTENT_OUT)
3022 tmp = build_fold_indirect_ref_loc (input_location,
3024 tmp = gfc_trans_dealloc_allocated (tmp);
3025 if (fsym->attr.optional
3026 && e->expr_type == EXPR_VARIABLE
3027 && e->symtree->n.sym->attr.optional)
3028 tmp = fold_build3 (COND_EXPR, void_type_node,
3029 gfc_conv_expr_present (e->symtree->n.sym),
3030 tmp, build_empty_stmt (input_location));
3031 gfc_add_expr_to_block (&se->pre, tmp);
3036 /* The case with fsym->attr.optional is that of a user subroutine
3037 with an interface indicating an optional argument. When we call
3038 an intrinsic subroutine, however, fsym is NULL, but we might still
3039 have an optional argument, so we proceed to the substitution
3041 if (e && (fsym == NULL || fsym->attr.optional))
3043 /* If an optional argument is itself an optional dummy argument,
3044 check its presence and substitute a null if absent. This is
3045 only needed when passing an array to an elemental procedure
3046 as then array elements are accessed - or no NULL pointer is
3047 allowed and a "1" or "0" should be passed if not present.
3048 When passing a non-array-descriptor full array to a
3049 non-array-descriptor dummy, no check is needed. For
3050 array-descriptor actual to array-descriptor dummy, see
3051 PR 41911 for why a check has to be inserted.
3052 fsym == NULL is checked as intrinsics required the descriptor
3053 but do not always set fsym. */
3054 if (e->expr_type == EXPR_VARIABLE
3055 && e->symtree->n.sym->attr.optional
3056 && ((e->rank > 0 && sym->attr.elemental)
3057 || e->representation.length || e->ts.type == BT_CHARACTER
3059 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3060 || fsym->as->type == AS_DEFERRED))))
3061 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3062 e->representation.length);
3067 /* Obtain the character length of an assumed character length
3068 length procedure from the typespec. */
3069 if (fsym->ts.type == BT_CHARACTER
3070 && parmse.string_length == NULL_TREE
3071 && e->ts.type == BT_PROCEDURE
3072 && e->symtree->n.sym->ts.type == BT_CHARACTER
3073 && e->symtree->n.sym->ts.u.cl->length != NULL
3074 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3076 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3077 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3081 if (fsym && need_interface_mapping && e)
3082 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3084 gfc_add_block_to_block (&se->pre, &parmse.pre);
3085 gfc_add_block_to_block (&post, &parmse.post);
3087 /* Allocated allocatable components of derived types must be
3088 deallocated for non-variable scalars. Non-variable arrays are
3089 dealt with in trans-array.c(gfc_conv_array_parameter). */
3090 if (e && e->ts.type == BT_DERIVED
3091 && e->ts.u.derived->attr.alloc_comp
3092 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3093 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3096 tmp = build_fold_indirect_ref_loc (input_location,
3098 parm_rank = e->rank;
3106 case (SCALAR_POINTER):
3107 tmp = build_fold_indirect_ref_loc (input_location,
3112 if (e->expr_type == EXPR_OP
3113 && e->value.op.op == INTRINSIC_PARENTHESES
3114 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3117 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3118 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3119 gfc_add_expr_to_block (&se->post, local_tmp);
3122 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3124 gfc_add_expr_to_block (&se->post, tmp);
3127 /* Add argument checking of passing an unallocated/NULL actual to
3128 a nonallocatable/nonpointer dummy. */
3130 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3132 symbol_attribute *attr;
3136 if (e->expr_type == EXPR_VARIABLE)
3137 attr = &e->symtree->n.sym->attr;
3138 else if (e->expr_type == EXPR_FUNCTION)
3140 /* For intrinsic functions, the gfc_attr are not available. */
3141 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3142 goto end_pointer_check;
3144 if (e->symtree->n.sym->attr.generic)
3145 attr = &e->value.function.esym->attr;
3147 attr = &e->symtree->n.sym->result->attr;
3150 goto end_pointer_check;
3154 /* If the actual argument is an optional pointer/allocatable and
3155 the formal argument takes an nonpointer optional value,
3156 it is invalid to pass a non-present argument on, even
3157 though there is no technical reason for this in gfortran.
3158 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3159 tree present, null_ptr, type;
3161 if (attr->allocatable
3162 && (fsym == NULL || !fsym->attr.allocatable))
3163 asprintf (&msg, "Allocatable actual argument '%s' is not "
3164 "allocated or not present", e->symtree->n.sym->name);
3165 else if (attr->pointer
3166 && (fsym == NULL || !fsym->attr.pointer))
3167 asprintf (&msg, "Pointer actual argument '%s' is not "
3168 "associated or not present",
3169 e->symtree->n.sym->name);
3170 else if (attr->proc_pointer
3171 && (fsym == NULL || !fsym->attr.proc_pointer))
3172 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3173 "associated or not present",
3174 e->symtree->n.sym->name);
3176 goto end_pointer_check;
3178 present = gfc_conv_expr_present (e->symtree->n.sym);
3179 type = TREE_TYPE (present);
3180 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3181 fold_convert (type, null_pointer_node));
3182 type = TREE_TYPE (parmse.expr);
3183 null_ptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3184 fold_convert (type, null_pointer_node));
3185 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3190 if (attr->allocatable
3191 && (fsym == NULL || !fsym->attr.allocatable))
3192 asprintf (&msg, "Allocatable actual argument '%s' is not "
3193 "allocated", e->symtree->n.sym->name);
3194 else if (attr->pointer
3195 && (fsym == NULL || !fsym->attr.pointer))
3196 asprintf (&msg, "Pointer actual argument '%s' is not "
3197 "associated", e->symtree->n.sym->name);
3198 else if (attr->proc_pointer
3199 && (fsym == NULL || !fsym->attr.proc_pointer))
3200 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3201 "associated", e->symtree->n.sym->name);
3203 goto end_pointer_check;
3206 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3207 fold_convert (TREE_TYPE (parmse.expr),
3208 null_pointer_node));
3211 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3218 /* Character strings are passed as two parameters, a length and a
3219 pointer - except for Bind(c) which only passes the pointer. */
3220 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3221 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3223 VEC_safe_push (tree, gc, arglist, parmse.expr);
3225 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3232 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3233 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3234 else if (ts.type == BT_CHARACTER)
3236 if (ts.u.cl->length == NULL)
3238 /* Assumed character length results are not allowed by 5.1.1.5 of the
3239 standard and are trapped in resolve.c; except in the case of SPREAD
3240 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3241 we take the character length of the first argument for the result.
3242 For dummies, we have to look through the formal argument list for
3243 this function and use the character length found there.*/
3244 if (!sym->attr.dummy)
3245 cl.backend_decl = VEC_index (tree, stringargs, 0);
3248 formal = sym->ns->proc_name->formal;
3249 for (; formal; formal = formal->next)
3250 if (strcmp (formal->sym->name, sym->name) == 0)
3251 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3258 /* Calculate the length of the returned string. */
3259 gfc_init_se (&parmse, NULL);
3260 if (need_interface_mapping)
3261 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3263 gfc_conv_expr (&parmse, ts.u.cl->length);
3264 gfc_add_block_to_block (&se->pre, &parmse.pre);
3265 gfc_add_block_to_block (&se->post, &parmse.post);
3267 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3268 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3269 build_int_cst (gfc_charlen_type_node, 0));
3270 cl.backend_decl = tmp;
3273 /* Set up a charlen structure for it. */
3278 len = cl.backend_decl;
3281 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3282 || (!comp && gfc_return_by_reference (sym));
3285 if (se->direct_byref)
3287 /* Sometimes, too much indirection can be applied; e.g. for
3288 function_result = array_valued_recursive_function. */
3289 if (TREE_TYPE (TREE_TYPE (se->expr))
3290 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3291 && GFC_DESCRIPTOR_TYPE_P
3292 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3293 se->expr = build_fold_indirect_ref_loc (input_location,
3296 result = build_fold_indirect_ref_loc (input_location,
3298 VEC_safe_push (tree, gc, retargs, se->expr);
3300 else if (comp && comp->attr.dimension)
3302 gcc_assert (se->loop && info);
3304 /* Set the type of the array. */
3305 tmp = gfc_typenode_for_spec (&comp->ts);
3306 info->dimen = se->loop->dimen;
3308 /* Evaluate the bounds of the result, if known. */
3309 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3311 /* Create a temporary to store the result. In case the function
3312 returns a pointer, the temporary will be a shallow copy and
3313 mustn't be deallocated. */
3314 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3315 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3316 NULL_TREE, false, !comp->attr.pointer,
3317 callee_alloc, &se->ss->expr->where);
3319 /* Pass the temporary as the first argument. */
3320 result = info->descriptor;
3321 tmp = gfc_build_addr_expr (NULL_TREE, result);
3322 VEC_safe_push (tree, gc, retargs, tmp);
3324 else if (!comp && sym->result->attr.dimension)
3326 gcc_assert (se->loop && info);
3328 /* Set the type of the array. */
3329 tmp = gfc_typenode_for_spec (&ts);
3330 info->dimen = se->loop->dimen;
3332 /* Evaluate the bounds of the result, if known. */
3333 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3335 /* Create a temporary to store the result. In case the function
3336 returns a pointer, the temporary will be a shallow copy and
3337 mustn't be deallocated. */
3338 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3339 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3340 NULL_TREE, false, !sym->attr.pointer,
3341 callee_alloc, &se->ss->expr->where);
3343 /* Pass the temporary as the first argument. */
3344 result = info->descriptor;
3345 tmp = gfc_build_addr_expr (NULL_TREE, result);
3346 VEC_safe_push (tree, gc, retargs, tmp);
3348 else if (ts.type == BT_CHARACTER)
3350 /* Pass the string length. */
3351 type = gfc_get_character_type (ts.kind, ts.u.cl);
3352 type = build_pointer_type (type);
3354 /* Return an address to a char[0:len-1]* temporary for
3355 character pointers. */
3356 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3357 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3359 var = gfc_create_var (type, "pstr");
3361 if ((!comp && sym->attr.allocatable)
3362 || (comp && comp->attr.allocatable))
3363 gfc_add_modify (&se->pre, var,
3364 fold_convert (TREE_TYPE (var),
3365 null_pointer_node));
3367 /* Provide an address expression for the function arguments. */
3368 var = gfc_build_addr_expr (NULL_TREE, var);
3371 var = gfc_conv_string_tmp (se, type, len);
3373 VEC_safe_push (tree, gc, retargs, var);
3377 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3379 type = gfc_get_complex_type (ts.kind);
3380 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3381 VEC_safe_push (tree, gc, retargs, var);
3384 /* Add the string length to the argument list. */
3385 if (ts.type == BT_CHARACTER)
3386 VEC_safe_push (tree, gc, retargs, len);
3388 gfc_free_interface_mapping (&mapping);
3390 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3391 arglen = (VEC_length (tree, arglist)
3392 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3393 VEC_reserve_exact (tree, gc, retargs, arglen);
3395 /* Add the return arguments. */
3396 VEC_splice (tree, retargs, arglist);
3398 /* Add the hidden string length parameters to the arguments. */
3399 VEC_splice (tree, retargs, stringargs);
3401 /* We may want to append extra arguments here. This is used e.g. for
3402 calls to libgfortran_matmul_??, which need extra information. */
3403 if (!VEC_empty (tree, append_args))
3404 VEC_splice (tree, retargs, append_args);
3407 /* Generate the actual call. */
3408 conv_function_val (se, sym, expr);
3410 /* If there are alternate return labels, function type should be
3411 integer. Can't modify the type in place though, since it can be shared
3412 with other functions. For dummy arguments, the typing is done to
3413 to this result, even if it has to be repeated for each call. */
3414 if (has_alternate_specifier
3415 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3417 if (!sym->attr.dummy)
3419 TREE_TYPE (sym->backend_decl)
3420 = build_function_type (integer_type_node,
3421 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3422 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3425 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3428 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3429 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3431 /* If we have a pointer function, but we don't want a pointer, e.g.
3434 where f is pointer valued, we have to dereference the result. */
3435 if (!se->want_pointer && !byref
3436 && (sym->attr.pointer || sym->attr.allocatable)
3437 && !gfc_is_proc_ptr_comp (expr, NULL))
3438 se->expr = build_fold_indirect_ref_loc (input_location,
3441 /* f2c calling conventions require a scalar default real function to
3442 return a double precision result. Convert this back to default
3443 real. We only care about the cases that can happen in Fortran 77.
3445 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3446 && sym->ts.kind == gfc_default_real_kind
3447 && !sym->attr.always_explicit)
3448 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3450 /* A pure function may still have side-effects - it may modify its
3452 TREE_SIDE_EFFECTS (se->expr) = 1;
3454 if (!sym->attr.pure)
3455 TREE_SIDE_EFFECTS (se->expr) = 1;
3460 /* Add the function call to the pre chain. There is no expression. */
3461 gfc_add_expr_to_block (&se->pre, se->expr);
3462 se->expr = NULL_TREE;
3464 if (!se->direct_byref)
3466 if (sym->attr.dimension || (comp && comp->attr.dimension))
3468 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3470 /* Check the data pointer hasn't been modified. This would
3471 happen in a function returning a pointer. */
3472 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3473 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3475 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3478 se->expr = info->descriptor;
3479 /* Bundle in the string length. */
3480 se->string_length = len;
3482 else if (ts.type == BT_CHARACTER)
3484 /* Dereference for character pointer results. */
3485 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3486 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3487 se->expr = build_fold_indirect_ref_loc (input_location, var);
3491 se->string_length = len;
3495 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3496 se->expr = build_fold_indirect_ref_loc (input_location, var);
3501 /* Follow the function call with the argument post block. */
3504 gfc_add_block_to_block (&se->pre, &post);
3506 /* Transformational functions of derived types with allocatable
3507 components must have the result allocatable components copied. */
3508 arg = expr->value.function.actual;
3509 if (result && arg && expr->rank
3510 && expr->value.function.isym
3511 && expr->value.function.isym->transformational
3512 && arg->expr->ts.type == BT_DERIVED
3513 && arg->expr->ts.u.derived->attr.alloc_comp)
3516 /* Copy the allocatable components. We have to use a
3517 temporary here to prevent source allocatable components
3518 from being corrupted. */
3519 tmp2 = gfc_evaluate_now (result, &se->pre);
3520 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3521 result, tmp2, expr->rank);
3522 gfc_add_expr_to_block (&se->pre, tmp);
3523 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3525 gfc_add_expr_to_block (&se->pre, tmp);
3527 /* Finally free the temporary's data field. */
3528 tmp = gfc_conv_descriptor_data_get (tmp2);
3529 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3530 gfc_add_expr_to_block (&se->pre, tmp);
3534 gfc_add_block_to_block (&se->post, &post);
3536 return has_alternate_specifier;
3540 /* Fill a character string with spaces. */
3543 fill_with_spaces (tree start, tree type, tree size)
3545 stmtblock_t block, loop;
3546 tree i, el, exit_label, cond, tmp;
3548 /* For a simple char type, we can call memset(). */
3549 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3550 return build_call_expr_loc (input_location,
3551 built_in_decls[BUILT_IN_MEMSET], 3, start,
3552 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3553 lang_hooks.to_target_charset (' ')),
3556 /* Otherwise, we use a loop:
3557 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3561 /* Initialize variables. */
3562 gfc_init_block (&block);
3563 i = gfc_create_var (sizetype, "i");
3564 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3565 el = gfc_create_var (build_pointer_type (type), "el");
3566 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3567 exit_label = gfc_build_label_decl (NULL_TREE);
3568 TREE_USED (exit_label) = 1;
3572 gfc_init_block (&loop);
3574 /* Exit condition. */
3575 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3576 fold_convert (sizetype, integer_zero_node));
3577 tmp = build1_v (GOTO_EXPR, exit_label);
3578 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3579 build_empty_stmt (input_location));
3580 gfc_add_expr_to_block (&loop, tmp);
3583 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3584 build_int_cst (type,
3585 lang_hooks.to_target_charset (' ')));
3587 /* Increment loop variables. */
3588 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3589 TYPE_SIZE_UNIT (type)));
3590 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3592 TYPE_SIZE_UNIT (type)));
3594 /* Making the loop... actually loop! */
3595 tmp = gfc_finish_block (&loop);
3596 tmp = build1_v (LOOP_EXPR, tmp);
3597 gfc_add_expr_to_block (&block, tmp);
3599 /* The exit label. */
3600 tmp = build1_v (LABEL_EXPR, exit_label);
3601 gfc_add_expr_to_block (&block, tmp);
3604 return gfc_finish_block (&block);
3608 /* Generate code to copy a string. */
3611 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3612 int dkind, tree slength, tree src, int skind)
3614 tree tmp, dlen, slen;
3623 stmtblock_t tempblock;
3625 gcc_assert (dkind == skind);
3627 if (slength != NULL_TREE)
3629 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3630 ssc = gfc_string_to_single_character (slen, src, skind);
3634 slen = build_int_cst (size_type_node, 1);
3638 if (dlength != NULL_TREE)
3640 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3641 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3645 dlen = build_int_cst (size_type_node, 1);
3649 /* Assign directly if the types are compatible. */
3650 if (dsc != NULL_TREE && ssc != NULL_TREE
3651 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3653 gfc_add_modify (block, dsc, ssc);
3657 /* Do nothing if the destination length is zero. */
3658 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3659 build_int_cst (size_type_node, 0));
3661 /* The following code was previously in _gfortran_copy_string:
3663 // The two strings may overlap so we use memmove.
3665 copy_string (GFC_INTEGER_4 destlen, char * dest,
3666 GFC_INTEGER_4 srclen, const char * src)
3668 if (srclen >= destlen)
3670 // This will truncate if too long.
3671 memmove (dest, src, destlen);
3675 memmove (dest, src, srclen);
3677 memset (&dest[srclen], ' ', destlen - srclen);
3681 We're now doing it here for better optimization, but the logic
3684 /* For non-default character kinds, we have to multiply the string
3685 length by the base type size. */
3686 chartype = gfc_get_char_type (dkind);
3687 slen = fold_build2 (MULT_EXPR, size_type_node,
3688 fold_convert (size_type_node, slen),
3689 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3690 dlen = fold_build2 (MULT_EXPR, size_type_node,
3691 fold_convert (size_type_node, dlen),
3692 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3695 dest = fold_convert (pvoid_type_node, dest);
3697 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3700 src = fold_convert (pvoid_type_node, src);
3702 src = gfc_build_addr_expr (pvoid_type_node, src);
3704 /* Truncate string if source is too long. */
3705 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3706 tmp2 = build_call_expr_loc (input_location,
3707 built_in_decls[BUILT_IN_MEMMOVE],
3708 3, dest, src, dlen);
3710 /* Else copy and pad with spaces. */
3711 tmp3 = build_call_expr_loc (input_location,
3712 built_in_decls[BUILT_IN_MEMMOVE],
3713 3, dest, src, slen);
3715 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3716 fold_convert (sizetype, slen));
3717 tmp4 = fill_with_spaces (tmp4, chartype,
3718 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3721 gfc_init_block (&tempblock);
3722 gfc_add_expr_to_block (&tempblock, tmp3);
3723 gfc_add_expr_to_block (&tempblock, tmp4);
3724 tmp3 = gfc_finish_block (&tempblock);
3726 /* The whole copy_string function is there. */
3727 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3728 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3729 build_empty_stmt (input_location));
3730 gfc_add_expr_to_block (block, tmp);
3734 /* Translate a statement function.
3735 The value of a statement function reference is obtained by evaluating the
3736 expression using the values of the actual arguments for the values of the
3737 corresponding dummy arguments. */
3740 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3744 gfc_formal_arglist *fargs;
3745 gfc_actual_arglist *args;
3748 gfc_saved_var *saved_vars;
3754 sym = expr->symtree->n.sym;
3755 args = expr->value.function.actual;
3756 gfc_init_se (&lse, NULL);
3757 gfc_init_se (&rse, NULL);
3760 for (fargs = sym->formal; fargs; fargs = fargs->next)
3762 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3763 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3765 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3767 /* Each dummy shall be specified, explicitly or implicitly, to be
3769 gcc_assert (fargs->sym->attr.dimension == 0);
3772 /* Create a temporary to hold the value. */
3773 type = gfc_typenode_for_spec (&fsym->ts);
3774 temp_vars[n] = gfc_create_var (type, fsym->name);
3776 if (fsym->ts.type == BT_CHARACTER)
3778 /* Copy string arguments. */
3781 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3782 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3784 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3785 tmp = gfc_build_addr_expr (build_pointer_type (type),
3788 gfc_conv_expr (&rse, args->expr);
3789 gfc_conv_string_parameter (&rse);
3790 gfc_add_block_to_block (&se->pre, &lse.pre);
3791 gfc_add_block_to_block (&se->pre, &rse.pre);
3793 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3794 rse.string_length, rse.expr, fsym->ts.kind);
3795 gfc_add_block_to_block (&se->pre, &lse.post);
3796 gfc_add_block_to_block (&se->pre, &rse.post);
3800 /* For everything else, just evaluate the expression. */
3801 gfc_conv_expr (&lse, args->expr);
3803 gfc_add_block_to_block (&se->pre, &lse.pre);
3804 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3805 gfc_add_block_to_block (&se->pre, &lse.post);
3811 /* Use the temporary variables in place of the real ones. */
3812 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3813 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3815 gfc_conv_expr (se, sym->value);
3817 if (sym->ts.type == BT_CHARACTER)
3819 gfc_conv_const_charlen (sym->ts.u.cl);
3821 /* Force the expression to the correct length. */
3822 if (!INTEGER_CST_P (se->string_length)
3823 || tree_int_cst_lt (se->string_length,
3824 sym->ts.u.cl->backend_decl))
3826 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3827 tmp = gfc_create_var (type, sym->name);
3828 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3829 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3830 sym->ts.kind, se->string_length, se->expr,
3834 se->string_length = sym->ts.u.cl->backend_decl;
3837 /* Restore the original variables. */
3838 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3839 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3840 gfc_free (saved_vars);
3844 /* Translate a function expression. */
3847 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3851 if (expr->value.function.isym)
3853 gfc_conv_intrinsic_function (se, expr);
3857 /* We distinguish statement functions from general functions to improve
3858 runtime performance. */
3859 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3861 gfc_conv_statement_function (se, expr);
3865 /* expr.value.function.esym is the resolved (specific) function symbol for
3866 most functions. However this isn't set for dummy procedures. */
3867 sym = expr->value.function.esym;
3869 sym = expr->symtree->n.sym;
3871 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3875 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3878 is_zero_initializer_p (gfc_expr * expr)
3880 if (expr->expr_type != EXPR_CONSTANT)
3883 /* We ignore constants with prescribed memory representations for now. */
3884 if (expr->representation.string)
3887 switch (expr->ts.type)
3890 return mpz_cmp_si (expr->value.integer, 0) == 0;
3893 return mpfr_zero_p (expr->value.real)
3894 && MPFR_SIGN (expr->value.real) >= 0;
3897 return expr->value.logical == 0;
3900 return mpfr_zero_p (mpc_realref (expr->value.complex))
3901 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3902 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3903 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3913 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3915 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3916 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3918 gfc_conv_tmp_array_ref (se);
3919 gfc_advance_se_ss_chain (se);
3923 /* Build a static initializer. EXPR is the expression for the initial value.
3924 The other parameters describe the variable of the component being
3925 initialized. EXPR may be null. */
3928 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3929 bool array, bool pointer, bool procptr)
3933 if (!(expr || pointer || procptr))
3936 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3937 (these are the only two iso_c_binding derived types that can be
3938 used as initialization expressions). If so, we need to modify
3939 the 'expr' to be that for a (void *). */
3940 if (expr != NULL && expr->ts.type == BT_DERIVED
3941 && expr->ts.is_iso_c && expr->ts.u.derived)
3943 gfc_symbol *derived = expr->ts.u.derived;
3945 /* The derived symbol has already been converted to a (void *). Use
3947 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
3948 expr->ts.f90_type = derived->ts.f90_type;
3950 gfc_init_se (&se, NULL);
3951 gfc_conv_constant (&se, expr);
3955 if (array && !procptr)
3957 /* Arrays need special handling. */
3959 return gfc_build_null_descriptor (type);
3960 /* Special case assigning an array to zero. */
3961 else if (is_zero_initializer_p (expr))
3962 return build_constructor (type, NULL);
3964 return gfc_conv_array_initializer (type, expr);
3966 else if (pointer || procptr)
3968 if (!expr || expr->expr_type == EXPR_NULL)
3969 return fold_convert (type, null_pointer_node);
3972 gfc_init_se (&se, NULL);
3973 se.want_pointer = 1;
3974 gfc_conv_expr (&se, expr);
3984 gfc_init_se (&se, NULL);
3985 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
3986 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
3988 gfc_conv_structure (&se, expr, 1);
3992 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3995 gfc_init_se (&se, NULL);
3996 gfc_conv_constant (&se, expr);
4003 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4015 gfc_start_block (&block);
4017 /* Initialize the scalarizer. */
4018 gfc_init_loopinfo (&loop);
4020 gfc_init_se (&lse, NULL);
4021 gfc_init_se (&rse, NULL);
4024 rss = gfc_walk_expr (expr);
4025 if (rss == gfc_ss_terminator)
4027 /* The rhs is scalar. Add a ss for the expression. */
4028 rss = gfc_get_ss ();
4029 rss->next = gfc_ss_terminator;
4030 rss->type = GFC_SS_SCALAR;
4034 /* Create a SS for the destination. */
4035 lss = gfc_get_ss ();
4036 lss->type = GFC_SS_COMPONENT;
4038 lss->shape = gfc_get_shape (cm->as->rank);
4039 lss->next = gfc_ss_terminator;
4040 lss->data.info.dimen = cm->as->rank;
4041 lss->data.info.descriptor = dest;
4042 lss->data.info.data = gfc_conv_array_data (dest);
4043 lss->data.info.offset = gfc_conv_array_offset (dest);
4044 for (n = 0; n < cm->as->rank; n++)
4046 lss->data.info.dim[n] = n;
4047 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4048 lss->data.info.stride[n] = gfc_index_one_node;
4050 mpz_init (lss->shape[n]);
4051 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4052 cm->as->lower[n]->value.integer);
4053 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4056 /* Associate the SS with the loop. */
4057 gfc_add_ss_to_loop (&loop, lss);
4058 gfc_add_ss_to_loop (&loop, rss);
4060 /* Calculate the bounds of the scalarization. */
4061 gfc_conv_ss_startstride (&loop);
4063 /* Setup the scalarizing loops. */
4064 gfc_conv_loop_setup (&loop, &expr->where);
4066 /* Setup the gfc_se structures. */
4067 gfc_copy_loopinfo_to_se (&lse, &loop);
4068 gfc_copy_loopinfo_to_se (&rse, &loop);
4071 gfc_mark_ss_chain_used (rss, 1);
4073 gfc_mark_ss_chain_used (lss, 1);
4075 /* Start the scalarized loop body. */
4076 gfc_start_scalarized_body (&loop, &body);
4078 gfc_conv_tmp_array_ref (&lse);
4079 if (cm->ts.type == BT_CHARACTER)
4080 lse.string_length = cm->ts.u.cl->backend_decl;
4082 gfc_conv_expr (&rse, expr);
4084 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4085 gfc_add_expr_to_block (&body, tmp);
4087 gcc_assert (rse.ss == gfc_ss_terminator);
4089 /* Generate the copying loops. */
4090 gfc_trans_scalarizing_loops (&loop, &body);
4092 /* Wrap the whole thing up. */
4093 gfc_add_block_to_block (&block, &loop.pre);
4094 gfc_add_block_to_block (&block, &loop.post);
4096 for (n = 0; n < cm->as->rank; n++)
4097 mpz_clear (lss->shape[n]);
4098 gfc_free (lss->shape);
4100 gfc_cleanup_loop (&loop);
4102 return gfc_finish_block (&block);
4107 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4118 gfc_expr *arg = NULL;
4120 gfc_start_block (&block);
4121 gfc_init_se (&se, NULL);
4123 /* Get the descriptor for the expressions. */
4124 rss = gfc_walk_expr (expr);
4125 se.want_pointer = 0;
4126 gfc_conv_expr_descriptor (&se, expr, rss);
4127 gfc_add_block_to_block (&block, &se.pre);
4128 gfc_add_modify (&block, dest, se.expr);
4130 /* Deal with arrays of derived types with allocatable components. */
4131 if (cm->ts.type == BT_DERIVED
4132 && cm->ts.u.derived->attr.alloc_comp)
4133 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4137 tmp = gfc_duplicate_allocatable (dest, se.expr,
4138 TREE_TYPE(cm->backend_decl),
4141 gfc_add_expr_to_block (&block, tmp);
4142 gfc_add_block_to_block (&block, &se.post);
4144 if (expr->expr_type != EXPR_VARIABLE)
4145 gfc_conv_descriptor_data_set (&block, se.expr,
4148 /* We need to know if the argument of a conversion function is a
4149 variable, so that the correct lower bound can be used. */
4150 if (expr->expr_type == EXPR_FUNCTION
4151 && expr->value.function.isym
4152 && expr->value.function.isym->conversion
4153 && expr->value.function.actual->expr
4154 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4155 arg = expr->value.function.actual->expr;
4157 /* Obtain the array spec of full array references. */
4159 as = gfc_get_full_arrayspec_from_expr (arg);
4161 as = gfc_get_full_arrayspec_from_expr (expr);
4163 /* Shift the lbound and ubound of temporaries to being unity,
4164 rather than zero, based. Always calculate the offset. */
4165 offset = gfc_conv_descriptor_offset_get (dest);
4166 gfc_add_modify (&block, offset, gfc_index_zero_node);
4167 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4169 for (n = 0; n < expr->rank; n++)
4174 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4175 TODO It looks as if gfc_conv_expr_descriptor should return
4176 the correct bounds and that the following should not be
4177 necessary. This would simplify gfc_conv_intrinsic_bound
4179 if (as && as->lower[n])
4182 gfc_init_se (&lbse, NULL);
4183 gfc_conv_expr (&lbse, as->lower[n]);
4184 gfc_add_block_to_block (&block, &lbse.pre);
4185 lbound = gfc_evaluate_now (lbse.expr, &block);
4189 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4190 lbound = gfc_conv_descriptor_lbound_get (tmp,
4194 lbound = gfc_conv_descriptor_lbound_get (dest,
4197 lbound = gfc_index_one_node;
4199 lbound = fold_convert (gfc_array_index_type, lbound);
4201 /* Shift the bounds and set the offset accordingly. */
4202 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4203 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4204 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4205 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4206 gfc_conv_descriptor_ubound_set (&block, dest,
4207 gfc_rank_cst[n], tmp);
4208 gfc_conv_descriptor_lbound_set (&block, dest,
4209 gfc_rank_cst[n], lbound);
4211 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4212 gfc_conv_descriptor_lbound_get (dest,
4214 gfc_conv_descriptor_stride_get (dest,
4216 gfc_add_modify (&block, tmp2, tmp);
4217 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4218 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4223 /* If a conversion expression has a null data pointer
4224 argument, nullify the allocatable component. */
4228 if (arg->symtree->n.sym->attr.allocatable
4229 || arg->symtree->n.sym->attr.pointer)
4231 non_null_expr = gfc_finish_block (&block);
4232 gfc_start_block (&block);
4233 gfc_conv_descriptor_data_set (&block, dest,
4235 null_expr = gfc_finish_block (&block);
4236 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4237 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4238 fold_convert (TREE_TYPE (tmp),
4239 null_pointer_node));
4240 return build3_v (COND_EXPR, tmp,
4241 null_expr, non_null_expr);
4245 return gfc_finish_block (&block);
4249 /* Assign a single component of a derived type constructor. */
4252 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4260 gfc_start_block (&block);
4262 if (cm->attr.pointer)
4264 gfc_init_se (&se, NULL);
4265 /* Pointer component. */
4266 if (cm->attr.dimension)
4268 /* Array pointer. */
4269 if (expr->expr_type == EXPR_NULL)
4270 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4273 rss = gfc_walk_expr (expr);
4274 se.direct_byref = 1;
4276 gfc_conv_expr_descriptor (&se, expr, rss);
4277 gfc_add_block_to_block (&block, &se.pre);
4278 gfc_add_block_to_block (&block, &se.post);
4283 /* Scalar pointers. */
4284 se.want_pointer = 1;
4285 gfc_conv_expr (&se, expr);
4286 gfc_add_block_to_block (&block, &se.pre);
4287 gfc_add_modify (&block, dest,
4288 fold_convert (TREE_TYPE (dest), se.expr));
4289 gfc_add_block_to_block (&block, &se.post);
4292 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4294 /* NULL initialization for CLASS components. */
4295 tmp = gfc_trans_structure_assign (dest,
4296 gfc_class_null_initializer (&cm->ts));
4297 gfc_add_expr_to_block (&block, tmp);
4299 else if (cm->attr.dimension)
4301 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4302 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4303 else if (cm->attr.allocatable)
4305 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4306 gfc_add_expr_to_block (&block, tmp);
4310 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4311 gfc_add_expr_to_block (&block, tmp);
4314 else if (expr->ts.type == BT_DERIVED)
4316 if (expr->expr_type != EXPR_STRUCTURE)
4318 gfc_init_se (&se, NULL);
4319 gfc_conv_expr (&se, expr);
4320 gfc_add_block_to_block (&block, &se.pre);
4321 gfc_add_modify (&block, dest,
4322 fold_convert (TREE_TYPE (dest), se.expr));
4323 gfc_add_block_to_block (&block, &se.post);
4327 /* Nested constructors. */
4328 tmp = gfc_trans_structure_assign (dest, expr);
4329 gfc_add_expr_to_block (&block, tmp);
4334 /* Scalar component. */
4335 gfc_init_se (&se, NULL);
4336 gfc_init_se (&lse, NULL);
4338 gfc_conv_expr (&se, expr);
4339 if (cm->ts.type == BT_CHARACTER)
4340 lse.string_length = cm->ts.u.cl->backend_decl;
4342 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4343 gfc_add_expr_to_block (&block, tmp);
4345 return gfc_finish_block (&block);
4348 /* Assign a derived type constructor to a variable. */
4351 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4359 gfc_start_block (&block);
4360 cm = expr->ts.u.derived->components;
4361 for (c = gfc_constructor_first (expr->value.constructor);
4362 c; c = gfc_constructor_next (c), cm = cm->next)
4364 /* Skip absent members in default initializers. */
4368 /* Handle c_null_(fun)ptr. */
4369 if (c && c->expr && c->expr->ts.is_iso_c)
4371 field = cm->backend_decl;
4372 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4373 dest, field, NULL_TREE);
4374 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4375 fold_convert (TREE_TYPE (tmp),
4376 null_pointer_node));
4377 gfc_add_expr_to_block (&block, tmp);
4381 field = cm->backend_decl;
4382 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4383 dest, field, NULL_TREE);
4384 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4385 gfc_add_expr_to_block (&block, tmp);
4387 return gfc_finish_block (&block);
4390 /* Build an expression for a constructor. If init is nonzero then
4391 this is part of a static variable initializer. */
4394 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4401 VEC(constructor_elt,gc) *v = NULL;
4403 gcc_assert (se->ss == NULL);
4404 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4405 type = gfc_typenode_for_spec (&expr->ts);
4409 /* Create a temporary variable and fill it in. */
4410 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4411 tmp = gfc_trans_structure_assign (se->expr, expr);
4412 gfc_add_expr_to_block (&se->pre, tmp);
4416 cm = expr->ts.u.derived->components;
4418 for (c = gfc_constructor_first (expr->value.constructor);
4419 c; c = gfc_constructor_next (c), cm = cm->next)
4421 /* Skip absent members in default initializers and allocatable
4422 components. Although the latter have a default initializer
4423 of EXPR_NULL,... by default, the static nullify is not needed
4424 since this is done every time we come into scope. */
4425 if (!c->expr || cm->attr.allocatable)
4428 if (strcmp (cm->name, "$size") == 0)
4430 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4431 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4433 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4434 && strcmp (cm->name, "$extends") == 0)
4438 vtabs = cm->initializer->symtree->n.sym;
4439 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4440 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4444 val = gfc_conv_initializer (c->expr, &cm->ts,
4445 TREE_TYPE (cm->backend_decl),
4446 cm->attr.dimension, cm->attr.pointer,
4447 cm->attr.proc_pointer);
4449 /* Append it to the constructor list. */
4450 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4453 se->expr = build_constructor (type, v);
4455 TREE_CONSTANT (se->expr) = 1;
4459 /* Translate a substring expression. */
4462 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4468 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4470 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4471 expr->value.character.length,
4472 expr->value.character.string);
4474 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4475 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4478 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4482 /* Entry point for expression translation. Evaluates a scalar quantity.
4483 EXPR is the expression to be translated, and SE is the state structure if
4484 called from within the scalarized. */
4487 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4489 if (se->ss && se->ss->expr == expr
4490 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4492 /* Substitute a scalar expression evaluated outside the scalarization
4494 se->expr = se->ss->data.scalar.expr;
4495 if (se->ss->type == GFC_SS_REFERENCE)
4496 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4497 se->string_length = se->ss->string_length;
4498 gfc_advance_se_ss_chain (se);
4502 /* We need to convert the expressions for the iso_c_binding derived types.
4503 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4504 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4505 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4506 updated to be an integer with a kind equal to the size of a (void *). */
4507 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4508 && expr->ts.u.derived->attr.is_iso_c)
4510 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4511 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4513 /* Set expr_type to EXPR_NULL, which will result in
4514 null_pointer_node being used below. */
4515 expr->expr_type = EXPR_NULL;
4519 /* Update the type/kind of the expression to be what the new
4520 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4521 expr->ts.type = expr->ts.u.derived->ts.type;
4522 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4523 expr->ts.kind = expr->ts.u.derived->ts.kind;
4527 switch (expr->expr_type)
4530 gfc_conv_expr_op (se, expr);
4534 gfc_conv_function_expr (se, expr);
4538 gfc_conv_constant (se, expr);
4542 gfc_conv_variable (se, expr);
4546 se->expr = null_pointer_node;
4549 case EXPR_SUBSTRING:
4550 gfc_conv_substring_expr (se, expr);
4553 case EXPR_STRUCTURE:
4554 gfc_conv_structure (se, expr, 0);
4558 gfc_conv_array_constructor_expr (se, expr);
4567 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4568 of an assignment. */
4570 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4572 gfc_conv_expr (se, expr);
4573 /* All numeric lvalues should have empty post chains. If not we need to
4574 figure out a way of rewriting an lvalue so that it has no post chain. */
4575 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4578 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4579 numeric expressions. Used for scalar values where inserting cleanup code
4582 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4586 gcc_assert (expr->ts.type != BT_CHARACTER);
4587 gfc_conv_expr (se, expr);
4590 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4591 gfc_add_modify (&se->pre, val, se->expr);
4593 gfc_add_block_to_block (&se->pre, &se->post);
4597 /* Helper to translate an expression and convert it to a particular type. */
4599 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4601 gfc_conv_expr_val (se, expr);
4602 se->expr = convert (type, se->expr);
4606 /* Converts an expression so that it can be passed by reference. Scalar
4610 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4614 if (se->ss && se->ss->expr == expr
4615 && se->ss->type == GFC_SS_REFERENCE)
4617 /* Returns a reference to the scalar evaluated outside the loop
4619 gfc_conv_expr (se, expr);
4623 if (expr->ts.type == BT_CHARACTER)
4625 gfc_conv_expr (se, expr);
4626 gfc_conv_string_parameter (se);
4630 if (expr->expr_type == EXPR_VARIABLE)
4632 se->want_pointer = 1;
4633 gfc_conv_expr (se, expr);
4636 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4637 gfc_add_modify (&se->pre, var, se->expr);
4638 gfc_add_block_to_block (&se->pre, &se->post);
4644 if (expr->expr_type == EXPR_FUNCTION
4645 && ((expr->value.function.esym
4646 && expr->value.function.esym->result->attr.pointer
4647 && !expr->value.function.esym->result->attr.dimension)
4648 || (!expr->value.function.esym
4649 && expr->symtree->n.sym->attr.pointer
4650 && !expr->symtree->n.sym->attr.dimension)))
4652 se->want_pointer = 1;
4653 gfc_conv_expr (se, expr);
4654 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4655 gfc_add_modify (&se->pre, var, se->expr);
4661 gfc_conv_expr (se, expr);
4663 /* Create a temporary var to hold the value. */
4664 if (TREE_CONSTANT (se->expr))
4666 tree tmp = se->expr;
4667 STRIP_TYPE_NOPS (tmp);
4668 var = build_decl (input_location,
4669 CONST_DECL, NULL, TREE_TYPE (tmp));
4670 DECL_INITIAL (var) = tmp;
4671 TREE_STATIC (var) = 1;
4676 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4677 gfc_add_modify (&se->pre, var, se->expr);
4679 gfc_add_block_to_block (&se->pre, &se->post);
4681 /* Take the address of that value. */
4682 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4687 gfc_trans_pointer_assign (gfc_code * code)
4689 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4693 /* Generate code for a pointer assignment. */
4696 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4707 gfc_start_block (&block);
4709 gfc_init_se (&lse, NULL);
4711 lss = gfc_walk_expr (expr1);
4712 rss = gfc_walk_expr (expr2);
4713 if (lss == gfc_ss_terminator)
4715 /* Scalar pointers. */
4716 lse.want_pointer = 1;
4717 gfc_conv_expr (&lse, expr1);
4718 gcc_assert (rss == gfc_ss_terminator);
4719 gfc_init_se (&rse, NULL);
4720 rse.want_pointer = 1;
4721 gfc_conv_expr (&rse, expr2);
4723 if (expr1->symtree->n.sym->attr.proc_pointer
4724 && expr1->symtree->n.sym->attr.dummy)
4725 lse.expr = build_fold_indirect_ref_loc (input_location,
4728 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4729 && expr2->symtree->n.sym->attr.dummy)
4730 rse.expr = build_fold_indirect_ref_loc (input_location,
4733 gfc_add_block_to_block (&block, &lse.pre);
4734 gfc_add_block_to_block (&block, &rse.pre);
4736 /* Check character lengths if character expression. The test is only
4737 really added if -fbounds-check is enabled. */
4738 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4739 && !expr1->symtree->n.sym->attr.proc_pointer
4740 && !gfc_is_proc_ptr_comp (expr1, NULL))
4742 gcc_assert (expr2->ts.type == BT_CHARACTER);
4743 gcc_assert (lse.string_length && rse.string_length);
4744 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4745 lse.string_length, rse.string_length,
4749 gfc_add_modify (&block, lse.expr,
4750 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4752 gfc_add_block_to_block (&block, &rse.post);
4753 gfc_add_block_to_block (&block, &lse.post);
4760 tree strlen_rhs = NULL_TREE;
4762 /* Array pointer. Find the last reference on the LHS and if it is an
4763 array section ref, we're dealing with bounds remapping. In this case,
4764 set it to AR_FULL so that gfc_conv_expr_descriptor does
4765 not see it and process the bounds remapping afterwards explicitely. */
4766 for (remap = expr1->ref; remap; remap = remap->next)
4767 if (!remap->next && remap->type == REF_ARRAY
4768 && remap->u.ar.type == AR_SECTION)
4770 remap->u.ar.type = AR_FULL;
4773 rank_remap = (remap && remap->u.ar.end[0]);
4775 gfc_conv_expr_descriptor (&lse, expr1, lss);
4776 strlen_lhs = lse.string_length;
4779 if (expr2->expr_type == EXPR_NULL)
4781 /* Just set the data pointer to null. */
4782 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4784 else if (rank_remap)
4786 /* If we are rank-remapping, just get the RHS's descriptor and
4787 process this later on. */
4788 gfc_init_se (&rse, NULL);
4789 rse.direct_byref = 1;
4790 rse.byref_noassign = 1;
4791 gfc_conv_expr_descriptor (&rse, expr2, rss);
4792 strlen_rhs = rse.string_length;
4794 else if (expr2->expr_type == EXPR_VARIABLE)
4796 /* Assign directly to the LHS's descriptor. */
4797 lse.direct_byref = 1;
4798 gfc_conv_expr_descriptor (&lse, expr2, rss);
4799 strlen_rhs = lse.string_length;
4801 /* If this is a subreference array pointer assignment, use the rhs
4802 descriptor element size for the lhs span. */
4803 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4805 decl = expr1->symtree->n.sym->backend_decl;
4806 gfc_init_se (&rse, NULL);
4807 rse.descriptor_only = 1;
4808 gfc_conv_expr (&rse, expr2);
4809 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4810 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4811 if (!INTEGER_CST_P (tmp))
4812 gfc_add_block_to_block (&lse.post, &rse.pre);
4813 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4818 /* Assign to a temporary descriptor and then copy that
4819 temporary to the pointer. */
4820 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4823 lse.direct_byref = 1;
4824 gfc_conv_expr_descriptor (&lse, expr2, rss);
4825 strlen_rhs = lse.string_length;
4826 gfc_add_modify (&lse.pre, desc, tmp);
4829 gfc_add_block_to_block (&block, &lse.pre);
4831 gfc_add_block_to_block (&block, &rse.pre);
4833 /* If we do bounds remapping, update LHS descriptor accordingly. */
4837 gcc_assert (remap->u.ar.dimen == expr1->rank);
4841 /* Do rank remapping. We already have the RHS's descriptor
4842 converted in rse and now have to build the correct LHS
4843 descriptor for it. */
4847 tree lbound, ubound;
4850 dtype = gfc_conv_descriptor_dtype (desc);
4851 tmp = gfc_get_dtype (TREE_TYPE (desc));
4852 gfc_add_modify (&block, dtype, tmp);
4854 /* Copy data pointer. */
4855 data = gfc_conv_descriptor_data_get (rse.expr);
4856 gfc_conv_descriptor_data_set (&block, desc, data);
4858 /* Copy offset but adjust it such that it would correspond
4859 to a lbound of zero. */
4860 offs = gfc_conv_descriptor_offset_get (rse.expr);
4861 for (dim = 0; dim < expr2->rank; ++dim)
4863 stride = gfc_conv_descriptor_stride_get (rse.expr,
4865 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
4867 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4869 offs = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4872 gfc_conv_descriptor_offset_set (&block, desc, offs);
4874 /* Set the bounds as declared for the LHS and calculate strides as
4875 well as another offset update accordingly. */
4876 stride = gfc_conv_descriptor_stride_get (rse.expr,
4878 for (dim = 0; dim < expr1->rank; ++dim)
4883 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
4885 /* Convert declared bounds. */
4886 gfc_init_se (&lower_se, NULL);
4887 gfc_init_se (&upper_se, NULL);
4888 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
4889 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
4891 gfc_add_block_to_block (&block, &lower_se.pre);
4892 gfc_add_block_to_block (&block, &upper_se.pre);
4894 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
4895 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
4897 lbound = gfc_evaluate_now (lbound, &block);
4898 ubound = gfc_evaluate_now (ubound, &block);
4900 gfc_add_block_to_block (&block, &lower_se.post);
4901 gfc_add_block_to_block (&block, &upper_se.post);
4903 /* Set bounds in descriptor. */
4904 gfc_conv_descriptor_lbound_set (&block, desc,
4905 gfc_rank_cst[dim], lbound);
4906 gfc_conv_descriptor_ubound_set (&block, desc,
4907 gfc_rank_cst[dim], ubound);
4910 stride = gfc_evaluate_now (stride, &block);
4911 gfc_conv_descriptor_stride_set (&block, desc,
4912 gfc_rank_cst[dim], stride);
4914 /* Update offset. */
4915 offs = gfc_conv_descriptor_offset_get (desc);
4916 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4918 offs = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4920 offs = gfc_evaluate_now (offs, &block);
4921 gfc_conv_descriptor_offset_set (&block, desc, offs);
4923 /* Update stride. */
4924 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4925 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4931 /* Bounds remapping. Just shift the lower bounds. */
4933 gcc_assert (expr1->rank == expr2->rank);
4935 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
4939 gcc_assert (remap->u.ar.start[dim]);
4940 gcc_assert (!remap->u.ar.end[dim]);
4941 gfc_init_se (&lbound_se, NULL);
4942 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
4944 gfc_add_block_to_block (&block, &lbound_se.pre);
4945 gfc_conv_shift_descriptor_lbound (&block, desc,
4946 dim, lbound_se.expr);
4947 gfc_add_block_to_block (&block, &lbound_se.post);
4952 /* Check string lengths if applicable. The check is only really added
4953 to the output code if -fbounds-check is enabled. */
4954 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4956 gcc_assert (expr2->ts.type == BT_CHARACTER);
4957 gcc_assert (strlen_lhs && strlen_rhs);
4958 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4959 strlen_lhs, strlen_rhs, &block);
4962 /* If rank remapping was done, check with -fcheck=bounds that
4963 the target is at least as large as the pointer. */
4964 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
4970 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
4971 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
4973 lsize = gfc_evaluate_now (lsize, &block);
4974 rsize = gfc_evaluate_now (rsize, &block);
4975 fault = fold_build2 (LT_EXPR, boolean_type_node, rsize, lsize);
4977 msg = _("Target of rank remapping is too small (%ld < %ld)");
4978 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
4982 gfc_add_block_to_block (&block, &lse.post);
4984 gfc_add_block_to_block (&block, &rse.post);
4987 return gfc_finish_block (&block);
4991 /* Makes sure se is suitable for passing as a function string parameter. */
4992 /* TODO: Need to check all callers of this function. It may be abused. */
4995 gfc_conv_string_parameter (gfc_se * se)
4999 if (TREE_CODE (se->expr) == STRING_CST)
5001 type = TREE_TYPE (TREE_TYPE (se->expr));
5002 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5006 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5008 if (TREE_CODE (se->expr) != INDIRECT_REF)
5010 type = TREE_TYPE (se->expr);
5011 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5015 type = gfc_get_character_type_len (gfc_default_character_kind,
5017 type = build_pointer_type (type);
5018 se->expr = gfc_build_addr_expr (type, se->expr);
5022 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5023 gcc_assert (se->string_length
5024 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
5028 /* Generate code for assignment of scalar variables. Includes character
5029 strings and derived types with allocatable components.
5030 If you know that the LHS has no allocations, set dealloc to false. */
5033 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5034 bool l_is_temp, bool r_is_var, bool dealloc)
5040 gfc_init_block (&block);
5042 if (ts.type == BT_CHARACTER)
5047 if (lse->string_length != NULL_TREE)
5049 gfc_conv_string_parameter (lse);
5050 gfc_add_block_to_block (&block, &lse->pre);
5051 llen = lse->string_length;
5054 if (rse->string_length != NULL_TREE)
5056 gcc_assert (rse->string_length != NULL_TREE);
5057 gfc_conv_string_parameter (rse);
5058 gfc_add_block_to_block (&block, &rse->pre);
5059 rlen = rse->string_length;
5062 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5063 rse->expr, ts.kind);
5065 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5069 /* Are the rhs and the lhs the same? */
5072 cond = fold_build2 (EQ_EXPR, boolean_type_node,
5073 gfc_build_addr_expr (NULL_TREE, lse->expr),
5074 gfc_build_addr_expr (NULL_TREE, rse->expr));
5075 cond = gfc_evaluate_now (cond, &lse->pre);
5078 /* Deallocate the lhs allocated components as long as it is not
5079 the same as the rhs. This must be done following the assignment
5080 to prevent deallocating data that could be used in the rhs
5082 if (!l_is_temp && dealloc)
5084 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5085 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5087 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5089 gfc_add_expr_to_block (&lse->post, tmp);
5092 gfc_add_block_to_block (&block, &rse->pre);
5093 gfc_add_block_to_block (&block, &lse->pre);
5095 gfc_add_modify (&block, lse->expr,
5096 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5098 /* Do a deep copy if the rhs is a variable, if it is not the
5102 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5103 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5105 gfc_add_expr_to_block (&block, tmp);
5108 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5110 gfc_add_block_to_block (&block, &lse->pre);
5111 gfc_add_block_to_block (&block, &rse->pre);
5112 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
5113 gfc_add_modify (&block, lse->expr, tmp);
5117 gfc_add_block_to_block (&block, &lse->pre);
5118 gfc_add_block_to_block (&block, &rse->pre);
5120 gfc_add_modify (&block, lse->expr,
5121 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5124 gfc_add_block_to_block (&block, &lse->post);
5125 gfc_add_block_to_block (&block, &rse->post);
5127 return gfc_finish_block (&block);
5131 /* There are quite a lot of restrictions on the optimisation in using an
5132 array function assign without a temporary. */
5135 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5138 bool seen_array_ref;
5140 gfc_symbol *sym = expr1->symtree->n.sym;
5142 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5143 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5146 /* Elemental functions are scalarized so that they don't need a
5147 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5148 they would need special treatment in gfc_trans_arrayfunc_assign. */
5149 if (expr2->value.function.esym != NULL
5150 && expr2->value.function.esym->attr.elemental)
5153 /* Need a temporary if rhs is not FULL or a contiguous section. */
5154 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5157 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5158 if (gfc_ref_needs_temporary_p (expr1->ref))
5161 /* Functions returning pointers need temporaries. */
5162 if (expr2->symtree->n.sym->attr.pointer
5163 || expr2->symtree->n.sym->attr.allocatable)
5166 /* Character array functions need temporaries unless the
5167 character lengths are the same. */
5168 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5170 if (expr1->ts.u.cl->length == NULL
5171 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5174 if (expr2->ts.u.cl->length == NULL
5175 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5178 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5179 expr2->ts.u.cl->length->value.integer) != 0)
5183 /* Check that no LHS component references appear during an array
5184 reference. This is needed because we do not have the means to
5185 span any arbitrary stride with an array descriptor. This check
5186 is not needed for the rhs because the function result has to be
5188 seen_array_ref = false;
5189 for (ref = expr1->ref; ref; ref = ref->next)
5191 if (ref->type == REF_ARRAY)
5192 seen_array_ref= true;
5193 else if (ref->type == REF_COMPONENT && seen_array_ref)
5197 /* Check for a dependency. */
5198 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5199 expr2->value.function.esym,
5200 expr2->value.function.actual,
5204 /* If we have reached here with an intrinsic function, we do not
5205 need a temporary. */
5206 if (expr2->value.function.isym)
5209 /* If the LHS is a dummy, we need a temporary if it is not
5211 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5214 /* A PURE function can unconditionally be called without a temporary. */
5215 if (expr2->value.function.esym != NULL
5216 && expr2->value.function.esym->attr.pure)
5219 /* TODO a function that could correctly be declared PURE but is not
5220 could do with returning false as well. */
5222 if (!sym->attr.use_assoc
5223 && !sym->attr.in_common
5224 && !sym->attr.pointer
5225 && !sym->attr.target
5226 && expr2->value.function.esym)
5228 /* A temporary is not needed if the function is not contained and
5229 the variable is local or host associated and not a pointer or
5231 if (!expr2->value.function.esym->attr.contained)
5234 /* A temporary is not needed if the lhs has never been host
5235 associated and the procedure is contained. */
5236 else if (!sym->attr.host_assoc)
5239 /* A temporary is not needed if the variable is local and not
5240 a pointer, a target or a result. */
5242 && expr2->value.function.esym->ns == sym->ns->parent)
5246 /* Default to temporary use. */
5251 /* Try to translate array(:) = func (...), where func is a transformational
5252 array function, without using a temporary. Returns NULL if this isn't the
5256 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5260 gfc_component *comp = NULL;
5262 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5265 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5267 gcc_assert (expr2->value.function.isym
5268 || (gfc_is_proc_ptr_comp (expr2, &comp)
5269 && comp && comp->attr.dimension)
5270 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5271 && expr2->value.function.esym->result->attr.dimension));
5273 ss = gfc_walk_expr (expr1);
5274 gcc_assert (ss != gfc_ss_terminator);
5275 gfc_init_se (&se, NULL);
5276 gfc_start_block (&se.pre);
5277 se.want_pointer = 1;
5279 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5281 if (expr1->ts.type == BT_DERIVED
5282 && expr1->ts.u.derived->attr.alloc_comp)
5285 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5287 gfc_add_expr_to_block (&se.pre, tmp);
5290 se.direct_byref = 1;
5291 se.ss = gfc_walk_expr (expr2);
5292 gcc_assert (se.ss != gfc_ss_terminator);
5293 gfc_conv_function_expr (&se, expr2);
5294 gfc_add_block_to_block (&se.pre, &se.post);
5296 return gfc_finish_block (&se.pre);
5300 /* Try to efficiently translate array(:) = 0. Return NULL if this
5304 gfc_trans_zero_assign (gfc_expr * expr)
5306 tree dest, len, type;
5310 sym = expr->symtree->n.sym;
5311 dest = gfc_get_symbol_decl (sym);
5313 type = TREE_TYPE (dest);
5314 if (POINTER_TYPE_P (type))
5315 type = TREE_TYPE (type);
5316 if (!GFC_ARRAY_TYPE_P (type))
5319 /* Determine the length of the array. */
5320 len = GFC_TYPE_ARRAY_SIZE (type);
5321 if (!len || TREE_CODE (len) != INTEGER_CST)
5324 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5325 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5326 fold_convert (gfc_array_index_type, tmp));
5328 /* If we are zeroing a local array avoid taking its address by emitting
5330 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5331 return build2 (MODIFY_EXPR, void_type_node,
5332 dest, build_constructor (TREE_TYPE (dest), NULL));
5334 /* Convert arguments to the correct types. */
5335 dest = fold_convert (pvoid_type_node, dest);
5336 len = fold_convert (size_type_node, len);
5338 /* Construct call to __builtin_memset. */
5339 tmp = build_call_expr_loc (input_location,
5340 built_in_decls[BUILT_IN_MEMSET],
5341 3, dest, integer_zero_node, len);
5342 return fold_convert (void_type_node, tmp);
5346 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5347 that constructs the call to __builtin_memcpy. */
5350 gfc_build_memcpy_call (tree dst, tree src, tree len)
5354 /* Convert arguments to the correct types. */
5355 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5356 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5358 dst = fold_convert (pvoid_type_node, dst);
5360 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5361 src = gfc_build_addr_expr (pvoid_type_node, src);
5363 src = fold_convert (pvoid_type_node, src);
5365 len = fold_convert (size_type_node, len);
5367 /* Construct call to __builtin_memcpy. */
5368 tmp = build_call_expr_loc (input_location,
5369 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5370 return fold_convert (void_type_node, tmp);
5374 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5375 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5376 source/rhs, both are gfc_full_array_ref_p which have been checked for
5380 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5382 tree dst, dlen, dtype;
5383 tree src, slen, stype;
5386 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5387 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5389 dtype = TREE_TYPE (dst);
5390 if (POINTER_TYPE_P (dtype))
5391 dtype = TREE_TYPE (dtype);
5392 stype = TREE_TYPE (src);
5393 if (POINTER_TYPE_P (stype))
5394 stype = TREE_TYPE (stype);
5396 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5399 /* Determine the lengths of the arrays. */
5400 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5401 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5403 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5404 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5405 fold_convert (gfc_array_index_type, tmp));
5407 slen = GFC_TYPE_ARRAY_SIZE (stype);
5408 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5410 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5411 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5412 fold_convert (gfc_array_index_type, tmp));
5414 /* Sanity check that they are the same. This should always be
5415 the case, as we should already have checked for conformance. */
5416 if (!tree_int_cst_equal (slen, dlen))
5419 return gfc_build_memcpy_call (dst, src, dlen);
5423 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5424 this can't be done. EXPR1 is the destination/lhs for which
5425 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5428 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5430 unsigned HOST_WIDE_INT nelem;
5436 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5440 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5441 dtype = TREE_TYPE (dst);
5442 if (POINTER_TYPE_P (dtype))
5443 dtype = TREE_TYPE (dtype);
5444 if (!GFC_ARRAY_TYPE_P (dtype))
5447 /* Determine the lengths of the array. */
5448 len = GFC_TYPE_ARRAY_SIZE (dtype);
5449 if (!len || TREE_CODE (len) != INTEGER_CST)
5452 /* Confirm that the constructor is the same size. */
5453 if (compare_tree_int (len, nelem) != 0)
5456 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5457 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5458 fold_convert (gfc_array_index_type, tmp));
5460 stype = gfc_typenode_for_spec (&expr2->ts);
5461 src = gfc_build_constant_array_constructor (expr2, stype);
5463 stype = TREE_TYPE (src);
5464 if (POINTER_TYPE_P (stype))
5465 stype = TREE_TYPE (stype);
5467 return gfc_build_memcpy_call (dst, src, len);
5471 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5472 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5473 init_flag indicates initialization expressions and dealloc that no
5474 deallocate prior assignment is needed (if in doubt, set true). */
5477 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5483 gfc_ss *lss_section;
5490 bool scalar_to_array;
5494 /* Assignment of the form lhs = rhs. */
5495 gfc_start_block (&block);
5497 gfc_init_se (&lse, NULL);
5498 gfc_init_se (&rse, NULL);
5501 lss = gfc_walk_expr (expr1);
5503 if (lss != gfc_ss_terminator)
5505 /* Allow the scalarizer to workshare array assignments. */
5506 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5507 ompws_flags |= OMPWS_SCALARIZER_WS;
5509 /* The assignment needs scalarization. */
5512 /* Find a non-scalar SS from the lhs. */
5513 while (lss_section != gfc_ss_terminator
5514 && lss_section->type != GFC_SS_SECTION)
5515 lss_section = lss_section->next;
5517 gcc_assert (lss_section != gfc_ss_terminator);
5519 /* Initialize the scalarizer. */
5520 gfc_init_loopinfo (&loop);
5523 rss = gfc_walk_expr (expr2);
5524 if (rss == gfc_ss_terminator)
5526 /* The rhs is scalar. Add a ss for the expression. */
5527 rss = gfc_get_ss ();
5528 rss->next = gfc_ss_terminator;
5529 rss->type = GFC_SS_SCALAR;
5532 /* Associate the SS with the loop. */
5533 gfc_add_ss_to_loop (&loop, lss);
5534 gfc_add_ss_to_loop (&loop, rss);
5536 /* Calculate the bounds of the scalarization. */
5537 gfc_conv_ss_startstride (&loop);
5538 /* Enable loop reversal. */
5539 for (n = 0; n < loop.dimen; n++)
5540 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5541 /* Resolve any data dependencies in the statement. */
5542 gfc_conv_resolve_dependencies (&loop, lss, rss);
5543 /* Setup the scalarizing loops. */
5544 gfc_conv_loop_setup (&loop, &expr2->where);
5546 /* Setup the gfc_se structures. */
5547 gfc_copy_loopinfo_to_se (&lse, &loop);
5548 gfc_copy_loopinfo_to_se (&rse, &loop);
5551 gfc_mark_ss_chain_used (rss, 1);
5552 if (loop.temp_ss == NULL)
5555 gfc_mark_ss_chain_used (lss, 1);
5559 lse.ss = loop.temp_ss;
5560 gfc_mark_ss_chain_used (lss, 3);
5561 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5564 /* Start the scalarized loop body. */
5565 gfc_start_scalarized_body (&loop, &body);
5568 gfc_init_block (&body);
5570 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5572 /* Translate the expression. */
5573 gfc_conv_expr (&rse, expr2);
5575 /* Stabilize a string length for temporaries. */
5576 if (expr2->ts.type == BT_CHARACTER)
5577 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5579 string_length = NULL_TREE;
5583 gfc_conv_tmp_array_ref (&lse);
5584 gfc_advance_se_ss_chain (&lse);
5585 if (expr2->ts.type == BT_CHARACTER)
5586 lse.string_length = string_length;
5589 gfc_conv_expr (&lse, expr1);
5591 /* Assignments of scalar derived types with allocatable components
5592 to arrays must be done with a deep copy and the rhs temporary
5593 must have its components deallocated afterwards. */
5594 scalar_to_array = (expr2->ts.type == BT_DERIVED
5595 && expr2->ts.u.derived->attr.alloc_comp
5596 && expr2->expr_type != EXPR_VARIABLE
5597 && !gfc_is_constant_expr (expr2)
5598 && expr1->rank && !expr2->rank);
5599 if (scalar_to_array && dealloc)
5601 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5602 gfc_add_expr_to_block (&loop.post, tmp);
5605 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5606 l_is_temp || init_flag,
5607 (expr2->expr_type == EXPR_VARIABLE)
5608 || scalar_to_array, dealloc);
5609 gfc_add_expr_to_block (&body, tmp);
5611 if (lss == gfc_ss_terminator)
5613 /* Use the scalar assignment as is. */
5614 gfc_add_block_to_block (&block, &body);
5618 gcc_assert (lse.ss == gfc_ss_terminator
5619 && rse.ss == gfc_ss_terminator);
5623 gfc_trans_scalarized_loop_boundary (&loop, &body);
5625 /* We need to copy the temporary to the actual lhs. */
5626 gfc_init_se (&lse, NULL);
5627 gfc_init_se (&rse, NULL);
5628 gfc_copy_loopinfo_to_se (&lse, &loop);
5629 gfc_copy_loopinfo_to_se (&rse, &loop);
5631 rse.ss = loop.temp_ss;
5634 gfc_conv_tmp_array_ref (&rse);
5635 gfc_advance_se_ss_chain (&rse);
5636 gfc_conv_expr (&lse, expr1);
5638 gcc_assert (lse.ss == gfc_ss_terminator
5639 && rse.ss == gfc_ss_terminator);
5641 if (expr2->ts.type == BT_CHARACTER)
5642 rse.string_length = string_length;
5644 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5645 false, false, dealloc);
5646 gfc_add_expr_to_block (&body, tmp);
5649 /* Generate the copying loops. */
5650 gfc_trans_scalarizing_loops (&loop, &body);
5652 /* Wrap the whole thing up. */
5653 gfc_add_block_to_block (&block, &loop.pre);
5654 gfc_add_block_to_block (&block, &loop.post);
5656 gfc_cleanup_loop (&loop);
5659 return gfc_finish_block (&block);
5663 /* Check whether EXPR is a copyable array. */
5666 copyable_array_p (gfc_expr * expr)
5668 if (expr->expr_type != EXPR_VARIABLE)
5671 /* First check it's an array. */
5672 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5675 if (!gfc_full_array_ref_p (expr->ref, NULL))
5678 /* Next check that it's of a simple enough type. */
5679 switch (expr->ts.type)
5691 return !expr->ts.u.derived->attr.alloc_comp;
5700 /* Translate an assignment. */
5703 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5708 /* Special case a single function returning an array. */
5709 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5711 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5716 /* Special case assigning an array to zero. */
5717 if (copyable_array_p (expr1)
5718 && is_zero_initializer_p (expr2))
5720 tmp = gfc_trans_zero_assign (expr1);
5725 /* Special case copying one array to another. */
5726 if (copyable_array_p (expr1)
5727 && copyable_array_p (expr2)
5728 && gfc_compare_types (&expr1->ts, &expr2->ts)
5729 && !gfc_check_dependency (expr1, expr2, 0))
5731 tmp = gfc_trans_array_copy (expr1, expr2);
5736 /* Special case initializing an array from a constant array constructor. */
5737 if (copyable_array_p (expr1)
5738 && expr2->expr_type == EXPR_ARRAY
5739 && gfc_compare_types (&expr1->ts, &expr2->ts))
5741 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5746 /* Fallback to the scalarizer to generate explicit loops. */
5747 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5751 gfc_trans_init_assign (gfc_code * code)
5753 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5757 gfc_trans_assign (gfc_code * code)
5759 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5763 /* Special case for initializing a CLASS variable on allocation.
5764 A MEMCPY is needed to copy the full data of the dynamic type,
5765 which may be different from the declared type. */
5768 gfc_trans_class_init_assign (gfc_code *code)
5774 gfc_start_block (&block);
5776 gfc_init_se (&dst, NULL);
5777 gfc_init_se (&src, NULL);
5778 gfc_add_component_ref (code->expr1, "$data");
5779 gfc_conv_expr (&dst, code->expr1);
5780 gfc_conv_expr (&src, code->expr2);
5781 gfc_add_block_to_block (&block, &src.pre);
5782 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5783 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5784 gfc_add_expr_to_block (&block, tmp);
5786 return gfc_finish_block (&block);
5790 /* Translate an assignment to a CLASS object
5791 (pointer or ordinary assignment). */
5794 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5801 gfc_start_block (&block);
5803 if (expr2->ts.type != BT_CLASS)
5805 /* Insert an additional assignment which sets the '$vptr' field. */
5806 lhs = gfc_copy_expr (expr1);
5807 gfc_add_component_ref (lhs, "$vptr");
5808 if (expr2->ts.type == BT_DERIVED)
5812 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
5814 rhs = gfc_get_expr ();
5815 rhs->expr_type = EXPR_VARIABLE;
5816 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5820 else if (expr2->expr_type == EXPR_NULL)
5821 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5825 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5826 gfc_add_expr_to_block (&block, tmp);
5828 gfc_free_expr (lhs);
5829 gfc_free_expr (rhs);
5832 /* Do the actual CLASS assignment. */
5833 if (expr2->ts.type == BT_CLASS)
5836 gfc_add_component_ref (expr1, "$data");
5838 if (op == EXEC_ASSIGN)
5839 tmp = gfc_trans_assignment (expr1, expr2, false, true);
5840 else if (op == EXEC_POINTER_ASSIGN)
5841 tmp = gfc_trans_pointer_assignment (expr1, expr2);
5845 gfc_add_expr_to_block (&block, tmp);
5847 return gfc_finish_block (&block);