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)
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 parent_decl = DECL_CONTEXT (current_function_decl);
595 if ((se->expr == parent_decl && return_value)
596 || (sym->ns && sym->ns->proc_name
598 && sym->ns->proc_name->backend_decl == parent_decl
599 && (alternate_entry || entry_master)))
604 /* Special case for assigning the return value of a function.
605 Self recursive functions must have an explicit return value. */
606 if (return_value && (se->expr == current_function_decl || parent_flag))
607 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
609 /* Similarly for alternate entry points. */
610 else if (alternate_entry
611 && (sym->ns->proc_name->backend_decl == current_function_decl
614 gfc_entry_list *el = NULL;
616 for (el = sym->ns->entries; el; el = el->next)
619 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
624 else if (entry_master
625 && (sym->ns->proc_name->backend_decl == current_function_decl
627 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
632 /* Procedure actual arguments. */
633 else if (sym->attr.flavor == FL_PROCEDURE
634 && se->expr != current_function_decl)
636 if (!sym->attr.dummy && !sym->attr.proc_pointer)
638 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
639 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
645 /* Dereference the expression, where needed. Since characters
646 are entirely different from other types, they are treated
648 if (sym->ts.type == BT_CHARACTER)
650 /* Dereference character pointer dummy arguments
652 if ((sym->attr.pointer || sym->attr.allocatable)
654 || sym->attr.function
655 || sym->attr.result))
656 se->expr = build_fold_indirect_ref_loc (input_location,
660 else if (!sym->attr.value)
662 /* Dereference non-character scalar dummy arguments. */
663 if (sym->attr.dummy && !sym->attr.dimension)
664 se->expr = build_fold_indirect_ref_loc (input_location,
667 /* Dereference scalar hidden result. */
668 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
669 && (sym->attr.function || sym->attr.result)
670 && !sym->attr.dimension && !sym->attr.pointer
671 && !sym->attr.always_explicit)
672 se->expr = build_fold_indirect_ref_loc (input_location,
675 /* Dereference non-character pointer variables.
676 These must be dummies, results, or scalars. */
677 if ((sym->attr.pointer || sym->attr.allocatable
678 || gfc_is_associate_pointer (sym))
680 || sym->attr.function
682 || !sym->attr.dimension))
683 se->expr = build_fold_indirect_ref_loc (input_location,
690 /* For character variables, also get the length. */
691 if (sym->ts.type == BT_CHARACTER)
693 /* If the character length of an entry isn't set, get the length from
694 the master function instead. */
695 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
696 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
698 se->string_length = sym->ts.u.cl->backend_decl;
699 gcc_assert (se->string_length);
707 /* Return the descriptor if that's what we want and this is an array
708 section reference. */
709 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
711 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
712 /* Return the descriptor for array pointers and allocations. */
714 && ref->next == NULL && (se->descriptor_only))
717 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
718 /* Return a pointer to an element. */
722 if (ref->u.c.sym->attr.extension)
723 conv_parent_component_references (se, ref);
725 gfc_conv_component_ref (se, ref);
729 gfc_conv_substring (se, ref, expr->ts.kind,
730 expr->symtree->name, &expr->where);
739 /* Pointer assignment, allocation or pass by reference. Arrays are handled
741 if (se->want_pointer)
743 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
744 gfc_conv_string_parameter (se);
746 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
751 /* Unary ops are easy... Or they would be if ! was a valid op. */
754 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
759 gcc_assert (expr->ts.type != BT_CHARACTER);
760 /* Initialize the operand. */
761 gfc_init_se (&operand, se);
762 gfc_conv_expr_val (&operand, expr->value.op.op1);
763 gfc_add_block_to_block (&se->pre, &operand.pre);
765 type = gfc_typenode_for_spec (&expr->ts);
767 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
768 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
769 All other unary operators have an equivalent GIMPLE unary operator. */
770 if (code == TRUTH_NOT_EXPR)
771 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
772 build_int_cst (type, 0));
774 se->expr = fold_build1 (code, type, operand.expr);
778 /* Expand power operator to optimal multiplications when a value is raised
779 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
780 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
781 Programming", 3rd Edition, 1998. */
783 /* This code is mostly duplicated from expand_powi in the backend.
784 We establish the "optimal power tree" lookup table with the defined size.
785 The items in the table are the exponents used to calculate the index
786 exponents. Any integer n less than the value can get an "addition chain",
787 with the first node being one. */
788 #define POWI_TABLE_SIZE 256
790 /* The table is from builtins.c. */
791 static const unsigned char powi_table[POWI_TABLE_SIZE] =
793 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
794 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
795 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
796 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
797 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
798 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
799 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
800 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
801 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
802 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
803 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
804 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
805 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
806 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
807 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
808 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
809 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
810 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
811 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
812 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
813 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
814 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
815 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
816 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
817 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
818 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
819 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
820 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
821 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
822 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
823 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
824 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
827 /* If n is larger than lookup table's max index, we use the "window
829 #define POWI_WINDOW_SIZE 3
831 /* Recursive function to expand the power operator. The temporary
832 values are put in tmpvar. The function returns tmpvar[1] ** n. */
834 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
841 if (n < POWI_TABLE_SIZE)
846 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
847 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
851 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
852 op0 = gfc_conv_powi (se, n - digit, tmpvar);
853 op1 = gfc_conv_powi (se, digit, tmpvar);
857 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
861 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
862 tmp = gfc_evaluate_now (tmp, &se->pre);
864 if (n < POWI_TABLE_SIZE)
871 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
872 return 1. Else return 0 and a call to runtime library functions
873 will have to be built. */
875 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
880 tree vartmp[POWI_TABLE_SIZE];
882 unsigned HOST_WIDE_INT n;
885 /* If exponent is too large, we won't expand it anyway, so don't bother
886 with large integer values. */
887 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
890 m = double_int_to_shwi (TREE_INT_CST (rhs));
891 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
892 of the asymmetric range of the integer type. */
893 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
895 type = TREE_TYPE (lhs);
896 sgn = tree_int_cst_sgn (rhs);
898 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
899 || optimize_size) && (m > 2 || m < -1))
905 se->expr = gfc_build_const (type, integer_one_node);
909 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
910 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
912 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
913 lhs, build_int_cst (TREE_TYPE (lhs), -1));
914 cond = fold_build2 (EQ_EXPR, boolean_type_node,
915 lhs, build_int_cst (TREE_TYPE (lhs), 1));
918 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
921 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
922 se->expr = fold_build3 (COND_EXPR, type,
923 tmp, build_int_cst (type, 1),
924 build_int_cst (type, 0));
928 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
929 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
930 build_int_cst (type, 0));
931 se->expr = fold_build3 (COND_EXPR, type,
932 cond, build_int_cst (type, 1), tmp);
936 memset (vartmp, 0, sizeof (vartmp));
940 tmp = gfc_build_const (type, integer_one_node);
941 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
944 se->expr = gfc_conv_powi (se, n, vartmp);
950 /* Power op (**). Constant integer exponent has special handling. */
953 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
955 tree gfc_int4_type_node;
962 gfc_init_se (&lse, se);
963 gfc_conv_expr_val (&lse, expr->value.op.op1);
964 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
965 gfc_add_block_to_block (&se->pre, &lse.pre);
967 gfc_init_se (&rse, se);
968 gfc_conv_expr_val (&rse, expr->value.op.op2);
969 gfc_add_block_to_block (&se->pre, &rse.pre);
971 if (expr->value.op.op2->ts.type == BT_INTEGER
972 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
973 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
976 gfc_int4_type_node = gfc_get_int_type (4);
978 kind = expr->value.op.op1->ts.kind;
979 switch (expr->value.op.op2->ts.type)
982 ikind = expr->value.op.op2->ts.kind;
987 rse.expr = convert (gfc_int4_type_node, rse.expr);
1009 if (expr->value.op.op1->ts.type == BT_INTEGER)
1010 lse.expr = convert (gfc_int4_type_node, lse.expr);
1035 switch (expr->value.op.op1->ts.type)
1038 if (kind == 3) /* Case 16 was not handled properly above. */
1040 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1044 /* Use builtins for real ** int4. */
1050 fndecl = built_in_decls[BUILT_IN_POWIF];
1054 fndecl = built_in_decls[BUILT_IN_POWI];
1059 fndecl = built_in_decls[BUILT_IN_POWIL];
1067 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1071 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1083 fndecl = built_in_decls[BUILT_IN_POWF];
1086 fndecl = built_in_decls[BUILT_IN_POW];
1090 fndecl = built_in_decls[BUILT_IN_POWL];
1101 fndecl = built_in_decls[BUILT_IN_CPOWF];
1104 fndecl = built_in_decls[BUILT_IN_CPOW];
1108 fndecl = built_in_decls[BUILT_IN_CPOWL];
1120 se->expr = build_call_expr_loc (input_location,
1121 fndecl, 2, lse.expr, rse.expr);
1125 /* Generate code to allocate a string temporary. */
1128 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1133 if (gfc_can_put_var_on_stack (len))
1135 /* Create a temporary variable to hold the result. */
1136 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1137 build_int_cst (gfc_charlen_type_node, 1));
1138 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1140 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1141 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1143 tmp = build_array_type (TREE_TYPE (type), tmp);
1145 var = gfc_create_var (tmp, "str");
1146 var = gfc_build_addr_expr (type, var);
1150 /* Allocate a temporary to hold the result. */
1151 var = gfc_create_var (type, "pstr");
1152 tmp = gfc_call_malloc (&se->pre, type,
1153 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1154 fold_convert (TREE_TYPE (len),
1155 TYPE_SIZE (type))));
1156 gfc_add_modify (&se->pre, var, tmp);
1158 /* Free the temporary afterwards. */
1159 tmp = gfc_call_free (convert (pvoid_type_node, var));
1160 gfc_add_expr_to_block (&se->post, tmp);
1167 /* Handle a string concatenation operation. A temporary will be allocated to
1171 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1174 tree len, type, var, tmp, fndecl;
1176 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1177 && expr->value.op.op2->ts.type == BT_CHARACTER);
1178 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1180 gfc_init_se (&lse, se);
1181 gfc_conv_expr (&lse, expr->value.op.op1);
1182 gfc_conv_string_parameter (&lse);
1183 gfc_init_se (&rse, se);
1184 gfc_conv_expr (&rse, expr->value.op.op2);
1185 gfc_conv_string_parameter (&rse);
1187 gfc_add_block_to_block (&se->pre, &lse.pre);
1188 gfc_add_block_to_block (&se->pre, &rse.pre);
1190 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1191 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1192 if (len == NULL_TREE)
1194 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1195 lse.string_length, rse.string_length);
1198 type = build_pointer_type (type);
1200 var = gfc_conv_string_tmp (se, type, len);
1202 /* Do the actual concatenation. */
1203 if (expr->ts.kind == 1)
1204 fndecl = gfor_fndecl_concat_string;
1205 else if (expr->ts.kind == 4)
1206 fndecl = gfor_fndecl_concat_string_char4;
1210 tmp = build_call_expr_loc (input_location,
1211 fndecl, 6, len, var, lse.string_length, lse.expr,
1212 rse.string_length, rse.expr);
1213 gfc_add_expr_to_block (&se->pre, tmp);
1215 /* Add the cleanup for the operands. */
1216 gfc_add_block_to_block (&se->pre, &rse.post);
1217 gfc_add_block_to_block (&se->pre, &lse.post);
1220 se->string_length = len;
1223 /* Translates an op expression. Common (binary) cases are handled by this
1224 function, others are passed on. Recursion is used in either case.
1225 We use the fact that (op1.ts == op2.ts) (except for the power
1227 Operators need no special handling for scalarized expressions as long as
1228 they call gfc_conv_simple_val to get their operands.
1229 Character strings get special handling. */
1232 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1234 enum tree_code code;
1243 switch (expr->value.op.op)
1245 case INTRINSIC_PARENTHESES:
1246 if ((expr->ts.type == BT_REAL
1247 || expr->ts.type == BT_COMPLEX)
1248 && gfc_option.flag_protect_parens)
1250 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1251 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1256 case INTRINSIC_UPLUS:
1257 gfc_conv_expr (se, expr->value.op.op1);
1260 case INTRINSIC_UMINUS:
1261 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1265 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1268 case INTRINSIC_PLUS:
1272 case INTRINSIC_MINUS:
1276 case INTRINSIC_TIMES:
1280 case INTRINSIC_DIVIDE:
1281 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1282 an integer, we must round towards zero, so we use a
1284 if (expr->ts.type == BT_INTEGER)
1285 code = TRUNC_DIV_EXPR;
1290 case INTRINSIC_POWER:
1291 gfc_conv_power_op (se, expr);
1294 case INTRINSIC_CONCAT:
1295 gfc_conv_concat_op (se, expr);
1299 code = TRUTH_ANDIF_EXPR;
1304 code = TRUTH_ORIF_EXPR;
1308 /* EQV and NEQV only work on logicals, but since we represent them
1309 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1311 case INTRINSIC_EQ_OS:
1319 case INTRINSIC_NE_OS:
1320 case INTRINSIC_NEQV:
1327 case INTRINSIC_GT_OS:
1334 case INTRINSIC_GE_OS:
1341 case INTRINSIC_LT_OS:
1348 case INTRINSIC_LE_OS:
1354 case INTRINSIC_USER:
1355 case INTRINSIC_ASSIGN:
1356 /* These should be converted into function calls by the frontend. */
1360 fatal_error ("Unknown intrinsic op");
1364 /* The only exception to this is **, which is handled separately anyway. */
1365 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1367 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1371 gfc_init_se (&lse, se);
1372 gfc_conv_expr (&lse, expr->value.op.op1);
1373 gfc_add_block_to_block (&se->pre, &lse.pre);
1376 gfc_init_se (&rse, se);
1377 gfc_conv_expr (&rse, expr->value.op.op2);
1378 gfc_add_block_to_block (&se->pre, &rse.pre);
1382 gfc_conv_string_parameter (&lse);
1383 gfc_conv_string_parameter (&rse);
1385 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1386 rse.string_length, rse.expr,
1387 expr->value.op.op1->ts.kind,
1389 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1390 gfc_add_block_to_block (&lse.post, &rse.post);
1393 type = gfc_typenode_for_spec (&expr->ts);
1397 /* The result of logical ops is always boolean_type_node. */
1398 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1399 se->expr = convert (type, tmp);
1402 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1404 /* Add the post blocks. */
1405 gfc_add_block_to_block (&se->post, &rse.post);
1406 gfc_add_block_to_block (&se->post, &lse.post);
1409 /* If a string's length is one, we convert it to a single character. */
1412 gfc_string_to_single_character (tree len, tree str, int kind)
1414 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1416 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1419 if (TREE_INT_CST_LOW (len) == 1)
1421 str = fold_convert (gfc_get_pchar_type (kind), str);
1422 return build_fold_indirect_ref_loc (input_location, str);
1426 && TREE_CODE (str) == ADDR_EXPR
1427 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1428 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1429 && array_ref_low_bound (TREE_OPERAND (str, 0))
1430 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1431 && TREE_INT_CST_LOW (len) > 1
1432 && TREE_INT_CST_LOW (len)
1433 == (unsigned HOST_WIDE_INT)
1434 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1436 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1437 ret = build_fold_indirect_ref_loc (input_location, ret);
1438 if (TREE_CODE (ret) == INTEGER_CST)
1440 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1441 int i, length = TREE_STRING_LENGTH (string_cst);
1442 const char *ptr = TREE_STRING_POINTER (string_cst);
1444 for (i = 1; i < length; i++)
1457 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1460 if (sym->backend_decl)
1462 /* This becomes the nominal_type in
1463 function.c:assign_parm_find_data_types. */
1464 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1465 /* This becomes the passed_type in
1466 function.c:assign_parm_find_data_types. C promotes char to
1467 integer for argument passing. */
1468 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1470 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1475 /* If we have a constant character expression, make it into an
1477 if ((*expr)->expr_type == EXPR_CONSTANT)
1482 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1483 (int)(*expr)->value.character.string[0]);
1484 if ((*expr)->ts.kind != gfc_c_int_kind)
1486 /* The expr needs to be compatible with a C int. If the
1487 conversion fails, then the 2 causes an ICE. */
1488 ts.type = BT_INTEGER;
1489 ts.kind = gfc_c_int_kind;
1490 gfc_convert_type (*expr, &ts, 2);
1493 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1495 if ((*expr)->ref == NULL)
1497 se->expr = gfc_string_to_single_character
1498 (build_int_cst (integer_type_node, 1),
1499 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1501 ((*expr)->symtree->n.sym)),
1506 gfc_conv_variable (se, *expr);
1507 se->expr = gfc_string_to_single_character
1508 (build_int_cst (integer_type_node, 1),
1509 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1517 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1518 if STR is a string literal, otherwise return -1. */
1521 gfc_optimize_len_trim (tree len, tree str, int kind)
1524 && TREE_CODE (str) == ADDR_EXPR
1525 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1526 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1527 && array_ref_low_bound (TREE_OPERAND (str, 0))
1528 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1529 && TREE_INT_CST_LOW (len) >= 1
1530 && TREE_INT_CST_LOW (len)
1531 == (unsigned HOST_WIDE_INT)
1532 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1534 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1535 folded = build_fold_indirect_ref_loc (input_location, folded);
1536 if (TREE_CODE (folded) == INTEGER_CST)
1538 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1539 int length = TREE_STRING_LENGTH (string_cst);
1540 const char *ptr = TREE_STRING_POINTER (string_cst);
1542 for (; length > 0; length--)
1543 if (ptr[length - 1] != ' ')
1552 /* Compare two strings. If they are all single characters, the result is the
1553 subtraction of them. Otherwise, we build a library call. */
1556 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1557 enum tree_code code)
1563 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1564 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1566 sc1 = gfc_string_to_single_character (len1, str1, kind);
1567 sc2 = gfc_string_to_single_character (len2, str2, kind);
1569 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1571 /* Deal with single character specially. */
1572 sc1 = fold_convert (integer_type_node, sc1);
1573 sc2 = fold_convert (integer_type_node, sc2);
1574 return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1577 if ((code == EQ_EXPR || code == NE_EXPR)
1579 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1581 /* If one string is a string literal with LEN_TRIM longer
1582 than the length of the second string, the strings
1584 int len = gfc_optimize_len_trim (len1, str1, kind);
1585 if (len > 0 && compare_tree_int (len2, len) < 0)
1586 return integer_one_node;
1587 len = gfc_optimize_len_trim (len2, str2, kind);
1588 if (len > 0 && compare_tree_int (len1, len) < 0)
1589 return integer_one_node;
1592 /* Build a call for the comparison. */
1594 fndecl = gfor_fndecl_compare_string;
1596 fndecl = gfor_fndecl_compare_string_char4;
1600 return build_call_expr_loc (input_location, fndecl, 4,
1601 len1, str1, len2, str2);
1605 /* Return the backend_decl for a procedure pointer component. */
1608 get_proc_ptr_comp (gfc_expr *e)
1612 gfc_init_se (&comp_se, NULL);
1613 e2 = gfc_copy_expr (e);
1614 e2->expr_type = EXPR_VARIABLE;
1615 gfc_conv_expr (&comp_se, e2);
1617 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1622 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1626 if (gfc_is_proc_ptr_comp (expr, NULL))
1627 tmp = get_proc_ptr_comp (expr);
1628 else if (sym->attr.dummy)
1630 tmp = gfc_get_symbol_decl (sym);
1631 if (sym->attr.proc_pointer)
1632 tmp = build_fold_indirect_ref_loc (input_location,
1634 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1635 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1639 if (!sym->backend_decl)
1640 sym->backend_decl = gfc_get_extern_function_decl (sym);
1642 tmp = sym->backend_decl;
1644 if (sym->attr.cray_pointee)
1646 /* TODO - make the cray pointee a pointer to a procedure,
1647 assign the pointer to it and use it for the call. This
1649 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1650 gfc_get_symbol_decl (sym->cp_pointer));
1651 tmp = gfc_evaluate_now (tmp, &se->pre);
1654 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1656 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1657 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1664 /* Initialize MAPPING. */
1667 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1669 mapping->syms = NULL;
1670 mapping->charlens = NULL;
1674 /* Free all memory held by MAPPING (but not MAPPING itself). */
1677 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1679 gfc_interface_sym_mapping *sym;
1680 gfc_interface_sym_mapping *nextsym;
1682 gfc_charlen *nextcl;
1684 for (sym = mapping->syms; sym; sym = nextsym)
1686 nextsym = sym->next;
1687 sym->new_sym->n.sym->formal = NULL;
1688 gfc_free_symbol (sym->new_sym->n.sym);
1689 gfc_free_expr (sym->expr);
1690 gfc_free (sym->new_sym);
1693 for (cl = mapping->charlens; cl; cl = nextcl)
1696 gfc_free_expr (cl->length);
1702 /* Return a copy of gfc_charlen CL. Add the returned structure to
1703 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1705 static gfc_charlen *
1706 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1709 gfc_charlen *new_charlen;
1711 new_charlen = gfc_get_charlen ();
1712 new_charlen->next = mapping->charlens;
1713 new_charlen->length = gfc_copy_expr (cl->length);
1715 mapping->charlens = new_charlen;
1720 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1721 array variable that can be used as the actual argument for dummy
1722 argument SYM. Add any initialization code to BLOCK. PACKED is as
1723 for gfc_get_nodesc_array_type and DATA points to the first element
1724 in the passed array. */
1727 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1728 gfc_packed packed, tree data)
1733 type = gfc_typenode_for_spec (&sym->ts);
1734 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1735 !sym->attr.target && !sym->attr.pointer
1736 && !sym->attr.proc_pointer);
1738 var = gfc_create_var (type, "ifm");
1739 gfc_add_modify (block, var, fold_convert (type, data));
1745 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1746 and offset of descriptorless array type TYPE given that it has the same
1747 size as DESC. Add any set-up code to BLOCK. */
1750 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1757 offset = gfc_index_zero_node;
1758 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1760 dim = gfc_rank_cst[n];
1761 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1762 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1764 GFC_TYPE_ARRAY_LBOUND (type, n)
1765 = gfc_conv_descriptor_lbound_get (desc, dim);
1766 GFC_TYPE_ARRAY_UBOUND (type, n)
1767 = gfc_conv_descriptor_ubound_get (desc, dim);
1769 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1771 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1772 gfc_conv_descriptor_ubound_get (desc, dim),
1773 gfc_conv_descriptor_lbound_get (desc, dim));
1774 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1775 GFC_TYPE_ARRAY_LBOUND (type, n),
1777 tmp = gfc_evaluate_now (tmp, block);
1778 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1780 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1781 GFC_TYPE_ARRAY_LBOUND (type, n),
1782 GFC_TYPE_ARRAY_STRIDE (type, n));
1783 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1785 offset = gfc_evaluate_now (offset, block);
1786 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1790 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1791 in SE. The caller may still use se->expr and se->string_length after
1792 calling this function. */
1795 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1796 gfc_symbol * sym, gfc_se * se,
1799 gfc_interface_sym_mapping *sm;
1803 gfc_symbol *new_sym;
1805 gfc_symtree *new_symtree;
1807 /* Create a new symbol to represent the actual argument. */
1808 new_sym = gfc_new_symbol (sym->name, NULL);
1809 new_sym->ts = sym->ts;
1810 new_sym->as = gfc_copy_array_spec (sym->as);
1811 new_sym->attr.referenced = 1;
1812 new_sym->attr.dimension = sym->attr.dimension;
1813 new_sym->attr.contiguous = sym->attr.contiguous;
1814 new_sym->attr.codimension = sym->attr.codimension;
1815 new_sym->attr.pointer = sym->attr.pointer;
1816 new_sym->attr.allocatable = sym->attr.allocatable;
1817 new_sym->attr.flavor = sym->attr.flavor;
1818 new_sym->attr.function = sym->attr.function;
1820 /* Ensure that the interface is available and that
1821 descriptors are passed for array actual arguments. */
1822 if (sym->attr.flavor == FL_PROCEDURE)
1824 new_sym->formal = expr->symtree->n.sym->formal;
1825 new_sym->attr.always_explicit
1826 = expr->symtree->n.sym->attr.always_explicit;
1829 /* Create a fake symtree for it. */
1831 new_symtree = gfc_new_symtree (&root, sym->name);
1832 new_symtree->n.sym = new_sym;
1833 gcc_assert (new_symtree == root);
1835 /* Create a dummy->actual mapping. */
1836 sm = XCNEW (gfc_interface_sym_mapping);
1837 sm->next = mapping->syms;
1839 sm->new_sym = new_symtree;
1840 sm->expr = gfc_copy_expr (expr);
1843 /* Stabilize the argument's value. */
1844 if (!sym->attr.function && se)
1845 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1847 if (sym->ts.type == BT_CHARACTER)
1849 /* Create a copy of the dummy argument's length. */
1850 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1851 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1853 /* If the length is specified as "*", record the length that
1854 the caller is passing. We should use the callee's length
1855 in all other cases. */
1856 if (!new_sym->ts.u.cl->length && se)
1858 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1859 new_sym->ts.u.cl->backend_decl = se->string_length;
1866 /* Use the passed value as-is if the argument is a function. */
1867 if (sym->attr.flavor == FL_PROCEDURE)
1870 /* If the argument is either a string or a pointer to a string,
1871 convert it to a boundless character type. */
1872 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1874 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1875 tmp = build_pointer_type (tmp);
1876 if (sym->attr.pointer)
1877 value = build_fold_indirect_ref_loc (input_location,
1881 value = fold_convert (tmp, value);
1884 /* If the argument is a scalar, a pointer to an array or an allocatable,
1886 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1887 value = build_fold_indirect_ref_loc (input_location,
1890 /* For character(*), use the actual argument's descriptor. */
1891 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1892 value = build_fold_indirect_ref_loc (input_location,
1895 /* If the argument is an array descriptor, use it to determine
1896 information about the actual argument's shape. */
1897 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1898 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1900 /* Get the actual argument's descriptor. */
1901 desc = build_fold_indirect_ref_loc (input_location,
1904 /* Create the replacement variable. */
1905 tmp = gfc_conv_descriptor_data_get (desc);
1906 value = gfc_get_interface_mapping_array (&se->pre, sym,
1909 /* Use DESC to work out the upper bounds, strides and offset. */
1910 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1913 /* Otherwise we have a packed array. */
1914 value = gfc_get_interface_mapping_array (&se->pre, sym,
1915 PACKED_FULL, se->expr);
1917 new_sym->backend_decl = value;
1921 /* Called once all dummy argument mappings have been added to MAPPING,
1922 but before the mapping is used to evaluate expressions. Pre-evaluate
1923 the length of each argument, adding any initialization code to PRE and
1924 any finalization code to POST. */
1927 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1928 stmtblock_t * pre, stmtblock_t * post)
1930 gfc_interface_sym_mapping *sym;
1934 for (sym = mapping->syms; sym; sym = sym->next)
1935 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1936 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1938 expr = sym->new_sym->n.sym->ts.u.cl->length;
1939 gfc_apply_interface_mapping_to_expr (mapping, expr);
1940 gfc_init_se (&se, NULL);
1941 gfc_conv_expr (&se, expr);
1942 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1943 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1944 gfc_add_block_to_block (pre, &se.pre);
1945 gfc_add_block_to_block (post, &se.post);
1947 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1952 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1956 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1957 gfc_constructor_base base)
1960 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1962 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1965 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1966 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1967 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1973 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1977 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1982 for (; ref; ref = ref->next)
1986 for (n = 0; n < ref->u.ar.dimen; n++)
1988 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1989 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1990 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1992 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1999 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2000 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2006 /* Convert intrinsic function calls into result expressions. */
2009 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2017 arg1 = expr->value.function.actual->expr;
2018 if (expr->value.function.actual->next)
2019 arg2 = expr->value.function.actual->next->expr;
2023 sym = arg1->symtree->n.sym;
2025 if (sym->attr.dummy)
2030 switch (expr->value.function.isym->id)
2033 /* TODO figure out why this condition is necessary. */
2034 if (sym->attr.function
2035 && (arg1->ts.u.cl->length == NULL
2036 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2037 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2040 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2044 if (!sym->as || sym->as->rank == 0)
2047 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2049 dup = mpz_get_si (arg2->value.integer);
2054 dup = sym->as->rank;
2058 for (; d < dup; d++)
2062 if (!sym->as->upper[d] || !sym->as->lower[d])
2064 gfc_free_expr (new_expr);
2068 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2069 gfc_get_int_expr (gfc_default_integer_kind,
2071 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2073 new_expr = gfc_multiply (new_expr, tmp);
2079 case GFC_ISYM_LBOUND:
2080 case GFC_ISYM_UBOUND:
2081 /* TODO These implementations of lbound and ubound do not limit if
2082 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2084 if (!sym->as || sym->as->rank == 0)
2087 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2088 d = mpz_get_si (arg2->value.integer) - 1;
2090 /* TODO: If the need arises, this could produce an array of
2094 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2096 if (sym->as->lower[d])
2097 new_expr = gfc_copy_expr (sym->as->lower[d]);
2101 if (sym->as->upper[d])
2102 new_expr = gfc_copy_expr (sym->as->upper[d]);
2110 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2114 gfc_replace_expr (expr, new_expr);
2120 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2121 gfc_interface_mapping * mapping)
2123 gfc_formal_arglist *f;
2124 gfc_actual_arglist *actual;
2126 actual = expr->value.function.actual;
2127 f = map_expr->symtree->n.sym->formal;
2129 for (; f && actual; f = f->next, actual = actual->next)
2134 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2137 if (map_expr->symtree->n.sym->attr.dimension)
2142 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2144 for (d = 0; d < as->rank; d++)
2146 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2147 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2150 expr->value.function.esym->as = as;
2153 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2155 expr->value.function.esym->ts.u.cl->length
2156 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2158 gfc_apply_interface_mapping_to_expr (mapping,
2159 expr->value.function.esym->ts.u.cl->length);
2164 /* EXPR is a copy of an expression that appeared in the interface
2165 associated with MAPPING. Walk it recursively looking for references to
2166 dummy arguments that MAPPING maps to actual arguments. Replace each such
2167 reference with a reference to the associated actual argument. */
2170 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2173 gfc_interface_sym_mapping *sym;
2174 gfc_actual_arglist *actual;
2179 /* Copying an expression does not copy its length, so do that here. */
2180 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2182 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2183 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2186 /* Apply the mapping to any references. */
2187 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2189 /* ...and to the expression's symbol, if it has one. */
2190 /* TODO Find out why the condition on expr->symtree had to be moved into
2191 the loop rather than being outside it, as originally. */
2192 for (sym = mapping->syms; sym; sym = sym->next)
2193 if (expr->symtree && sym->old == expr->symtree->n.sym)
2195 if (sym->new_sym->n.sym->backend_decl)
2196 expr->symtree = sym->new_sym;
2198 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2201 /* ...and to subexpressions in expr->value. */
2202 switch (expr->expr_type)
2207 case EXPR_SUBSTRING:
2211 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2212 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2216 for (actual = expr->value.function.actual; actual; actual = actual->next)
2217 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2219 if (expr->value.function.esym == NULL
2220 && expr->value.function.isym != NULL
2221 && expr->value.function.actual->expr->symtree
2222 && gfc_map_intrinsic_function (expr, mapping))
2225 for (sym = mapping->syms; sym; sym = sym->next)
2226 if (sym->old == expr->value.function.esym)
2228 expr->value.function.esym = sym->new_sym->n.sym;
2229 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2230 expr->value.function.esym->result = sym->new_sym->n.sym;
2235 case EXPR_STRUCTURE:
2236 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2249 /* Evaluate interface expression EXPR using MAPPING. Store the result
2253 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2254 gfc_se * se, gfc_expr * expr)
2256 expr = gfc_copy_expr (expr);
2257 gfc_apply_interface_mapping_to_expr (mapping, expr);
2258 gfc_conv_expr (se, expr);
2259 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2260 gfc_free_expr (expr);
2264 /* Returns a reference to a temporary array into which a component of
2265 an actual argument derived type array is copied and then returned
2266 after the function call. */
2268 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2269 sym_intent intent, bool formal_ptr)
2287 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2289 gfc_init_se (&lse, NULL);
2290 gfc_init_se (&rse, NULL);
2292 /* Walk the argument expression. */
2293 rss = gfc_walk_expr (expr);
2295 gcc_assert (rss != gfc_ss_terminator);
2297 /* Initialize the scalarizer. */
2298 gfc_init_loopinfo (&loop);
2299 gfc_add_ss_to_loop (&loop, rss);
2301 /* Calculate the bounds of the scalarization. */
2302 gfc_conv_ss_startstride (&loop);
2304 /* Build an ss for the temporary. */
2305 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2306 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2308 base_type = gfc_typenode_for_spec (&expr->ts);
2309 if (GFC_ARRAY_TYPE_P (base_type)
2310 || GFC_DESCRIPTOR_TYPE_P (base_type))
2311 base_type = gfc_get_element_type (base_type);
2313 loop.temp_ss = gfc_get_ss ();;
2314 loop.temp_ss->type = GFC_SS_TEMP;
2315 loop.temp_ss->data.temp.type = base_type;
2317 if (expr->ts.type == BT_CHARACTER)
2318 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2320 loop.temp_ss->string_length = NULL;
2322 parmse->string_length = loop.temp_ss->string_length;
2323 loop.temp_ss->data.temp.dimen = loop.dimen;
2324 loop.temp_ss->next = gfc_ss_terminator;
2326 /* Associate the SS with the loop. */
2327 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2329 /* Setup the scalarizing loops. */
2330 gfc_conv_loop_setup (&loop, &expr->where);
2332 /* Pass the temporary descriptor back to the caller. */
2333 info = &loop.temp_ss->data.info;
2334 parmse->expr = info->descriptor;
2336 /* Setup the gfc_se structures. */
2337 gfc_copy_loopinfo_to_se (&lse, &loop);
2338 gfc_copy_loopinfo_to_se (&rse, &loop);
2341 lse.ss = loop.temp_ss;
2342 gfc_mark_ss_chain_used (rss, 1);
2343 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2345 /* Start the scalarized loop body. */
2346 gfc_start_scalarized_body (&loop, &body);
2348 /* Translate the expression. */
2349 gfc_conv_expr (&rse, expr);
2351 gfc_conv_tmp_array_ref (&lse);
2352 gfc_advance_se_ss_chain (&lse);
2354 if (intent != INTENT_OUT)
2356 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2357 gfc_add_expr_to_block (&body, tmp);
2358 gcc_assert (rse.ss == gfc_ss_terminator);
2359 gfc_trans_scalarizing_loops (&loop, &body);
2363 /* Make sure that the temporary declaration survives by merging
2364 all the loop declarations into the current context. */
2365 for (n = 0; n < loop.dimen; n++)
2367 gfc_merge_block_scope (&body);
2368 body = loop.code[loop.order[n]];
2370 gfc_merge_block_scope (&body);
2373 /* Add the post block after the second loop, so that any
2374 freeing of allocated memory is done at the right time. */
2375 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2377 /**********Copy the temporary back again.*********/
2379 gfc_init_se (&lse, NULL);
2380 gfc_init_se (&rse, NULL);
2382 /* Walk the argument expression. */
2383 lss = gfc_walk_expr (expr);
2384 rse.ss = loop.temp_ss;
2387 /* Initialize the scalarizer. */
2388 gfc_init_loopinfo (&loop2);
2389 gfc_add_ss_to_loop (&loop2, lss);
2391 /* Calculate the bounds of the scalarization. */
2392 gfc_conv_ss_startstride (&loop2);
2394 /* Setup the scalarizing loops. */
2395 gfc_conv_loop_setup (&loop2, &expr->where);
2397 gfc_copy_loopinfo_to_se (&lse, &loop2);
2398 gfc_copy_loopinfo_to_se (&rse, &loop2);
2400 gfc_mark_ss_chain_used (lss, 1);
2401 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2403 /* Declare the variable to hold the temporary offset and start the
2404 scalarized loop body. */
2405 offset = gfc_create_var (gfc_array_index_type, NULL);
2406 gfc_start_scalarized_body (&loop2, &body);
2408 /* Build the offsets for the temporary from the loop variables. The
2409 temporary array has lbounds of zero and strides of one in all
2410 dimensions, so this is very simple. The offset is only computed
2411 outside the innermost loop, so the overall transfer could be
2412 optimized further. */
2413 info = &rse.ss->data.info;
2414 dimen = info->dimen;
2416 tmp_index = gfc_index_zero_node;
2417 for (n = dimen - 1; n > 0; n--)
2420 tmp = rse.loop->loopvar[n];
2421 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2422 tmp, rse.loop->from[n]);
2423 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2426 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2427 rse.loop->to[n-1], rse.loop->from[n-1]);
2428 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2429 tmp_str, gfc_index_one_node);
2431 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2435 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2436 tmp_index, rse.loop->from[0]);
2437 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2439 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2440 rse.loop->loopvar[0], offset);
2442 /* Now use the offset for the reference. */
2443 tmp = build_fold_indirect_ref_loc (input_location,
2445 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2447 if (expr->ts.type == BT_CHARACTER)
2448 rse.string_length = expr->ts.u.cl->backend_decl;
2450 gfc_conv_expr (&lse, expr);
2452 gcc_assert (lse.ss == gfc_ss_terminator);
2454 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2455 gfc_add_expr_to_block (&body, tmp);
2457 /* Generate the copying loops. */
2458 gfc_trans_scalarizing_loops (&loop2, &body);
2460 /* Wrap the whole thing up by adding the second loop to the post-block
2461 and following it by the post-block of the first loop. In this way,
2462 if the temporary needs freeing, it is done after use! */
2463 if (intent != INTENT_IN)
2465 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2466 gfc_add_block_to_block (&parmse->post, &loop2.post);
2469 gfc_add_block_to_block (&parmse->post, &loop.post);
2471 gfc_cleanup_loop (&loop);
2472 gfc_cleanup_loop (&loop2);
2474 /* Pass the string length to the argument expression. */
2475 if (expr->ts.type == BT_CHARACTER)
2476 parmse->string_length = expr->ts.u.cl->backend_decl;
2478 /* Determine the offset for pointer formal arguments and set the
2482 size = gfc_index_one_node;
2483 offset = gfc_index_zero_node;
2484 for (n = 0; n < dimen; n++)
2486 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2488 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2489 tmp, gfc_index_one_node);
2490 gfc_conv_descriptor_ubound_set (&parmse->pre,
2494 gfc_conv_descriptor_lbound_set (&parmse->pre,
2497 gfc_index_one_node);
2498 size = gfc_evaluate_now (size, &parmse->pre);
2499 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2501 offset = gfc_evaluate_now (offset, &parmse->pre);
2502 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2503 rse.loop->to[n], rse.loop->from[n]);
2504 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2505 tmp, gfc_index_one_node);
2506 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2510 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2514 /* We want either the address for the data or the address of the descriptor,
2515 depending on the mode of passing array arguments. */
2517 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2519 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2525 /* Generate the code for argument list functions. */
2528 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2530 /* Pass by value for g77 %VAL(arg), pass the address
2531 indirectly for %LOC, else by reference. Thus %REF
2532 is a "do-nothing" and %LOC is the same as an F95
2534 if (strncmp (name, "%VAL", 4) == 0)
2535 gfc_conv_expr (se, expr);
2536 else if (strncmp (name, "%LOC", 4) == 0)
2538 gfc_conv_expr_reference (se, expr);
2539 se->expr = gfc_build_addr_expr (NULL, se->expr);
2541 else if (strncmp (name, "%REF", 4) == 0)
2542 gfc_conv_expr_reference (se, expr);
2544 gfc_error ("Unknown argument list function at %L", &expr->where);
2548 /* Takes a derived type expression and returns the address of a temporary
2549 class object of the 'declared' type. */
2551 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2552 gfc_typespec class_ts)
2556 gfc_symbol *declared = class_ts.u.derived;
2562 /* The derived type needs to be converted to a temporary
2564 tmp = gfc_typenode_for_spec (&class_ts);
2565 var = gfc_create_var (tmp, "class");
2568 cmp = gfc_find_component (declared, "$vptr", true, true);
2569 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2570 var, cmp->backend_decl, NULL_TREE);
2572 /* Remember the vtab corresponds to the derived type
2573 not to the class declared type. */
2574 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2576 gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
2577 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2578 gfc_add_modify (&parmse->pre, ctree,
2579 fold_convert (TREE_TYPE (ctree), tmp));
2581 /* Now set the data field. */
2582 cmp = gfc_find_component (declared, "$data", true, true);
2583 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2584 var, cmp->backend_decl, NULL_TREE);
2585 ss = gfc_walk_expr (e);
2586 if (ss == gfc_ss_terminator)
2589 gfc_conv_expr_reference (parmse, e);
2590 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2591 gfc_add_modify (&parmse->pre, ctree, tmp);
2596 gfc_conv_expr (parmse, e);
2597 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2600 /* Pass the address of the class object. */
2601 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2605 /* The following routine generates code for the intrinsic
2606 procedures from the ISO_C_BINDING module:
2608 * C_FUNLOC (function)
2609 * C_F_POINTER (subroutine)
2610 * C_F_PROCPOINTER (subroutine)
2611 * C_ASSOCIATED (function)
2612 One exception which is not handled here is C_F_POINTER with non-scalar
2613 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2616 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2617 gfc_actual_arglist * arg)
2622 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2624 if (arg->expr->rank == 0)
2625 gfc_conv_expr_reference (se, arg->expr);
2629 /* This is really the actual arg because no formal arglist is
2630 created for C_LOC. */
2631 fsym = arg->expr->symtree->n.sym;
2633 /* We should want it to do g77 calling convention. */
2635 && !(fsym->attr.pointer || fsym->attr.allocatable)
2636 && fsym->as->type != AS_ASSUMED_SHAPE;
2637 f = f || !sym->attr.always_explicit;
2639 argss = gfc_walk_expr (arg->expr);
2640 gfc_conv_array_parameter (se, arg->expr, argss, f,
2644 /* TODO -- the following two lines shouldn't be necessary, but if
2645 they're removed, a bug is exposed later in the code path.
2646 This workaround was thus introduced, but will have to be
2647 removed; please see PR 35150 for details about the issue. */
2648 se->expr = convert (pvoid_type_node, se->expr);
2649 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2653 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2655 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2656 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2657 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2658 gfc_conv_expr_reference (se, arg->expr);
2662 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2663 && arg->next->expr->rank == 0)
2664 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2666 /* Convert c_f_pointer if fptr is a scalar
2667 and convert c_f_procpointer. */
2671 gfc_init_se (&cptrse, NULL);
2672 gfc_conv_expr (&cptrse, arg->expr);
2673 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2674 gfc_add_block_to_block (&se->post, &cptrse.post);
2676 gfc_init_se (&fptrse, NULL);
2677 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2678 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2679 fptrse.want_pointer = 1;
2681 gfc_conv_expr (&fptrse, arg->next->expr);
2682 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2683 gfc_add_block_to_block (&se->post, &fptrse.post);
2685 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2686 && arg->next->expr->symtree->n.sym->attr.dummy)
2687 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2690 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2692 fold_convert (TREE_TYPE (fptrse.expr),
2697 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2702 /* Build the addr_expr for the first argument. The argument is
2703 already an *address* so we don't need to set want_pointer in
2705 gfc_init_se (&arg1se, NULL);
2706 gfc_conv_expr (&arg1se, arg->expr);
2707 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2708 gfc_add_block_to_block (&se->post, &arg1se.post);
2710 /* See if we were given two arguments. */
2711 if (arg->next == NULL)
2712 /* Only given one arg so generate a null and do a
2713 not-equal comparison against the first arg. */
2714 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2715 fold_convert (TREE_TYPE (arg1se.expr),
2716 null_pointer_node));
2722 /* Given two arguments so build the arg2se from second arg. */
2723 gfc_init_se (&arg2se, NULL);
2724 gfc_conv_expr (&arg2se, arg->next->expr);
2725 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2726 gfc_add_block_to_block (&se->post, &arg2se.post);
2728 /* Generate test to compare that the two args are equal. */
2729 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2730 arg1se.expr, arg2se.expr);
2731 /* Generate test to ensure that the first arg is not null. */
2732 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2733 arg1se.expr, null_pointer_node);
2735 /* Finally, the generated test must check that both arg1 is not
2736 NULL and that it is equal to the second arg. */
2737 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2738 not_null_expr, eq_expr);
2744 /* Nothing was done. */
2748 /* Generate code for a procedure call. Note can return se->post != NULL.
2749 If se->direct_byref is set then se->expr contains the return parameter.
2750 Return nonzero, if the call has alternate specifiers.
2751 'expr' is only needed for procedure pointer components. */
2754 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2755 gfc_actual_arglist * arg, gfc_expr * expr,
2756 VEC(tree,gc) *append_args)
2758 gfc_interface_mapping mapping;
2759 VEC(tree,gc) *arglist;
2760 VEC(tree,gc) *retargs;
2771 VEC(tree,gc) *stringargs;
2773 gfc_formal_arglist *formal;
2774 int has_alternate_specifier = 0;
2775 bool need_interface_mapping;
2782 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2783 gfc_component *comp = NULL;
2793 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2794 && conv_isocbinding_procedure (se, sym, arg))
2797 gfc_is_proc_ptr_comp (expr, &comp);
2801 if (!sym->attr.elemental)
2803 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2804 if (se->ss->useflags)
2806 gcc_assert ((!comp && gfc_return_by_reference (sym)
2807 && sym->result->attr.dimension)
2808 || (comp && comp->attr.dimension));
2809 gcc_assert (se->loop != NULL);
2811 /* Access the previously obtained result. */
2812 gfc_conv_tmp_array_ref (se);
2813 gfc_advance_se_ss_chain (se);
2817 info = &se->ss->data.info;
2822 gfc_init_block (&post);
2823 gfc_init_interface_mapping (&mapping);
2826 formal = sym->formal;
2827 need_interface_mapping = sym->attr.dimension ||
2828 (sym->ts.type == BT_CHARACTER
2829 && sym->ts.u.cl->length
2830 && sym->ts.u.cl->length->expr_type
2835 formal = comp->formal;
2836 need_interface_mapping = comp->attr.dimension ||
2837 (comp->ts.type == BT_CHARACTER
2838 && comp->ts.u.cl->length
2839 && comp->ts.u.cl->length->expr_type
2843 /* Evaluate the arguments. */
2844 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2847 fsym = formal ? formal->sym : NULL;
2848 parm_kind = MISSING;
2852 if (se->ignore_optional)
2854 /* Some intrinsics have already been resolved to the correct
2858 else if (arg->label)
2860 has_alternate_specifier = 1;
2865 /* Pass a NULL pointer for an absent arg. */
2866 gfc_init_se (&parmse, NULL);
2867 parmse.expr = null_pointer_node;
2868 if (arg->missing_arg_type == BT_CHARACTER)
2869 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2872 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2874 /* Pass a NULL pointer to denote an absent arg. */
2875 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2876 gfc_init_se (&parmse, NULL);
2877 parmse.expr = null_pointer_node;
2878 if (arg->missing_arg_type == BT_CHARACTER)
2879 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2881 else if (fsym && fsym->ts.type == BT_CLASS
2882 && e->ts.type == BT_DERIVED)
2884 /* The derived type needs to be converted to a temporary
2886 gfc_init_se (&parmse, se);
2887 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2889 else if (se->ss && se->ss->useflags)
2891 /* An elemental function inside a scalarized loop. */
2892 gfc_init_se (&parmse, se);
2893 gfc_conv_expr_reference (&parmse, e);
2894 parm_kind = ELEMENTAL;
2898 /* A scalar or transformational function. */
2899 gfc_init_se (&parmse, NULL);
2900 argss = gfc_walk_expr (e);
2902 if (argss == gfc_ss_terminator)
2904 if (e->expr_type == EXPR_VARIABLE
2905 && e->symtree->n.sym->attr.cray_pointee
2906 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2908 /* The Cray pointer needs to be converted to a pointer to
2909 a type given by the expression. */
2910 gfc_conv_expr (&parmse, e);
2911 type = build_pointer_type (TREE_TYPE (parmse.expr));
2912 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2913 parmse.expr = convert (type, tmp);
2915 else if (fsym && fsym->attr.value)
2917 if (fsym->ts.type == BT_CHARACTER
2918 && fsym->ts.is_c_interop
2919 && fsym->ns->proc_name != NULL
2920 && fsym->ns->proc_name->attr.is_bind_c)
2923 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2924 if (parmse.expr == NULL)
2925 gfc_conv_expr (&parmse, e);
2928 gfc_conv_expr (&parmse, e);
2930 else if (arg->name && arg->name[0] == '%')
2931 /* Argument list functions %VAL, %LOC and %REF are signalled
2932 through arg->name. */
2933 conv_arglist_function (&parmse, arg->expr, arg->name);
2934 else if ((e->expr_type == EXPR_FUNCTION)
2935 && ((e->value.function.esym
2936 && e->value.function.esym->result->attr.pointer)
2937 || (!e->value.function.esym
2938 && e->symtree->n.sym->attr.pointer))
2939 && fsym && fsym->attr.target)
2941 gfc_conv_expr (&parmse, e);
2942 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2944 else if (e->expr_type == EXPR_FUNCTION
2945 && e->symtree->n.sym->result
2946 && e->symtree->n.sym->result != e->symtree->n.sym
2947 && e->symtree->n.sym->result->attr.proc_pointer)
2949 /* Functions returning procedure pointers. */
2950 gfc_conv_expr (&parmse, e);
2951 if (fsym && fsym->attr.proc_pointer)
2952 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2956 gfc_conv_expr_reference (&parmse, e);
2958 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2959 allocated on entry, it must be deallocated. */
2960 if (fsym && fsym->attr.allocatable
2961 && fsym->attr.intent == INTENT_OUT)
2965 gfc_init_block (&block);
2966 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2968 gfc_add_expr_to_block (&block, tmp);
2969 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2970 parmse.expr, null_pointer_node);
2971 gfc_add_expr_to_block (&block, tmp);
2973 if (fsym->attr.optional
2974 && e->expr_type == EXPR_VARIABLE
2975 && e->symtree->n.sym->attr.optional)
2977 tmp = fold_build3 (COND_EXPR, void_type_node,
2978 gfc_conv_expr_present (e->symtree->n.sym),
2979 gfc_finish_block (&block),
2980 build_empty_stmt (input_location));
2983 tmp = gfc_finish_block (&block);
2985 gfc_add_expr_to_block (&se->pre, tmp);
2988 if (fsym && e->expr_type != EXPR_NULL
2989 && ((fsym->attr.pointer
2990 && fsym->attr.flavor != FL_PROCEDURE)
2991 || (fsym->attr.proc_pointer
2992 && !(e->expr_type == EXPR_VARIABLE
2993 && e->symtree->n.sym->attr.dummy))
2994 || (e->expr_type == EXPR_VARIABLE
2995 && gfc_is_proc_ptr_comp (e, NULL))
2996 || fsym->attr.allocatable))
2998 /* Scalar pointer dummy args require an extra level of
2999 indirection. The null pointer already contains
3000 this level of indirection. */
3001 parm_kind = SCALAR_POINTER;
3002 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3008 /* If the procedure requires an explicit interface, the actual
3009 argument is passed according to the corresponding formal
3010 argument. If the corresponding formal argument is a POINTER,
3011 ALLOCATABLE or assumed shape, we do not use g77's calling
3012 convention, and pass the address of the array descriptor
3013 instead. Otherwise we use g77's calling convention. */
3016 && !(fsym->attr.pointer || fsym->attr.allocatable)
3017 && fsym->as->type != AS_ASSUMED_SHAPE;
3019 f = f || !comp->attr.always_explicit;
3021 f = f || !sym->attr.always_explicit;
3023 if (e->expr_type == EXPR_VARIABLE
3024 && is_subref_array (e))
3025 /* The actual argument is a component reference to an
3026 array of derived types. In this case, the argument
3027 is converted to a temporary, which is passed and then
3028 written back after the procedure call. */
3029 gfc_conv_subref_array_arg (&parmse, e, f,
3030 fsym ? fsym->attr.intent : INTENT_INOUT,
3031 fsym && fsym->attr.pointer);
3033 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3036 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3037 allocated on entry, it must be deallocated. */
3038 if (fsym && fsym->attr.allocatable
3039 && fsym->attr.intent == INTENT_OUT)
3041 tmp = build_fold_indirect_ref_loc (input_location,
3043 tmp = gfc_trans_dealloc_allocated (tmp);
3044 if (fsym->attr.optional
3045 && e->expr_type == EXPR_VARIABLE
3046 && e->symtree->n.sym->attr.optional)
3047 tmp = fold_build3 (COND_EXPR, void_type_node,
3048 gfc_conv_expr_present (e->symtree->n.sym),
3049 tmp, build_empty_stmt (input_location));
3050 gfc_add_expr_to_block (&se->pre, tmp);
3055 /* The case with fsym->attr.optional is that of a user subroutine
3056 with an interface indicating an optional argument. When we call
3057 an intrinsic subroutine, however, fsym is NULL, but we might still
3058 have an optional argument, so we proceed to the substitution
3060 if (e && (fsym == NULL || fsym->attr.optional))
3062 /* If an optional argument is itself an optional dummy argument,
3063 check its presence and substitute a null if absent. This is
3064 only needed when passing an array to an elemental procedure
3065 as then array elements are accessed - or no NULL pointer is
3066 allowed and a "1" or "0" should be passed if not present.
3067 When passing a non-array-descriptor full array to a
3068 non-array-descriptor dummy, no check is needed. For
3069 array-descriptor actual to array-descriptor dummy, see
3070 PR 41911 for why a check has to be inserted.
3071 fsym == NULL is checked as intrinsics required the descriptor
3072 but do not always set fsym. */
3073 if (e->expr_type == EXPR_VARIABLE
3074 && e->symtree->n.sym->attr.optional
3075 && ((e->rank > 0 && sym->attr.elemental)
3076 || e->representation.length || e->ts.type == BT_CHARACTER
3078 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3079 || fsym->as->type == AS_DEFERRED))))
3080 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3081 e->representation.length);
3086 /* Obtain the character length of an assumed character length
3087 length procedure from the typespec. */
3088 if (fsym->ts.type == BT_CHARACTER
3089 && parmse.string_length == NULL_TREE
3090 && e->ts.type == BT_PROCEDURE
3091 && e->symtree->n.sym->ts.type == BT_CHARACTER
3092 && e->symtree->n.sym->ts.u.cl->length != NULL
3093 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3095 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3096 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3100 if (fsym && need_interface_mapping && e)
3101 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3103 gfc_add_block_to_block (&se->pre, &parmse.pre);
3104 gfc_add_block_to_block (&post, &parmse.post);
3106 /* Allocated allocatable components of derived types must be
3107 deallocated for non-variable scalars. Non-variable arrays are
3108 dealt with in trans-array.c(gfc_conv_array_parameter). */
3109 if (e && e->ts.type == BT_DERIVED
3110 && e->ts.u.derived->attr.alloc_comp
3111 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3112 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3115 tmp = build_fold_indirect_ref_loc (input_location,
3117 parm_rank = e->rank;
3125 case (SCALAR_POINTER):
3126 tmp = build_fold_indirect_ref_loc (input_location,
3131 if (e->expr_type == EXPR_OP
3132 && e->value.op.op == INTRINSIC_PARENTHESES
3133 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3136 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3137 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3138 gfc_add_expr_to_block (&se->post, local_tmp);
3141 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3143 gfc_add_expr_to_block (&se->post, tmp);
3146 /* Add argument checking of passing an unallocated/NULL actual to
3147 a nonallocatable/nonpointer dummy. */
3149 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3151 symbol_attribute *attr;
3155 if (e->expr_type == EXPR_VARIABLE)
3156 attr = &e->symtree->n.sym->attr;
3157 else if (e->expr_type == EXPR_FUNCTION)
3159 /* For intrinsic functions, the gfc_attr are not available. */
3160 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3161 goto end_pointer_check;
3163 if (e->symtree->n.sym->attr.generic)
3164 attr = &e->value.function.esym->attr;
3166 attr = &e->symtree->n.sym->result->attr;
3169 goto end_pointer_check;
3173 /* If the actual argument is an optional pointer/allocatable and
3174 the formal argument takes an nonpointer optional value,
3175 it is invalid to pass a non-present argument on, even
3176 though there is no technical reason for this in gfortran.
3177 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3178 tree present, null_ptr, type;
3180 if (attr->allocatable
3181 && (fsym == NULL || !fsym->attr.allocatable))
3182 asprintf (&msg, "Allocatable actual argument '%s' is not "
3183 "allocated or not present", e->symtree->n.sym->name);
3184 else if (attr->pointer
3185 && (fsym == NULL || !fsym->attr.pointer))
3186 asprintf (&msg, "Pointer actual argument '%s' is not "
3187 "associated or not present",
3188 e->symtree->n.sym->name);
3189 else if (attr->proc_pointer
3190 && (fsym == NULL || !fsym->attr.proc_pointer))
3191 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3192 "associated or not present",
3193 e->symtree->n.sym->name);
3195 goto end_pointer_check;
3197 present = gfc_conv_expr_present (e->symtree->n.sym);
3198 type = TREE_TYPE (present);
3199 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3200 fold_convert (type, null_pointer_node));
3201 type = TREE_TYPE (parmse.expr);
3202 null_ptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3203 fold_convert (type, null_pointer_node));
3204 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3209 if (attr->allocatable
3210 && (fsym == NULL || !fsym->attr.allocatable))
3211 asprintf (&msg, "Allocatable actual argument '%s' is not "
3212 "allocated", e->symtree->n.sym->name);
3213 else if (attr->pointer
3214 && (fsym == NULL || !fsym->attr.pointer))
3215 asprintf (&msg, "Pointer actual argument '%s' is not "
3216 "associated", e->symtree->n.sym->name);
3217 else if (attr->proc_pointer
3218 && (fsym == NULL || !fsym->attr.proc_pointer))
3219 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3220 "associated", e->symtree->n.sym->name);
3222 goto end_pointer_check;
3225 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3226 fold_convert (TREE_TYPE (parmse.expr),
3227 null_pointer_node));
3230 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3237 /* Character strings are passed as two parameters, a length and a
3238 pointer - except for Bind(c) which only passes the pointer. */
3239 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3240 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3242 VEC_safe_push (tree, gc, arglist, parmse.expr);
3244 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3251 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3252 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3253 else if (ts.type == BT_CHARACTER)
3255 if (ts.u.cl->length == NULL)
3257 /* Assumed character length results are not allowed by 5.1.1.5 of the
3258 standard and are trapped in resolve.c; except in the case of SPREAD
3259 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3260 we take the character length of the first argument for the result.
3261 For dummies, we have to look through the formal argument list for
3262 this function and use the character length found there.*/
3263 if (!sym->attr.dummy)
3264 cl.backend_decl = VEC_index (tree, stringargs, 0);
3267 formal = sym->ns->proc_name->formal;
3268 for (; formal; formal = formal->next)
3269 if (strcmp (formal->sym->name, sym->name) == 0)
3270 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3277 /* Calculate the length of the returned string. */
3278 gfc_init_se (&parmse, NULL);
3279 if (need_interface_mapping)
3280 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3282 gfc_conv_expr (&parmse, ts.u.cl->length);
3283 gfc_add_block_to_block (&se->pre, &parmse.pre);
3284 gfc_add_block_to_block (&se->post, &parmse.post);
3286 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3287 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3288 build_int_cst (gfc_charlen_type_node, 0));
3289 cl.backend_decl = tmp;
3292 /* Set up a charlen structure for it. */
3297 len = cl.backend_decl;
3300 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3301 || (!comp && gfc_return_by_reference (sym));
3304 if (se->direct_byref)
3306 /* Sometimes, too much indirection can be applied; e.g. for
3307 function_result = array_valued_recursive_function. */
3308 if (TREE_TYPE (TREE_TYPE (se->expr))
3309 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3310 && GFC_DESCRIPTOR_TYPE_P
3311 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3312 se->expr = build_fold_indirect_ref_loc (input_location,
3315 result = build_fold_indirect_ref_loc (input_location,
3317 VEC_safe_push (tree, gc, retargs, se->expr);
3319 else if (comp && comp->attr.dimension)
3321 gcc_assert (se->loop && info);
3323 /* Set the type of the array. */
3324 tmp = gfc_typenode_for_spec (&comp->ts);
3325 info->dimen = se->loop->dimen;
3327 /* Evaluate the bounds of the result, if known. */
3328 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3330 /* Create a temporary to store the result. In case the function
3331 returns a pointer, the temporary will be a shallow copy and
3332 mustn't be deallocated. */
3333 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3334 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3335 NULL_TREE, false, !comp->attr.pointer,
3336 callee_alloc, &se->ss->expr->where);
3338 /* Pass the temporary as the first argument. */
3339 result = info->descriptor;
3340 tmp = gfc_build_addr_expr (NULL_TREE, result);
3341 VEC_safe_push (tree, gc, retargs, tmp);
3343 else if (!comp && sym->result->attr.dimension)
3345 gcc_assert (se->loop && info);
3347 /* Set the type of the array. */
3348 tmp = gfc_typenode_for_spec (&ts);
3349 info->dimen = se->loop->dimen;
3351 /* Evaluate the bounds of the result, if known. */
3352 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3354 /* Create a temporary to store the result. In case the function
3355 returns a pointer, the temporary will be a shallow copy and
3356 mustn't be deallocated. */
3357 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3358 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3359 NULL_TREE, false, !sym->attr.pointer,
3360 callee_alloc, &se->ss->expr->where);
3362 /* Pass the temporary as the first argument. */
3363 result = info->descriptor;
3364 tmp = gfc_build_addr_expr (NULL_TREE, result);
3365 VEC_safe_push (tree, gc, retargs, tmp);
3367 else if (ts.type == BT_CHARACTER)
3369 /* Pass the string length. */
3370 type = gfc_get_character_type (ts.kind, ts.u.cl);
3371 type = build_pointer_type (type);
3373 /* Return an address to a char[0:len-1]* temporary for
3374 character pointers. */
3375 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3376 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3378 var = gfc_create_var (type, "pstr");
3380 if ((!comp && sym->attr.allocatable)
3381 || (comp && comp->attr.allocatable))
3382 gfc_add_modify (&se->pre, var,
3383 fold_convert (TREE_TYPE (var),
3384 null_pointer_node));
3386 /* Provide an address expression for the function arguments. */
3387 var = gfc_build_addr_expr (NULL_TREE, var);
3390 var = gfc_conv_string_tmp (se, type, len);
3392 VEC_safe_push (tree, gc, retargs, var);
3396 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3398 type = gfc_get_complex_type (ts.kind);
3399 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3400 VEC_safe_push (tree, gc, retargs, var);
3403 /* Add the string length to the argument list. */
3404 if (ts.type == BT_CHARACTER)
3405 VEC_safe_push (tree, gc, retargs, len);
3407 gfc_free_interface_mapping (&mapping);
3409 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3410 arglen = (VEC_length (tree, arglist)
3411 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3412 VEC_reserve_exact (tree, gc, retargs, arglen);
3414 /* Add the return arguments. */
3415 VEC_splice (tree, retargs, arglist);
3417 /* Add the hidden string length parameters to the arguments. */
3418 VEC_splice (tree, retargs, stringargs);
3420 /* We may want to append extra arguments here. This is used e.g. for
3421 calls to libgfortran_matmul_??, which need extra information. */
3422 if (!VEC_empty (tree, append_args))
3423 VEC_splice (tree, retargs, append_args);
3426 /* Generate the actual call. */
3427 conv_function_val (se, sym, expr);
3429 /* If there are alternate return labels, function type should be
3430 integer. Can't modify the type in place though, since it can be shared
3431 with other functions. For dummy arguments, the typing is done to
3432 to this result, even if it has to be repeated for each call. */
3433 if (has_alternate_specifier
3434 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3436 if (!sym->attr.dummy)
3438 TREE_TYPE (sym->backend_decl)
3439 = build_function_type (integer_type_node,
3440 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3441 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3444 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3447 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3448 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3450 /* If we have a pointer function, but we don't want a pointer, e.g.
3453 where f is pointer valued, we have to dereference the result. */
3454 if (!se->want_pointer && !byref
3455 && (sym->attr.pointer || sym->attr.allocatable)
3456 && !gfc_is_proc_ptr_comp (expr, NULL))
3457 se->expr = build_fold_indirect_ref_loc (input_location,
3460 /* f2c calling conventions require a scalar default real function to
3461 return a double precision result. Convert this back to default
3462 real. We only care about the cases that can happen in Fortran 77.
3464 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3465 && sym->ts.kind == gfc_default_real_kind
3466 && !sym->attr.always_explicit)
3467 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3469 /* A pure function may still have side-effects - it may modify its
3471 TREE_SIDE_EFFECTS (se->expr) = 1;
3473 if (!sym->attr.pure)
3474 TREE_SIDE_EFFECTS (se->expr) = 1;
3479 /* Add the function call to the pre chain. There is no expression. */
3480 gfc_add_expr_to_block (&se->pre, se->expr);
3481 se->expr = NULL_TREE;
3483 if (!se->direct_byref)
3485 if (sym->attr.dimension || (comp && comp->attr.dimension))
3487 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3489 /* Check the data pointer hasn't been modified. This would
3490 happen in a function returning a pointer. */
3491 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3492 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3494 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3497 se->expr = info->descriptor;
3498 /* Bundle in the string length. */
3499 se->string_length = len;
3501 else if (ts.type == BT_CHARACTER)
3503 /* Dereference for character pointer results. */
3504 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3505 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3506 se->expr = build_fold_indirect_ref_loc (input_location, var);
3510 se->string_length = len;
3514 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3515 se->expr = build_fold_indirect_ref_loc (input_location, var);
3520 /* Follow the function call with the argument post block. */
3523 gfc_add_block_to_block (&se->pre, &post);
3525 /* Transformational functions of derived types with allocatable
3526 components must have the result allocatable components copied. */
3527 arg = expr->value.function.actual;
3528 if (result && arg && expr->rank
3529 && expr->value.function.isym
3530 && expr->value.function.isym->transformational
3531 && arg->expr->ts.type == BT_DERIVED
3532 && arg->expr->ts.u.derived->attr.alloc_comp)
3535 /* Copy the allocatable components. We have to use a
3536 temporary here to prevent source allocatable components
3537 from being corrupted. */
3538 tmp2 = gfc_evaluate_now (result, &se->pre);
3539 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3540 result, tmp2, expr->rank);
3541 gfc_add_expr_to_block (&se->pre, tmp);
3542 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3544 gfc_add_expr_to_block (&se->pre, tmp);
3546 /* Finally free the temporary's data field. */
3547 tmp = gfc_conv_descriptor_data_get (tmp2);
3548 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3549 gfc_add_expr_to_block (&se->pre, tmp);
3553 gfc_add_block_to_block (&se->post, &post);
3555 return has_alternate_specifier;
3559 /* Fill a character string with spaces. */
3562 fill_with_spaces (tree start, tree type, tree size)
3564 stmtblock_t block, loop;
3565 tree i, el, exit_label, cond, tmp;
3567 /* For a simple char type, we can call memset(). */
3568 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3569 return build_call_expr_loc (input_location,
3570 built_in_decls[BUILT_IN_MEMSET], 3, start,
3571 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3572 lang_hooks.to_target_charset (' ')),
3575 /* Otherwise, we use a loop:
3576 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3580 /* Initialize variables. */
3581 gfc_init_block (&block);
3582 i = gfc_create_var (sizetype, "i");
3583 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3584 el = gfc_create_var (build_pointer_type (type), "el");
3585 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3586 exit_label = gfc_build_label_decl (NULL_TREE);
3587 TREE_USED (exit_label) = 1;
3591 gfc_init_block (&loop);
3593 /* Exit condition. */
3594 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3595 fold_convert (sizetype, integer_zero_node));
3596 tmp = build1_v (GOTO_EXPR, exit_label);
3597 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3598 build_empty_stmt (input_location));
3599 gfc_add_expr_to_block (&loop, tmp);
3602 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3603 build_int_cst (type,
3604 lang_hooks.to_target_charset (' ')));
3606 /* Increment loop variables. */
3607 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3608 TYPE_SIZE_UNIT (type)));
3609 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3611 TYPE_SIZE_UNIT (type)));
3613 /* Making the loop... actually loop! */
3614 tmp = gfc_finish_block (&loop);
3615 tmp = build1_v (LOOP_EXPR, tmp);
3616 gfc_add_expr_to_block (&block, tmp);
3618 /* The exit label. */
3619 tmp = build1_v (LABEL_EXPR, exit_label);
3620 gfc_add_expr_to_block (&block, tmp);
3623 return gfc_finish_block (&block);
3627 /* Generate code to copy a string. */
3630 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3631 int dkind, tree slength, tree src, int skind)
3633 tree tmp, dlen, slen;
3642 stmtblock_t tempblock;
3644 gcc_assert (dkind == skind);
3646 if (slength != NULL_TREE)
3648 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3649 ssc = gfc_string_to_single_character (slen, src, skind);
3653 slen = build_int_cst (size_type_node, 1);
3657 if (dlength != NULL_TREE)
3659 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3660 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3664 dlen = build_int_cst (size_type_node, 1);
3668 /* Assign directly if the types are compatible. */
3669 if (dsc != NULL_TREE && ssc != NULL_TREE
3670 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3672 gfc_add_modify (block, dsc, ssc);
3676 /* Do nothing if the destination length is zero. */
3677 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3678 build_int_cst (size_type_node, 0));
3680 /* The following code was previously in _gfortran_copy_string:
3682 // The two strings may overlap so we use memmove.
3684 copy_string (GFC_INTEGER_4 destlen, char * dest,
3685 GFC_INTEGER_4 srclen, const char * src)
3687 if (srclen >= destlen)
3689 // This will truncate if too long.
3690 memmove (dest, src, destlen);
3694 memmove (dest, src, srclen);
3696 memset (&dest[srclen], ' ', destlen - srclen);
3700 We're now doing it here for better optimization, but the logic
3703 /* For non-default character kinds, we have to multiply the string
3704 length by the base type size. */
3705 chartype = gfc_get_char_type (dkind);
3706 slen = fold_build2 (MULT_EXPR, size_type_node,
3707 fold_convert (size_type_node, slen),
3708 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3709 dlen = fold_build2 (MULT_EXPR, size_type_node,
3710 fold_convert (size_type_node, dlen),
3711 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3714 dest = fold_convert (pvoid_type_node, dest);
3716 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3719 src = fold_convert (pvoid_type_node, src);
3721 src = gfc_build_addr_expr (pvoid_type_node, src);
3723 /* Truncate string if source is too long. */
3724 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3725 tmp2 = build_call_expr_loc (input_location,
3726 built_in_decls[BUILT_IN_MEMMOVE],
3727 3, dest, src, dlen);
3729 /* Else copy and pad with spaces. */
3730 tmp3 = build_call_expr_loc (input_location,
3731 built_in_decls[BUILT_IN_MEMMOVE],
3732 3, dest, src, slen);
3734 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3735 fold_convert (sizetype, slen));
3736 tmp4 = fill_with_spaces (tmp4, chartype,
3737 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3740 gfc_init_block (&tempblock);
3741 gfc_add_expr_to_block (&tempblock, tmp3);
3742 gfc_add_expr_to_block (&tempblock, tmp4);
3743 tmp3 = gfc_finish_block (&tempblock);
3745 /* The whole copy_string function is there. */
3746 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3747 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3748 build_empty_stmt (input_location));
3749 gfc_add_expr_to_block (block, tmp);
3753 /* Translate a statement function.
3754 The value of a statement function reference is obtained by evaluating the
3755 expression using the values of the actual arguments for the values of the
3756 corresponding dummy arguments. */
3759 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3763 gfc_formal_arglist *fargs;
3764 gfc_actual_arglist *args;
3767 gfc_saved_var *saved_vars;
3773 sym = expr->symtree->n.sym;
3774 args = expr->value.function.actual;
3775 gfc_init_se (&lse, NULL);
3776 gfc_init_se (&rse, NULL);
3779 for (fargs = sym->formal; fargs; fargs = fargs->next)
3781 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3782 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3784 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3786 /* Each dummy shall be specified, explicitly or implicitly, to be
3788 gcc_assert (fargs->sym->attr.dimension == 0);
3791 /* Create a temporary to hold the value. */
3792 type = gfc_typenode_for_spec (&fsym->ts);
3793 temp_vars[n] = gfc_create_var (type, fsym->name);
3795 if (fsym->ts.type == BT_CHARACTER)
3797 /* Copy string arguments. */
3800 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3801 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3803 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3804 tmp = gfc_build_addr_expr (build_pointer_type (type),
3807 gfc_conv_expr (&rse, args->expr);
3808 gfc_conv_string_parameter (&rse);
3809 gfc_add_block_to_block (&se->pre, &lse.pre);
3810 gfc_add_block_to_block (&se->pre, &rse.pre);
3812 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3813 rse.string_length, rse.expr, fsym->ts.kind);
3814 gfc_add_block_to_block (&se->pre, &lse.post);
3815 gfc_add_block_to_block (&se->pre, &rse.post);
3819 /* For everything else, just evaluate the expression. */
3820 gfc_conv_expr (&lse, args->expr);
3822 gfc_add_block_to_block (&se->pre, &lse.pre);
3823 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3824 gfc_add_block_to_block (&se->pre, &lse.post);
3830 /* Use the temporary variables in place of the real ones. */
3831 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3832 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3834 gfc_conv_expr (se, sym->value);
3836 if (sym->ts.type == BT_CHARACTER)
3838 gfc_conv_const_charlen (sym->ts.u.cl);
3840 /* Force the expression to the correct length. */
3841 if (!INTEGER_CST_P (se->string_length)
3842 || tree_int_cst_lt (se->string_length,
3843 sym->ts.u.cl->backend_decl))
3845 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3846 tmp = gfc_create_var (type, sym->name);
3847 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3848 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3849 sym->ts.kind, se->string_length, se->expr,
3853 se->string_length = sym->ts.u.cl->backend_decl;
3856 /* Restore the original variables. */
3857 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3858 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3859 gfc_free (saved_vars);
3863 /* Translate a function expression. */
3866 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3870 if (expr->value.function.isym)
3872 gfc_conv_intrinsic_function (se, expr);
3876 /* We distinguish statement functions from general functions to improve
3877 runtime performance. */
3878 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3880 gfc_conv_statement_function (se, expr);
3884 /* expr.value.function.esym is the resolved (specific) function symbol for
3885 most functions. However this isn't set for dummy procedures. */
3886 sym = expr->value.function.esym;
3888 sym = expr->symtree->n.sym;
3890 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3894 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3897 is_zero_initializer_p (gfc_expr * expr)
3899 if (expr->expr_type != EXPR_CONSTANT)
3902 /* We ignore constants with prescribed memory representations for now. */
3903 if (expr->representation.string)
3906 switch (expr->ts.type)
3909 return mpz_cmp_si (expr->value.integer, 0) == 0;
3912 return mpfr_zero_p (expr->value.real)
3913 && MPFR_SIGN (expr->value.real) >= 0;
3916 return expr->value.logical == 0;
3919 return mpfr_zero_p (mpc_realref (expr->value.complex))
3920 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3921 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3922 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3932 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3934 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3935 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3937 gfc_conv_tmp_array_ref (se);
3938 gfc_advance_se_ss_chain (se);
3942 /* Build a static initializer. EXPR is the expression for the initial value.
3943 The other parameters describe the variable of the component being
3944 initialized. EXPR may be null. */
3947 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3948 bool array, bool pointer)
3952 if (!(expr || pointer))
3955 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3956 (these are the only two iso_c_binding derived types that can be
3957 used as initialization expressions). If so, we need to modify
3958 the 'expr' to be that for a (void *). */
3959 if (expr != NULL && expr->ts.type == BT_DERIVED
3960 && expr->ts.is_iso_c && expr->ts.u.derived)
3962 gfc_symbol *derived = expr->ts.u.derived;
3964 /* The derived symbol has already been converted to a (void *). Use
3966 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
3967 expr->ts.f90_type = derived->ts.f90_type;
3969 gfc_init_se (&se, NULL);
3970 gfc_conv_constant (&se, expr);
3976 /* Arrays need special handling. */
3978 return gfc_build_null_descriptor (type);
3979 /* Special case assigning an array to zero. */
3980 else if (is_zero_initializer_p (expr))
3981 return build_constructor (type, NULL);
3983 return gfc_conv_array_initializer (type, expr);
3986 return fold_convert (type, null_pointer_node);
3993 gfc_init_se (&se, NULL);
3994 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
3995 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
3997 gfc_conv_structure (&se, expr, 1);
4001 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4004 gfc_init_se (&se, NULL);
4005 gfc_conv_constant (&se, expr);
4012 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4024 gfc_start_block (&block);
4026 /* Initialize the scalarizer. */
4027 gfc_init_loopinfo (&loop);
4029 gfc_init_se (&lse, NULL);
4030 gfc_init_se (&rse, NULL);
4033 rss = gfc_walk_expr (expr);
4034 if (rss == gfc_ss_terminator)
4036 /* The rhs is scalar. Add a ss for the expression. */
4037 rss = gfc_get_ss ();
4038 rss->next = gfc_ss_terminator;
4039 rss->type = GFC_SS_SCALAR;
4043 /* Create a SS for the destination. */
4044 lss = gfc_get_ss ();
4045 lss->type = GFC_SS_COMPONENT;
4047 lss->shape = gfc_get_shape (cm->as->rank);
4048 lss->next = gfc_ss_terminator;
4049 lss->data.info.dimen = cm->as->rank;
4050 lss->data.info.descriptor = dest;
4051 lss->data.info.data = gfc_conv_array_data (dest);
4052 lss->data.info.offset = gfc_conv_array_offset (dest);
4053 for (n = 0; n < cm->as->rank; n++)
4055 lss->data.info.dim[n] = n;
4056 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4057 lss->data.info.stride[n] = gfc_index_one_node;
4059 mpz_init (lss->shape[n]);
4060 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4061 cm->as->lower[n]->value.integer);
4062 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4065 /* Associate the SS with the loop. */
4066 gfc_add_ss_to_loop (&loop, lss);
4067 gfc_add_ss_to_loop (&loop, rss);
4069 /* Calculate the bounds of the scalarization. */
4070 gfc_conv_ss_startstride (&loop);
4072 /* Setup the scalarizing loops. */
4073 gfc_conv_loop_setup (&loop, &expr->where);
4075 /* Setup the gfc_se structures. */
4076 gfc_copy_loopinfo_to_se (&lse, &loop);
4077 gfc_copy_loopinfo_to_se (&rse, &loop);
4080 gfc_mark_ss_chain_used (rss, 1);
4082 gfc_mark_ss_chain_used (lss, 1);
4084 /* Start the scalarized loop body. */
4085 gfc_start_scalarized_body (&loop, &body);
4087 gfc_conv_tmp_array_ref (&lse);
4088 if (cm->ts.type == BT_CHARACTER)
4089 lse.string_length = cm->ts.u.cl->backend_decl;
4091 gfc_conv_expr (&rse, expr);
4093 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4094 gfc_add_expr_to_block (&body, tmp);
4096 gcc_assert (rse.ss == gfc_ss_terminator);
4098 /* Generate the copying loops. */
4099 gfc_trans_scalarizing_loops (&loop, &body);
4101 /* Wrap the whole thing up. */
4102 gfc_add_block_to_block (&block, &loop.pre);
4103 gfc_add_block_to_block (&block, &loop.post);
4105 for (n = 0; n < cm->as->rank; n++)
4106 mpz_clear (lss->shape[n]);
4107 gfc_free (lss->shape);
4109 gfc_cleanup_loop (&loop);
4111 return gfc_finish_block (&block);
4116 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4127 gfc_expr *arg = NULL;
4129 gfc_start_block (&block);
4130 gfc_init_se (&se, NULL);
4132 /* Get the descriptor for the expressions. */
4133 rss = gfc_walk_expr (expr);
4134 se.want_pointer = 0;
4135 gfc_conv_expr_descriptor (&se, expr, rss);
4136 gfc_add_block_to_block (&block, &se.pre);
4137 gfc_add_modify (&block, dest, se.expr);
4139 /* Deal with arrays of derived types with allocatable components. */
4140 if (cm->ts.type == BT_DERIVED
4141 && cm->ts.u.derived->attr.alloc_comp)
4142 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4146 tmp = gfc_duplicate_allocatable (dest, se.expr,
4147 TREE_TYPE(cm->backend_decl),
4150 gfc_add_expr_to_block (&block, tmp);
4151 gfc_add_block_to_block (&block, &se.post);
4153 if (expr->expr_type != EXPR_VARIABLE)
4154 gfc_conv_descriptor_data_set (&block, se.expr,
4157 /* We need to know if the argument of a conversion function is a
4158 variable, so that the correct lower bound can be used. */
4159 if (expr->expr_type == EXPR_FUNCTION
4160 && expr->value.function.isym
4161 && expr->value.function.isym->conversion
4162 && expr->value.function.actual->expr
4163 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4164 arg = expr->value.function.actual->expr;
4166 /* Obtain the array spec of full array references. */
4168 as = gfc_get_full_arrayspec_from_expr (arg);
4170 as = gfc_get_full_arrayspec_from_expr (expr);
4172 /* Shift the lbound and ubound of temporaries to being unity,
4173 rather than zero, based. Always calculate the offset. */
4174 offset = gfc_conv_descriptor_offset_get (dest);
4175 gfc_add_modify (&block, offset, gfc_index_zero_node);
4176 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4178 for (n = 0; n < expr->rank; n++)
4183 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4184 TODO It looks as if gfc_conv_expr_descriptor should return
4185 the correct bounds and that the following should not be
4186 necessary. This would simplify gfc_conv_intrinsic_bound
4188 if (as && as->lower[n])
4191 gfc_init_se (&lbse, NULL);
4192 gfc_conv_expr (&lbse, as->lower[n]);
4193 gfc_add_block_to_block (&block, &lbse.pre);
4194 lbound = gfc_evaluate_now (lbse.expr, &block);
4198 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4199 lbound = gfc_conv_descriptor_lbound_get (tmp,
4203 lbound = gfc_conv_descriptor_lbound_get (dest,
4206 lbound = gfc_index_one_node;
4208 lbound = fold_convert (gfc_array_index_type, lbound);
4210 /* Shift the bounds and set the offset accordingly. */
4211 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4212 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4213 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4214 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4215 gfc_conv_descriptor_ubound_set (&block, dest,
4216 gfc_rank_cst[n], tmp);
4217 gfc_conv_descriptor_lbound_set (&block, dest,
4218 gfc_rank_cst[n], lbound);
4220 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4221 gfc_conv_descriptor_lbound_get (dest,
4223 gfc_conv_descriptor_stride_get (dest,
4225 gfc_add_modify (&block, tmp2, tmp);
4226 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4227 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4232 /* If a conversion expression has a null data pointer
4233 argument, nullify the allocatable component. */
4237 if (arg->symtree->n.sym->attr.allocatable
4238 || arg->symtree->n.sym->attr.pointer)
4240 non_null_expr = gfc_finish_block (&block);
4241 gfc_start_block (&block);
4242 gfc_conv_descriptor_data_set (&block, dest,
4244 null_expr = gfc_finish_block (&block);
4245 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4246 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4247 fold_convert (TREE_TYPE (tmp),
4248 null_pointer_node));
4249 return build3_v (COND_EXPR, tmp,
4250 null_expr, non_null_expr);
4254 return gfc_finish_block (&block);
4258 /* Assign a single component of a derived type constructor. */
4261 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4269 gfc_start_block (&block);
4271 if (cm->attr.pointer)
4273 gfc_init_se (&se, NULL);
4274 /* Pointer component. */
4275 if (cm->attr.dimension)
4277 /* Array pointer. */
4278 if (expr->expr_type == EXPR_NULL)
4279 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4282 rss = gfc_walk_expr (expr);
4283 se.direct_byref = 1;
4285 gfc_conv_expr_descriptor (&se, expr, rss);
4286 gfc_add_block_to_block (&block, &se.pre);
4287 gfc_add_block_to_block (&block, &se.post);
4292 /* Scalar pointers. */
4293 se.want_pointer = 1;
4294 gfc_conv_expr (&se, expr);
4295 gfc_add_block_to_block (&block, &se.pre);
4296 gfc_add_modify (&block, dest,
4297 fold_convert (TREE_TYPE (dest), se.expr));
4298 gfc_add_block_to_block (&block, &se.post);
4301 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4303 /* NULL initialization for CLASS components. */
4304 tmp = gfc_trans_structure_assign (dest,
4305 gfc_class_null_initializer (&cm->ts));
4306 gfc_add_expr_to_block (&block, tmp);
4308 else if (cm->attr.dimension)
4310 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4311 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4312 else if (cm->attr.allocatable)
4314 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4315 gfc_add_expr_to_block (&block, tmp);
4319 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4320 gfc_add_expr_to_block (&block, tmp);
4323 else if (expr->ts.type == BT_DERIVED)
4325 if (expr->expr_type != EXPR_STRUCTURE)
4327 gfc_init_se (&se, NULL);
4328 gfc_conv_expr (&se, expr);
4329 gfc_add_block_to_block (&block, &se.pre);
4330 gfc_add_modify (&block, dest,
4331 fold_convert (TREE_TYPE (dest), se.expr));
4332 gfc_add_block_to_block (&block, &se.post);
4336 /* Nested constructors. */
4337 tmp = gfc_trans_structure_assign (dest, expr);
4338 gfc_add_expr_to_block (&block, tmp);
4343 /* Scalar component. */
4344 gfc_init_se (&se, NULL);
4345 gfc_init_se (&lse, NULL);
4347 gfc_conv_expr (&se, expr);
4348 if (cm->ts.type == BT_CHARACTER)
4349 lse.string_length = cm->ts.u.cl->backend_decl;
4351 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4352 gfc_add_expr_to_block (&block, tmp);
4354 return gfc_finish_block (&block);
4357 /* Assign a derived type constructor to a variable. */
4360 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4368 gfc_start_block (&block);
4369 cm = expr->ts.u.derived->components;
4370 for (c = gfc_constructor_first (expr->value.constructor);
4371 c; c = gfc_constructor_next (c), cm = cm->next)
4373 /* Skip absent members in default initializers. */
4377 /* Handle c_null_(fun)ptr. */
4378 if (c && c->expr && c->expr->ts.is_iso_c)
4380 field = cm->backend_decl;
4381 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4382 dest, field, NULL_TREE);
4383 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4384 fold_convert (TREE_TYPE (tmp),
4385 null_pointer_node));
4386 gfc_add_expr_to_block (&block, tmp);
4390 field = cm->backend_decl;
4391 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4392 dest, field, NULL_TREE);
4393 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4394 gfc_add_expr_to_block (&block, tmp);
4396 return gfc_finish_block (&block);
4399 /* Build an expression for a constructor. If init is nonzero then
4400 this is part of a static variable initializer. */
4403 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4410 VEC(constructor_elt,gc) *v = NULL;
4412 gcc_assert (se->ss == NULL);
4413 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4414 type = gfc_typenode_for_spec (&expr->ts);
4418 /* Create a temporary variable and fill it in. */
4419 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4420 tmp = gfc_trans_structure_assign (se->expr, expr);
4421 gfc_add_expr_to_block (&se->pre, tmp);
4425 cm = expr->ts.u.derived->components;
4427 for (c = gfc_constructor_first (expr->value.constructor);
4428 c; c = gfc_constructor_next (c), cm = cm->next)
4430 /* Skip absent members in default initializers and allocatable
4431 components. Although the latter have a default initializer
4432 of EXPR_NULL,... by default, the static nullify is not needed
4433 since this is done every time we come into scope. */
4434 if (!c->expr || cm->attr.allocatable)
4437 if (strcmp (cm->name, "$size") == 0)
4439 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4440 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4442 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4443 && strcmp (cm->name, "$extends") == 0)
4447 vtabs = cm->initializer->symtree->n.sym;
4448 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4449 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4453 val = gfc_conv_initializer (c->expr, &cm->ts,
4454 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4455 cm->attr.pointer || cm->attr.proc_pointer);
4457 /* Append it to the constructor list. */
4458 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4461 se->expr = build_constructor (type, v);
4463 TREE_CONSTANT (se->expr) = 1;
4467 /* Translate a substring expression. */
4470 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4476 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4478 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4479 expr->value.character.length,
4480 expr->value.character.string);
4482 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4483 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4486 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4490 /* Entry point for expression translation. Evaluates a scalar quantity.
4491 EXPR is the expression to be translated, and SE is the state structure if
4492 called from within the scalarized. */
4495 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4497 if (se->ss && se->ss->expr == expr
4498 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4500 /* Substitute a scalar expression evaluated outside the scalarization
4502 se->expr = se->ss->data.scalar.expr;
4503 if (se->ss->type == GFC_SS_REFERENCE)
4504 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4505 se->string_length = se->ss->string_length;
4506 gfc_advance_se_ss_chain (se);
4510 /* We need to convert the expressions for the iso_c_binding derived types.
4511 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4512 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4513 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4514 updated to be an integer with a kind equal to the size of a (void *). */
4515 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4516 && expr->ts.u.derived->attr.is_iso_c)
4518 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4519 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4521 /* Set expr_type to EXPR_NULL, which will result in
4522 null_pointer_node being used below. */
4523 expr->expr_type = EXPR_NULL;
4527 /* Update the type/kind of the expression to be what the new
4528 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4529 expr->ts.type = expr->ts.u.derived->ts.type;
4530 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4531 expr->ts.kind = expr->ts.u.derived->ts.kind;
4535 switch (expr->expr_type)
4538 gfc_conv_expr_op (se, expr);
4542 gfc_conv_function_expr (se, expr);
4546 gfc_conv_constant (se, expr);
4550 gfc_conv_variable (se, expr);
4554 se->expr = null_pointer_node;
4557 case EXPR_SUBSTRING:
4558 gfc_conv_substring_expr (se, expr);
4561 case EXPR_STRUCTURE:
4562 gfc_conv_structure (se, expr, 0);
4566 gfc_conv_array_constructor_expr (se, expr);
4575 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4576 of an assignment. */
4578 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4580 gfc_conv_expr (se, expr);
4581 /* All numeric lvalues should have empty post chains. If not we need to
4582 figure out a way of rewriting an lvalue so that it has no post chain. */
4583 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4586 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4587 numeric expressions. Used for scalar values where inserting cleanup code
4590 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4594 gcc_assert (expr->ts.type != BT_CHARACTER);
4595 gfc_conv_expr (se, expr);
4598 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4599 gfc_add_modify (&se->pre, val, se->expr);
4601 gfc_add_block_to_block (&se->pre, &se->post);
4605 /* Helper to translate an expression and convert it to a particular type. */
4607 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4609 gfc_conv_expr_val (se, expr);
4610 se->expr = convert (type, se->expr);
4614 /* Converts an expression so that it can be passed by reference. Scalar
4618 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4622 if (se->ss && se->ss->expr == expr
4623 && se->ss->type == GFC_SS_REFERENCE)
4625 /* Returns a reference to the scalar evaluated outside the loop
4627 gfc_conv_expr (se, expr);
4631 if (expr->ts.type == BT_CHARACTER)
4633 gfc_conv_expr (se, expr);
4634 gfc_conv_string_parameter (se);
4638 if (expr->expr_type == EXPR_VARIABLE)
4640 se->want_pointer = 1;
4641 gfc_conv_expr (se, expr);
4644 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4645 gfc_add_modify (&se->pre, var, se->expr);
4646 gfc_add_block_to_block (&se->pre, &se->post);
4652 if (expr->expr_type == EXPR_FUNCTION
4653 && ((expr->value.function.esym
4654 && expr->value.function.esym->result->attr.pointer
4655 && !expr->value.function.esym->result->attr.dimension)
4656 || (!expr->value.function.esym
4657 && expr->symtree->n.sym->attr.pointer
4658 && !expr->symtree->n.sym->attr.dimension)))
4660 se->want_pointer = 1;
4661 gfc_conv_expr (se, expr);
4662 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4663 gfc_add_modify (&se->pre, var, se->expr);
4669 gfc_conv_expr (se, expr);
4671 /* Create a temporary var to hold the value. */
4672 if (TREE_CONSTANT (se->expr))
4674 tree tmp = se->expr;
4675 STRIP_TYPE_NOPS (tmp);
4676 var = build_decl (input_location,
4677 CONST_DECL, NULL, TREE_TYPE (tmp));
4678 DECL_INITIAL (var) = tmp;
4679 TREE_STATIC (var) = 1;
4684 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4685 gfc_add_modify (&se->pre, var, se->expr);
4687 gfc_add_block_to_block (&se->pre, &se->post);
4689 /* Take the address of that value. */
4690 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4695 gfc_trans_pointer_assign (gfc_code * code)
4697 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4701 /* Generate code for a pointer assignment. */
4704 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4715 gfc_start_block (&block);
4717 gfc_init_se (&lse, NULL);
4719 lss = gfc_walk_expr (expr1);
4720 rss = gfc_walk_expr (expr2);
4721 if (lss == gfc_ss_terminator)
4723 /* Scalar pointers. */
4724 lse.want_pointer = 1;
4725 gfc_conv_expr (&lse, expr1);
4726 gcc_assert (rss == gfc_ss_terminator);
4727 gfc_init_se (&rse, NULL);
4728 rse.want_pointer = 1;
4729 gfc_conv_expr (&rse, expr2);
4731 if (expr1->symtree->n.sym->attr.proc_pointer
4732 && expr1->symtree->n.sym->attr.dummy)
4733 lse.expr = build_fold_indirect_ref_loc (input_location,
4736 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4737 && expr2->symtree->n.sym->attr.dummy)
4738 rse.expr = build_fold_indirect_ref_loc (input_location,
4741 gfc_add_block_to_block (&block, &lse.pre);
4742 gfc_add_block_to_block (&block, &rse.pre);
4744 /* Check character lengths if character expression. The test is only
4745 really added if -fbounds-check is enabled. */
4746 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4747 && !expr1->symtree->n.sym->attr.proc_pointer
4748 && !gfc_is_proc_ptr_comp (expr1, NULL))
4750 gcc_assert (expr2->ts.type == BT_CHARACTER);
4751 gcc_assert (lse.string_length && rse.string_length);
4752 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4753 lse.string_length, rse.string_length,
4757 gfc_add_modify (&block, lse.expr,
4758 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4760 gfc_add_block_to_block (&block, &rse.post);
4761 gfc_add_block_to_block (&block, &lse.post);
4766 tree strlen_rhs = NULL_TREE;
4768 /* Array pointer. */
4769 gfc_conv_expr_descriptor (&lse, expr1, lss);
4770 strlen_lhs = lse.string_length;
4771 switch (expr2->expr_type)
4774 /* Just set the data pointer to null. */
4775 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4779 /* Assign directly to the pointer's descriptor. */
4780 lse.direct_byref = 1;
4781 gfc_conv_expr_descriptor (&lse, expr2, rss);
4782 strlen_rhs = lse.string_length;
4784 /* If this is a subreference array pointer assignment, use the rhs
4785 descriptor element size for the lhs span. */
4786 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4788 decl = expr1->symtree->n.sym->backend_decl;
4789 gfc_init_se (&rse, NULL);
4790 rse.descriptor_only = 1;
4791 gfc_conv_expr (&rse, expr2);
4792 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4793 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4794 if (!INTEGER_CST_P (tmp))
4795 gfc_add_block_to_block (&lse.post, &rse.pre);
4796 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4802 /* Assign to a temporary descriptor and then copy that
4803 temporary to the pointer. */
4805 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4808 lse.direct_byref = 1;
4809 gfc_conv_expr_descriptor (&lse, expr2, rss);
4810 strlen_rhs = lse.string_length;
4811 gfc_add_modify (&lse.pre, desc, tmp);
4815 gfc_add_block_to_block (&block, &lse.pre);
4817 /* Check string lengths if applicable. The check is only really added
4818 to the output code if -fbounds-check is enabled. */
4819 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4821 gcc_assert (expr2->ts.type == BT_CHARACTER);
4822 gcc_assert (strlen_lhs && strlen_rhs);
4823 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4824 strlen_lhs, strlen_rhs, &block);
4827 gfc_add_block_to_block (&block, &lse.post);
4829 return gfc_finish_block (&block);
4833 /* Makes sure se is suitable for passing as a function string parameter. */
4834 /* TODO: Need to check all callers of this function. It may be abused. */
4837 gfc_conv_string_parameter (gfc_se * se)
4841 if (TREE_CODE (se->expr) == STRING_CST)
4843 type = TREE_TYPE (TREE_TYPE (se->expr));
4844 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4848 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4850 if (TREE_CODE (se->expr) != INDIRECT_REF)
4852 type = TREE_TYPE (se->expr);
4853 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4857 type = gfc_get_character_type_len (gfc_default_character_kind,
4859 type = build_pointer_type (type);
4860 se->expr = gfc_build_addr_expr (type, se->expr);
4864 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4865 gcc_assert (se->string_length
4866 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4870 /* Generate code for assignment of scalar variables. Includes character
4871 strings and derived types with allocatable components.
4872 If you know that the LHS has no allocations, set dealloc to false. */
4875 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4876 bool l_is_temp, bool r_is_var, bool dealloc)
4882 gfc_init_block (&block);
4884 if (ts.type == BT_CHARACTER)
4889 if (lse->string_length != NULL_TREE)
4891 gfc_conv_string_parameter (lse);
4892 gfc_add_block_to_block (&block, &lse->pre);
4893 llen = lse->string_length;
4896 if (rse->string_length != NULL_TREE)
4898 gcc_assert (rse->string_length != NULL_TREE);
4899 gfc_conv_string_parameter (rse);
4900 gfc_add_block_to_block (&block, &rse->pre);
4901 rlen = rse->string_length;
4904 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4905 rse->expr, ts.kind);
4907 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4911 /* Are the rhs and the lhs the same? */
4914 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4915 gfc_build_addr_expr (NULL_TREE, lse->expr),
4916 gfc_build_addr_expr (NULL_TREE, rse->expr));
4917 cond = gfc_evaluate_now (cond, &lse->pre);
4920 /* Deallocate the lhs allocated components as long as it is not
4921 the same as the rhs. This must be done following the assignment
4922 to prevent deallocating data that could be used in the rhs
4924 if (!l_is_temp && dealloc)
4926 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4927 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4929 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4931 gfc_add_expr_to_block (&lse->post, tmp);
4934 gfc_add_block_to_block (&block, &rse->pre);
4935 gfc_add_block_to_block (&block, &lse->pre);
4937 gfc_add_modify (&block, lse->expr,
4938 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4940 /* Do a deep copy if the rhs is a variable, if it is not the
4944 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4945 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4947 gfc_add_expr_to_block (&block, tmp);
4950 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4952 gfc_add_block_to_block (&block, &lse->pre);
4953 gfc_add_block_to_block (&block, &rse->pre);
4954 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4955 gfc_add_modify (&block, lse->expr, tmp);
4959 gfc_add_block_to_block (&block, &lse->pre);
4960 gfc_add_block_to_block (&block, &rse->pre);
4962 gfc_add_modify (&block, lse->expr,
4963 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4966 gfc_add_block_to_block (&block, &lse->post);
4967 gfc_add_block_to_block (&block, &rse->post);
4969 return gfc_finish_block (&block);
4973 /* There are quite a lot of restrictions on the optimisation in using an
4974 array function assign without a temporary. */
4977 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
4980 bool seen_array_ref;
4982 gfc_symbol *sym = expr1->symtree->n.sym;
4984 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4985 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4988 /* Elemental functions are scalarized so that they don't need a
4989 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
4990 they would need special treatment in gfc_trans_arrayfunc_assign. */
4991 if (expr2->value.function.esym != NULL
4992 && expr2->value.function.esym->attr.elemental)
4995 /* Need a temporary if rhs is not FULL or a contiguous section. */
4996 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4999 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5000 if (gfc_ref_needs_temporary_p (expr1->ref))
5003 /* Functions returning pointers need temporaries. */
5004 if (expr2->symtree->n.sym->attr.pointer
5005 || expr2->symtree->n.sym->attr.allocatable)
5008 /* Character array functions need temporaries unless the
5009 character lengths are the same. */
5010 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5012 if (expr1->ts.u.cl->length == NULL
5013 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5016 if (expr2->ts.u.cl->length == NULL
5017 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5020 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5021 expr2->ts.u.cl->length->value.integer) != 0)
5025 /* Check that no LHS component references appear during an array
5026 reference. This is needed because we do not have the means to
5027 span any arbitrary stride with an array descriptor. This check
5028 is not needed for the rhs because the function result has to be
5030 seen_array_ref = false;
5031 for (ref = expr1->ref; ref; ref = ref->next)
5033 if (ref->type == REF_ARRAY)
5034 seen_array_ref= true;
5035 else if (ref->type == REF_COMPONENT && seen_array_ref)
5039 /* Check for a dependency. */
5040 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5041 expr2->value.function.esym,
5042 expr2->value.function.actual,
5046 /* If we have reached here with an intrinsic function, we do not
5047 need a temporary. */
5048 if (expr2->value.function.isym)
5051 /* If the LHS is a dummy, we need a temporary if it is not
5053 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5056 /* A PURE function can unconditionally be called without a temporary. */
5057 if (expr2->value.function.esym != NULL
5058 && expr2->value.function.esym->attr.pure)
5061 /* TODO a function that could correctly be declared PURE but is not
5062 could do with returning false as well. */
5064 if (!sym->attr.use_assoc
5065 && !sym->attr.in_common
5066 && !sym->attr.pointer
5067 && !sym->attr.target
5068 && expr2->value.function.esym)
5070 /* A temporary is not needed if the function is not contained and
5071 the variable is local or host associated and not a pointer or
5073 if (!expr2->value.function.esym->attr.contained)
5076 /* A temporary is not needed if the lhs has never been host
5077 associated and the procedure is contained. */
5078 else if (!sym->attr.host_assoc)
5081 /* A temporary is not needed if the variable is local and not
5082 a pointer, a target or a result. */
5084 && expr2->value.function.esym->ns == sym->ns->parent)
5088 /* Default to temporary use. */
5093 /* Try to translate array(:) = func (...), where func is a transformational
5094 array function, without using a temporary. Returns NULL if this isn't the
5098 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5102 gfc_component *comp = NULL;
5104 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5107 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5109 gcc_assert (expr2->value.function.isym
5110 || (gfc_is_proc_ptr_comp (expr2, &comp)
5111 && comp && comp->attr.dimension)
5112 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5113 && expr2->value.function.esym->result->attr.dimension));
5115 ss = gfc_walk_expr (expr1);
5116 gcc_assert (ss != gfc_ss_terminator);
5117 gfc_init_se (&se, NULL);
5118 gfc_start_block (&se.pre);
5119 se.want_pointer = 1;
5121 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5123 if (expr1->ts.type == BT_DERIVED
5124 && expr1->ts.u.derived->attr.alloc_comp)
5127 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5129 gfc_add_expr_to_block (&se.pre, tmp);
5132 se.direct_byref = 1;
5133 se.ss = gfc_walk_expr (expr2);
5134 gcc_assert (se.ss != gfc_ss_terminator);
5135 gfc_conv_function_expr (&se, expr2);
5136 gfc_add_block_to_block (&se.pre, &se.post);
5138 return gfc_finish_block (&se.pre);
5142 /* Try to efficiently translate array(:) = 0. Return NULL if this
5146 gfc_trans_zero_assign (gfc_expr * expr)
5148 tree dest, len, type;
5152 sym = expr->symtree->n.sym;
5153 dest = gfc_get_symbol_decl (sym);
5155 type = TREE_TYPE (dest);
5156 if (POINTER_TYPE_P (type))
5157 type = TREE_TYPE (type);
5158 if (!GFC_ARRAY_TYPE_P (type))
5161 /* Determine the length of the array. */
5162 len = GFC_TYPE_ARRAY_SIZE (type);
5163 if (!len || TREE_CODE (len) != INTEGER_CST)
5166 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5167 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5168 fold_convert (gfc_array_index_type, tmp));
5170 /* If we are zeroing a local array avoid taking its address by emitting
5172 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5173 return build2 (MODIFY_EXPR, void_type_node,
5174 dest, build_constructor (TREE_TYPE (dest), NULL));
5176 /* Convert arguments to the correct types. */
5177 dest = fold_convert (pvoid_type_node, dest);
5178 len = fold_convert (size_type_node, len);
5180 /* Construct call to __builtin_memset. */
5181 tmp = build_call_expr_loc (input_location,
5182 built_in_decls[BUILT_IN_MEMSET],
5183 3, dest, integer_zero_node, len);
5184 return fold_convert (void_type_node, tmp);
5188 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5189 that constructs the call to __builtin_memcpy. */
5192 gfc_build_memcpy_call (tree dst, tree src, tree len)
5196 /* Convert arguments to the correct types. */
5197 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5198 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5200 dst = fold_convert (pvoid_type_node, dst);
5202 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5203 src = gfc_build_addr_expr (pvoid_type_node, src);
5205 src = fold_convert (pvoid_type_node, src);
5207 len = fold_convert (size_type_node, len);
5209 /* Construct call to __builtin_memcpy. */
5210 tmp = build_call_expr_loc (input_location,
5211 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5212 return fold_convert (void_type_node, tmp);
5216 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5217 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5218 source/rhs, both are gfc_full_array_ref_p which have been checked for
5222 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5224 tree dst, dlen, dtype;
5225 tree src, slen, stype;
5228 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5229 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5231 dtype = TREE_TYPE (dst);
5232 if (POINTER_TYPE_P (dtype))
5233 dtype = TREE_TYPE (dtype);
5234 stype = TREE_TYPE (src);
5235 if (POINTER_TYPE_P (stype))
5236 stype = TREE_TYPE (stype);
5238 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5241 /* Determine the lengths of the arrays. */
5242 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5243 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5245 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5246 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5247 fold_convert (gfc_array_index_type, tmp));
5249 slen = GFC_TYPE_ARRAY_SIZE (stype);
5250 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5252 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5253 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5254 fold_convert (gfc_array_index_type, tmp));
5256 /* Sanity check that they are the same. This should always be
5257 the case, as we should already have checked for conformance. */
5258 if (!tree_int_cst_equal (slen, dlen))
5261 return gfc_build_memcpy_call (dst, src, dlen);
5265 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5266 this can't be done. EXPR1 is the destination/lhs for which
5267 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5270 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5272 unsigned HOST_WIDE_INT nelem;
5278 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5282 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5283 dtype = TREE_TYPE (dst);
5284 if (POINTER_TYPE_P (dtype))
5285 dtype = TREE_TYPE (dtype);
5286 if (!GFC_ARRAY_TYPE_P (dtype))
5289 /* Determine the lengths of the array. */
5290 len = GFC_TYPE_ARRAY_SIZE (dtype);
5291 if (!len || TREE_CODE (len) != INTEGER_CST)
5294 /* Confirm that the constructor is the same size. */
5295 if (compare_tree_int (len, nelem) != 0)
5298 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5299 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5300 fold_convert (gfc_array_index_type, tmp));
5302 stype = gfc_typenode_for_spec (&expr2->ts);
5303 src = gfc_build_constant_array_constructor (expr2, stype);
5305 stype = TREE_TYPE (src);
5306 if (POINTER_TYPE_P (stype))
5307 stype = TREE_TYPE (stype);
5309 return gfc_build_memcpy_call (dst, src, len);
5313 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5314 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5315 init_flag indicates initialization expressions and dealloc that no
5316 deallocate prior assignment is needed (if in doubt, set true). */
5319 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5325 gfc_ss *lss_section;
5332 bool scalar_to_array;
5336 /* Assignment of the form lhs = rhs. */
5337 gfc_start_block (&block);
5339 gfc_init_se (&lse, NULL);
5340 gfc_init_se (&rse, NULL);
5343 lss = gfc_walk_expr (expr1);
5345 if (lss != gfc_ss_terminator)
5347 /* Allow the scalarizer to workshare array assignments. */
5348 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5349 ompws_flags |= OMPWS_SCALARIZER_WS;
5351 /* The assignment needs scalarization. */
5354 /* Find a non-scalar SS from the lhs. */
5355 while (lss_section != gfc_ss_terminator
5356 && lss_section->type != GFC_SS_SECTION)
5357 lss_section = lss_section->next;
5359 gcc_assert (lss_section != gfc_ss_terminator);
5361 /* Initialize the scalarizer. */
5362 gfc_init_loopinfo (&loop);
5365 rss = gfc_walk_expr (expr2);
5366 if (rss == gfc_ss_terminator)
5368 /* The rhs is scalar. Add a ss for the expression. */
5369 rss = gfc_get_ss ();
5370 rss->next = gfc_ss_terminator;
5371 rss->type = GFC_SS_SCALAR;
5374 /* Associate the SS with the loop. */
5375 gfc_add_ss_to_loop (&loop, lss);
5376 gfc_add_ss_to_loop (&loop, rss);
5378 /* Calculate the bounds of the scalarization. */
5379 gfc_conv_ss_startstride (&loop);
5380 /* Enable loop reversal. */
5381 for (n = 0; n < loop.dimen; n++)
5382 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5383 /* Resolve any data dependencies in the statement. */
5384 gfc_conv_resolve_dependencies (&loop, lss, rss);
5385 /* Setup the scalarizing loops. */
5386 gfc_conv_loop_setup (&loop, &expr2->where);
5388 /* Setup the gfc_se structures. */
5389 gfc_copy_loopinfo_to_se (&lse, &loop);
5390 gfc_copy_loopinfo_to_se (&rse, &loop);
5393 gfc_mark_ss_chain_used (rss, 1);
5394 if (loop.temp_ss == NULL)
5397 gfc_mark_ss_chain_used (lss, 1);
5401 lse.ss = loop.temp_ss;
5402 gfc_mark_ss_chain_used (lss, 3);
5403 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5406 /* Start the scalarized loop body. */
5407 gfc_start_scalarized_body (&loop, &body);
5410 gfc_init_block (&body);
5412 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5414 /* Translate the expression. */
5415 gfc_conv_expr (&rse, expr2);
5417 /* Stabilize a string length for temporaries. */
5418 if (expr2->ts.type == BT_CHARACTER)
5419 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5421 string_length = NULL_TREE;
5425 gfc_conv_tmp_array_ref (&lse);
5426 gfc_advance_se_ss_chain (&lse);
5427 if (expr2->ts.type == BT_CHARACTER)
5428 lse.string_length = string_length;
5431 gfc_conv_expr (&lse, expr1);
5433 /* Assignments of scalar derived types with allocatable components
5434 to arrays must be done with a deep copy and the rhs temporary
5435 must have its components deallocated afterwards. */
5436 scalar_to_array = (expr2->ts.type == BT_DERIVED
5437 && expr2->ts.u.derived->attr.alloc_comp
5438 && expr2->expr_type != EXPR_VARIABLE
5439 && !gfc_is_constant_expr (expr2)
5440 && expr1->rank && !expr2->rank);
5441 if (scalar_to_array && dealloc)
5443 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5444 gfc_add_expr_to_block (&loop.post, tmp);
5447 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5448 l_is_temp || init_flag,
5449 (expr2->expr_type == EXPR_VARIABLE)
5450 || scalar_to_array, dealloc);
5451 gfc_add_expr_to_block (&body, tmp);
5453 if (lss == gfc_ss_terminator)
5455 /* Use the scalar assignment as is. */
5456 gfc_add_block_to_block (&block, &body);
5460 gcc_assert (lse.ss == gfc_ss_terminator
5461 && rse.ss == gfc_ss_terminator);
5465 gfc_trans_scalarized_loop_boundary (&loop, &body);
5467 /* We need to copy the temporary to the actual lhs. */
5468 gfc_init_se (&lse, NULL);
5469 gfc_init_se (&rse, NULL);
5470 gfc_copy_loopinfo_to_se (&lse, &loop);
5471 gfc_copy_loopinfo_to_se (&rse, &loop);
5473 rse.ss = loop.temp_ss;
5476 gfc_conv_tmp_array_ref (&rse);
5477 gfc_advance_se_ss_chain (&rse);
5478 gfc_conv_expr (&lse, expr1);
5480 gcc_assert (lse.ss == gfc_ss_terminator
5481 && rse.ss == gfc_ss_terminator);
5483 if (expr2->ts.type == BT_CHARACTER)
5484 rse.string_length = string_length;
5486 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5487 false, false, dealloc);
5488 gfc_add_expr_to_block (&body, tmp);
5491 /* Generate the copying loops. */
5492 gfc_trans_scalarizing_loops (&loop, &body);
5494 /* Wrap the whole thing up. */
5495 gfc_add_block_to_block (&block, &loop.pre);
5496 gfc_add_block_to_block (&block, &loop.post);
5498 gfc_cleanup_loop (&loop);
5501 return gfc_finish_block (&block);
5505 /* Check whether EXPR is a copyable array. */
5508 copyable_array_p (gfc_expr * expr)
5510 if (expr->expr_type != EXPR_VARIABLE)
5513 /* First check it's an array. */
5514 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5517 if (!gfc_full_array_ref_p (expr->ref, NULL))
5520 /* Next check that it's of a simple enough type. */
5521 switch (expr->ts.type)
5533 return !expr->ts.u.derived->attr.alloc_comp;
5542 /* Translate an assignment. */
5545 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5550 /* Special case a single function returning an array. */
5551 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5553 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5558 /* Special case assigning an array to zero. */
5559 if (copyable_array_p (expr1)
5560 && is_zero_initializer_p (expr2))
5562 tmp = gfc_trans_zero_assign (expr1);
5567 /* Special case copying one array to another. */
5568 if (copyable_array_p (expr1)
5569 && copyable_array_p (expr2)
5570 && gfc_compare_types (&expr1->ts, &expr2->ts)
5571 && !gfc_check_dependency (expr1, expr2, 0))
5573 tmp = gfc_trans_array_copy (expr1, expr2);
5578 /* Special case initializing an array from a constant array constructor. */
5579 if (copyable_array_p (expr1)
5580 && expr2->expr_type == EXPR_ARRAY
5581 && gfc_compare_types (&expr1->ts, &expr2->ts))
5583 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5588 /* Fallback to the scalarizer to generate explicit loops. */
5589 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5593 gfc_trans_init_assign (gfc_code * code)
5595 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5599 gfc_trans_assign (gfc_code * code)
5601 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5605 /* Generate code to assign typebound procedures to a derived vtab. */
5606 void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
5610 tree vtb, ctree, proc, cond = NULL_TREE;
5613 /* Point to the first procedure pointer. */
5614 cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
5619 vtb = gfc_get_symbol_decl (vtab);
5621 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), vtb,
5622 cmp->backend_decl, NULL_TREE);
5623 cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
5624 build_int_cst (TREE_TYPE (ctree), 0));
5626 gfc_init_block (&body);
5627 for (; cmp; cmp = cmp->next)
5629 gfc_symbol *target = NULL;
5631 /* This is required when typebound generic procedures are called
5632 with derived type targets. The specific procedures do not get
5633 added to the vtype, which remains "empty". */
5634 if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
5635 target = cmp->tb->u.specific->n.sym;
5639 st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
5640 if (st->n.tb && st->n.tb->u.specific)
5641 target = st->n.tb->u.specific->n.sym;
5647 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5648 vtb, cmp->backend_decl, NULL_TREE);
5649 proc = gfc_get_symbol_decl (target);
5650 proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
5651 gfc_add_modify (&body, ctree, proc);
5654 proc = gfc_finish_block (&body);
5656 proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
5658 gfc_add_expr_to_block (block, proc);
5662 /* Special case for initializing a CLASS variable on allocation.
5663 A MEMCPY is needed to copy the full data of the dynamic type,
5664 which may be different from the declared type. */
5667 gfc_trans_class_init_assign (gfc_code *code)
5673 gfc_start_block (&block);
5675 gfc_init_se (&dst, NULL);
5676 gfc_init_se (&src, NULL);
5677 gfc_add_component_ref (code->expr1, "$data");
5678 gfc_conv_expr (&dst, code->expr1);
5679 gfc_conv_expr (&src, code->expr2);
5680 gfc_add_block_to_block (&block, &src.pre);
5681 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5682 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5683 gfc_add_expr_to_block (&block, tmp);
5685 return gfc_finish_block (&block);
5689 /* Translate an assignment to a CLASS object
5690 (pointer or ordinary assignment). */
5693 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5700 gfc_start_block (&block);
5702 if (expr2->ts.type != BT_CLASS)
5704 /* Insert an additional assignment which sets the '$vptr' field. */
5705 lhs = gfc_copy_expr (expr1);
5706 gfc_add_component_ref (lhs, "$vptr");
5707 if (expr2->ts.type == BT_DERIVED)
5711 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
5713 gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
5714 rhs = gfc_get_expr ();
5715 rhs->expr_type = EXPR_VARIABLE;
5716 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5720 else if (expr2->expr_type == EXPR_NULL)
5721 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5725 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5726 gfc_add_expr_to_block (&block, tmp);
5728 gfc_free_expr (lhs);
5729 gfc_free_expr (rhs);
5732 /* Do the actual CLASS assignment. */
5733 if (expr2->ts.type == BT_CLASS)
5736 gfc_add_component_ref (expr1, "$data");
5738 if (op == EXEC_ASSIGN)
5739 tmp = gfc_trans_assignment (expr1, expr2, false, true);
5740 else if (op == EXEC_POINTER_ASSIGN)
5741 tmp = gfc_trans_pointer_assignment (expr1, expr2);
5745 gfc_add_expr_to_block (&block, tmp);
5747 return gfc_finish_block (&block);