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)
679 || sym->attr.function
681 || !sym->attr.dimension))
682 se->expr = build_fold_indirect_ref_loc (input_location,
689 /* For character variables, also get the length. */
690 if (sym->ts.type == BT_CHARACTER)
692 /* If the character length of an entry isn't set, get the length from
693 the master function instead. */
694 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
695 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
697 se->string_length = sym->ts.u.cl->backend_decl;
698 gcc_assert (se->string_length);
706 /* Return the descriptor if that's what we want and this is an array
707 section reference. */
708 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
710 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
711 /* Return the descriptor for array pointers and allocations. */
713 && ref->next == NULL && (se->descriptor_only))
716 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
717 /* Return a pointer to an element. */
721 if (ref->u.c.sym->attr.extension)
722 conv_parent_component_references (se, ref);
724 gfc_conv_component_ref (se, ref);
728 gfc_conv_substring (se, ref, expr->ts.kind,
729 expr->symtree->name, &expr->where);
738 /* Pointer assignment, allocation or pass by reference. Arrays are handled
740 if (se->want_pointer)
742 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
743 gfc_conv_string_parameter (se);
745 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
750 /* Unary ops are easy... Or they would be if ! was a valid op. */
753 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
758 gcc_assert (expr->ts.type != BT_CHARACTER);
759 /* Initialize the operand. */
760 gfc_init_se (&operand, se);
761 gfc_conv_expr_val (&operand, expr->value.op.op1);
762 gfc_add_block_to_block (&se->pre, &operand.pre);
764 type = gfc_typenode_for_spec (&expr->ts);
766 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
767 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
768 All other unary operators have an equivalent GIMPLE unary operator. */
769 if (code == TRUTH_NOT_EXPR)
770 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
771 build_int_cst (type, 0));
773 se->expr = fold_build1 (code, type, operand.expr);
777 /* Expand power operator to optimal multiplications when a value is raised
778 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
779 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
780 Programming", 3rd Edition, 1998. */
782 /* This code is mostly duplicated from expand_powi in the backend.
783 We establish the "optimal power tree" lookup table with the defined size.
784 The items in the table are the exponents used to calculate the index
785 exponents. Any integer n less than the value can get an "addition chain",
786 with the first node being one. */
787 #define POWI_TABLE_SIZE 256
789 /* The table is from builtins.c. */
790 static const unsigned char powi_table[POWI_TABLE_SIZE] =
792 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
793 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
794 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
795 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
796 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
797 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
798 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
799 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
800 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
801 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
802 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
803 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
804 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
805 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
806 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
807 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
808 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
809 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
810 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
811 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
812 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
813 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
814 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
815 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
816 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
817 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
818 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
819 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
820 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
821 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
822 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
823 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
826 /* If n is larger than lookup table's max index, we use the "window
828 #define POWI_WINDOW_SIZE 3
830 /* Recursive function to expand the power operator. The temporary
831 values are put in tmpvar. The function returns tmpvar[1] ** n. */
833 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
840 if (n < POWI_TABLE_SIZE)
845 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
846 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
850 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
851 op0 = gfc_conv_powi (se, n - digit, tmpvar);
852 op1 = gfc_conv_powi (se, digit, tmpvar);
856 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
860 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
861 tmp = gfc_evaluate_now (tmp, &se->pre);
863 if (n < POWI_TABLE_SIZE)
870 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
871 return 1. Else return 0 and a call to runtime library functions
872 will have to be built. */
874 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
879 tree vartmp[POWI_TABLE_SIZE];
881 unsigned HOST_WIDE_INT n;
884 /* If exponent is too large, we won't expand it anyway, so don't bother
885 with large integer values. */
886 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
889 m = double_int_to_shwi (TREE_INT_CST (rhs));
890 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
891 of the asymmetric range of the integer type. */
892 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
894 type = TREE_TYPE (lhs);
895 sgn = tree_int_cst_sgn (rhs);
897 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
898 || optimize_size) && (m > 2 || m < -1))
904 se->expr = gfc_build_const (type, integer_one_node);
908 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
909 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
911 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
912 lhs, build_int_cst (TREE_TYPE (lhs), -1));
913 cond = fold_build2 (EQ_EXPR, boolean_type_node,
914 lhs, build_int_cst (TREE_TYPE (lhs), 1));
917 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
920 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
921 se->expr = fold_build3 (COND_EXPR, type,
922 tmp, build_int_cst (type, 1),
923 build_int_cst (type, 0));
927 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
928 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
929 build_int_cst (type, 0));
930 se->expr = fold_build3 (COND_EXPR, type,
931 cond, build_int_cst (type, 1), tmp);
935 memset (vartmp, 0, sizeof (vartmp));
939 tmp = gfc_build_const (type, integer_one_node);
940 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
943 se->expr = gfc_conv_powi (se, n, vartmp);
949 /* Power op (**). Constant integer exponent has special handling. */
952 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
954 tree gfc_int4_type_node;
961 gfc_init_se (&lse, se);
962 gfc_conv_expr_val (&lse, expr->value.op.op1);
963 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
964 gfc_add_block_to_block (&se->pre, &lse.pre);
966 gfc_init_se (&rse, se);
967 gfc_conv_expr_val (&rse, expr->value.op.op2);
968 gfc_add_block_to_block (&se->pre, &rse.pre);
970 if (expr->value.op.op2->ts.type == BT_INTEGER
971 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
972 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
975 gfc_int4_type_node = gfc_get_int_type (4);
977 kind = expr->value.op.op1->ts.kind;
978 switch (expr->value.op.op2->ts.type)
981 ikind = expr->value.op.op2->ts.kind;
986 rse.expr = convert (gfc_int4_type_node, rse.expr);
1008 if (expr->value.op.op1->ts.type == BT_INTEGER)
1009 lse.expr = convert (gfc_int4_type_node, lse.expr);
1034 switch (expr->value.op.op1->ts.type)
1037 if (kind == 3) /* Case 16 was not handled properly above. */
1039 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1043 /* Use builtins for real ** int4. */
1049 fndecl = built_in_decls[BUILT_IN_POWIF];
1053 fndecl = built_in_decls[BUILT_IN_POWI];
1058 fndecl = built_in_decls[BUILT_IN_POWIL];
1066 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1070 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1082 fndecl = built_in_decls[BUILT_IN_POWF];
1085 fndecl = built_in_decls[BUILT_IN_POW];
1089 fndecl = built_in_decls[BUILT_IN_POWL];
1100 fndecl = built_in_decls[BUILT_IN_CPOWF];
1103 fndecl = built_in_decls[BUILT_IN_CPOW];
1107 fndecl = built_in_decls[BUILT_IN_CPOWL];
1119 se->expr = build_call_expr_loc (input_location,
1120 fndecl, 2, lse.expr, rse.expr);
1124 /* Generate code to allocate a string temporary. */
1127 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1132 if (gfc_can_put_var_on_stack (len))
1134 /* Create a temporary variable to hold the result. */
1135 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1136 build_int_cst (gfc_charlen_type_node, 1));
1137 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1139 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1140 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1142 tmp = build_array_type (TREE_TYPE (type), tmp);
1144 var = gfc_create_var (tmp, "str");
1145 var = gfc_build_addr_expr (type, var);
1149 /* Allocate a temporary to hold the result. */
1150 var = gfc_create_var (type, "pstr");
1151 tmp = gfc_call_malloc (&se->pre, type,
1152 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1153 fold_convert (TREE_TYPE (len),
1154 TYPE_SIZE (type))));
1155 gfc_add_modify (&se->pre, var, tmp);
1157 /* Free the temporary afterwards. */
1158 tmp = gfc_call_free (convert (pvoid_type_node, var));
1159 gfc_add_expr_to_block (&se->post, tmp);
1166 /* Handle a string concatenation operation. A temporary will be allocated to
1170 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1173 tree len, type, var, tmp, fndecl;
1175 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1176 && expr->value.op.op2->ts.type == BT_CHARACTER);
1177 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1179 gfc_init_se (&lse, se);
1180 gfc_conv_expr (&lse, expr->value.op.op1);
1181 gfc_conv_string_parameter (&lse);
1182 gfc_init_se (&rse, se);
1183 gfc_conv_expr (&rse, expr->value.op.op2);
1184 gfc_conv_string_parameter (&rse);
1186 gfc_add_block_to_block (&se->pre, &lse.pre);
1187 gfc_add_block_to_block (&se->pre, &rse.pre);
1189 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1190 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1191 if (len == NULL_TREE)
1193 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1194 lse.string_length, rse.string_length);
1197 type = build_pointer_type (type);
1199 var = gfc_conv_string_tmp (se, type, len);
1201 /* Do the actual concatenation. */
1202 if (expr->ts.kind == 1)
1203 fndecl = gfor_fndecl_concat_string;
1204 else if (expr->ts.kind == 4)
1205 fndecl = gfor_fndecl_concat_string_char4;
1209 tmp = build_call_expr_loc (input_location,
1210 fndecl, 6, len, var, lse.string_length, lse.expr,
1211 rse.string_length, rse.expr);
1212 gfc_add_expr_to_block (&se->pre, tmp);
1214 /* Add the cleanup for the operands. */
1215 gfc_add_block_to_block (&se->pre, &rse.post);
1216 gfc_add_block_to_block (&se->pre, &lse.post);
1219 se->string_length = len;
1222 /* Translates an op expression. Common (binary) cases are handled by this
1223 function, others are passed on. Recursion is used in either case.
1224 We use the fact that (op1.ts == op2.ts) (except for the power
1226 Operators need no special handling for scalarized expressions as long as
1227 they call gfc_conv_simple_val to get their operands.
1228 Character strings get special handling. */
1231 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1233 enum tree_code code;
1242 switch (expr->value.op.op)
1244 case INTRINSIC_PARENTHESES:
1245 if ((expr->ts.type == BT_REAL
1246 || expr->ts.type == BT_COMPLEX)
1247 && gfc_option.flag_protect_parens)
1249 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1250 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1255 case INTRINSIC_UPLUS:
1256 gfc_conv_expr (se, expr->value.op.op1);
1259 case INTRINSIC_UMINUS:
1260 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1264 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1267 case INTRINSIC_PLUS:
1271 case INTRINSIC_MINUS:
1275 case INTRINSIC_TIMES:
1279 case INTRINSIC_DIVIDE:
1280 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1281 an integer, we must round towards zero, so we use a
1283 if (expr->ts.type == BT_INTEGER)
1284 code = TRUNC_DIV_EXPR;
1289 case INTRINSIC_POWER:
1290 gfc_conv_power_op (se, expr);
1293 case INTRINSIC_CONCAT:
1294 gfc_conv_concat_op (se, expr);
1298 code = TRUTH_ANDIF_EXPR;
1303 code = TRUTH_ORIF_EXPR;
1307 /* EQV and NEQV only work on logicals, but since we represent them
1308 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1310 case INTRINSIC_EQ_OS:
1318 case INTRINSIC_NE_OS:
1319 case INTRINSIC_NEQV:
1326 case INTRINSIC_GT_OS:
1333 case INTRINSIC_GE_OS:
1340 case INTRINSIC_LT_OS:
1347 case INTRINSIC_LE_OS:
1353 case INTRINSIC_USER:
1354 case INTRINSIC_ASSIGN:
1355 /* These should be converted into function calls by the frontend. */
1359 fatal_error ("Unknown intrinsic op");
1363 /* The only exception to this is **, which is handled separately anyway. */
1364 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1366 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1370 gfc_init_se (&lse, se);
1371 gfc_conv_expr (&lse, expr->value.op.op1);
1372 gfc_add_block_to_block (&se->pre, &lse.pre);
1375 gfc_init_se (&rse, se);
1376 gfc_conv_expr (&rse, expr->value.op.op2);
1377 gfc_add_block_to_block (&se->pre, &rse.pre);
1381 gfc_conv_string_parameter (&lse);
1382 gfc_conv_string_parameter (&rse);
1384 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1385 rse.string_length, rse.expr,
1386 expr->value.op.op1->ts.kind,
1388 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1389 gfc_add_block_to_block (&lse.post, &rse.post);
1392 type = gfc_typenode_for_spec (&expr->ts);
1396 /* The result of logical ops is always boolean_type_node. */
1397 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1398 se->expr = convert (type, tmp);
1401 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1403 /* Add the post blocks. */
1404 gfc_add_block_to_block (&se->post, &rse.post);
1405 gfc_add_block_to_block (&se->post, &lse.post);
1408 /* If a string's length is one, we convert it to a single character. */
1411 gfc_string_to_single_character (tree len, tree str, int kind)
1413 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1415 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
1418 if (TREE_INT_CST_LOW (len) == 1)
1420 str = fold_convert (gfc_get_pchar_type (kind), str);
1421 return build_fold_indirect_ref_loc (input_location, str);
1425 && TREE_CODE (str) == ADDR_EXPR
1426 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1427 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1428 && array_ref_low_bound (TREE_OPERAND (str, 0))
1429 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1430 && TREE_INT_CST_LOW (len) > 1
1431 && TREE_INT_CST_LOW (len)
1432 == (unsigned HOST_WIDE_INT)
1433 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1435 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1436 ret = build_fold_indirect_ref_loc (input_location, ret);
1437 if (TREE_CODE (ret) == INTEGER_CST)
1439 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1440 int i, length = TREE_STRING_LENGTH (string_cst);
1441 const char *ptr = TREE_STRING_POINTER (string_cst);
1443 for (i = 1; i < length; i++)
1456 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1459 if (sym->backend_decl)
1461 /* This becomes the nominal_type in
1462 function.c:assign_parm_find_data_types. */
1463 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1464 /* This becomes the passed_type in
1465 function.c:assign_parm_find_data_types. C promotes char to
1466 integer for argument passing. */
1467 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1469 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1474 /* If we have a constant character expression, make it into an
1476 if ((*expr)->expr_type == EXPR_CONSTANT)
1481 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1482 (int)(*expr)->value.character.string[0]);
1483 if ((*expr)->ts.kind != gfc_c_int_kind)
1485 /* The expr needs to be compatible with a C int. If the
1486 conversion fails, then the 2 causes an ICE. */
1487 ts.type = BT_INTEGER;
1488 ts.kind = gfc_c_int_kind;
1489 gfc_convert_type (*expr, &ts, 2);
1492 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1494 if ((*expr)->ref == NULL)
1496 se->expr = gfc_string_to_single_character
1497 (build_int_cst (integer_type_node, 1),
1498 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1500 ((*expr)->symtree->n.sym)),
1505 gfc_conv_variable (se, *expr);
1506 se->expr = gfc_string_to_single_character
1507 (build_int_cst (integer_type_node, 1),
1508 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1516 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1517 if STR is a string literal, otherwise return -1. */
1520 gfc_optimize_len_trim (tree len, tree str, int kind)
1523 && TREE_CODE (str) == ADDR_EXPR
1524 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1525 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1526 && array_ref_low_bound (TREE_OPERAND (str, 0))
1527 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1528 && TREE_INT_CST_LOW (len) >= 1
1529 && TREE_INT_CST_LOW (len)
1530 == (unsigned HOST_WIDE_INT)
1531 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1533 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1534 folded = build_fold_indirect_ref_loc (input_location, folded);
1535 if (TREE_CODE (folded) == INTEGER_CST)
1537 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1538 int length = TREE_STRING_LENGTH (string_cst);
1539 const char *ptr = TREE_STRING_POINTER (string_cst);
1541 for (; length > 0; length--)
1542 if (ptr[length - 1] != ' ')
1551 /* Compare two strings. If they are all single characters, the result is the
1552 subtraction of them. Otherwise, we build a library call. */
1555 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1556 enum tree_code code)
1562 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1563 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1565 sc1 = gfc_string_to_single_character (len1, str1, kind);
1566 sc2 = gfc_string_to_single_character (len2, str2, kind);
1568 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1570 /* Deal with single character specially. */
1571 sc1 = fold_convert (integer_type_node, sc1);
1572 sc2 = fold_convert (integer_type_node, sc2);
1573 return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1576 if ((code == EQ_EXPR || code == NE_EXPR)
1578 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1580 /* If one string is a string literal with LEN_TRIM longer
1581 than the length of the second string, the strings
1583 int len = gfc_optimize_len_trim (len1, str1, kind);
1584 if (len > 0 && compare_tree_int (len2, len) < 0)
1585 return integer_one_node;
1586 len = gfc_optimize_len_trim (len2, str2, kind);
1587 if (len > 0 && compare_tree_int (len1, len) < 0)
1588 return integer_one_node;
1591 /* Build a call for the comparison. */
1593 fndecl = gfor_fndecl_compare_string;
1595 fndecl = gfor_fndecl_compare_string_char4;
1599 return build_call_expr_loc (input_location, fndecl, 4,
1600 len1, str1, len2, str2);
1604 /* Return the backend_decl for a procedure pointer component. */
1607 get_proc_ptr_comp (gfc_expr *e)
1611 gfc_init_se (&comp_se, NULL);
1612 e2 = gfc_copy_expr (e);
1613 e2->expr_type = EXPR_VARIABLE;
1614 gfc_conv_expr (&comp_se, e2);
1616 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1621 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1625 if (gfc_is_proc_ptr_comp (expr, NULL))
1626 tmp = get_proc_ptr_comp (expr);
1627 else if (sym->attr.dummy)
1629 tmp = gfc_get_symbol_decl (sym);
1630 if (sym->attr.proc_pointer)
1631 tmp = build_fold_indirect_ref_loc (input_location,
1633 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1634 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1638 if (!sym->backend_decl)
1639 sym->backend_decl = gfc_get_extern_function_decl (sym);
1641 tmp = sym->backend_decl;
1643 if (sym->attr.cray_pointee)
1645 /* TODO - make the cray pointee a pointer to a procedure,
1646 assign the pointer to it and use it for the call. This
1648 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1649 gfc_get_symbol_decl (sym->cp_pointer));
1650 tmp = gfc_evaluate_now (tmp, &se->pre);
1653 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1655 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1656 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1663 /* Initialize MAPPING. */
1666 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1668 mapping->syms = NULL;
1669 mapping->charlens = NULL;
1673 /* Free all memory held by MAPPING (but not MAPPING itself). */
1676 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1678 gfc_interface_sym_mapping *sym;
1679 gfc_interface_sym_mapping *nextsym;
1681 gfc_charlen *nextcl;
1683 for (sym = mapping->syms; sym; sym = nextsym)
1685 nextsym = sym->next;
1686 sym->new_sym->n.sym->formal = NULL;
1687 gfc_free_symbol (sym->new_sym->n.sym);
1688 gfc_free_expr (sym->expr);
1689 gfc_free (sym->new_sym);
1692 for (cl = mapping->charlens; cl; cl = nextcl)
1695 gfc_free_expr (cl->length);
1701 /* Return a copy of gfc_charlen CL. Add the returned structure to
1702 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1704 static gfc_charlen *
1705 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1708 gfc_charlen *new_charlen;
1710 new_charlen = gfc_get_charlen ();
1711 new_charlen->next = mapping->charlens;
1712 new_charlen->length = gfc_copy_expr (cl->length);
1714 mapping->charlens = new_charlen;
1719 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1720 array variable that can be used as the actual argument for dummy
1721 argument SYM. Add any initialization code to BLOCK. PACKED is as
1722 for gfc_get_nodesc_array_type and DATA points to the first element
1723 in the passed array. */
1726 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1727 gfc_packed packed, tree data)
1732 type = gfc_typenode_for_spec (&sym->ts);
1733 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1734 !sym->attr.target && !sym->attr.pointer
1735 && !sym->attr.proc_pointer);
1737 var = gfc_create_var (type, "ifm");
1738 gfc_add_modify (block, var, fold_convert (type, data));
1744 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1745 and offset of descriptorless array type TYPE given that it has the same
1746 size as DESC. Add any set-up code to BLOCK. */
1749 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1756 offset = gfc_index_zero_node;
1757 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1759 dim = gfc_rank_cst[n];
1760 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1761 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1763 GFC_TYPE_ARRAY_LBOUND (type, n)
1764 = gfc_conv_descriptor_lbound_get (desc, dim);
1765 GFC_TYPE_ARRAY_UBOUND (type, n)
1766 = gfc_conv_descriptor_ubound_get (desc, dim);
1768 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1770 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1771 gfc_conv_descriptor_ubound_get (desc, dim),
1772 gfc_conv_descriptor_lbound_get (desc, dim));
1773 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1774 GFC_TYPE_ARRAY_LBOUND (type, n),
1776 tmp = gfc_evaluate_now (tmp, block);
1777 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1779 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1780 GFC_TYPE_ARRAY_LBOUND (type, n),
1781 GFC_TYPE_ARRAY_STRIDE (type, n));
1782 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1784 offset = gfc_evaluate_now (offset, block);
1785 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1789 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1790 in SE. The caller may still use se->expr and se->string_length after
1791 calling this function. */
1794 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1795 gfc_symbol * sym, gfc_se * se,
1798 gfc_interface_sym_mapping *sm;
1802 gfc_symbol *new_sym;
1804 gfc_symtree *new_symtree;
1806 /* Create a new symbol to represent the actual argument. */
1807 new_sym = gfc_new_symbol (sym->name, NULL);
1808 new_sym->ts = sym->ts;
1809 new_sym->as = gfc_copy_array_spec (sym->as);
1810 new_sym->attr.referenced = 1;
1811 new_sym->attr.dimension = sym->attr.dimension;
1812 new_sym->attr.contiguous = sym->attr.contiguous;
1813 new_sym->attr.codimension = sym->attr.codimension;
1814 new_sym->attr.pointer = sym->attr.pointer;
1815 new_sym->attr.allocatable = sym->attr.allocatable;
1816 new_sym->attr.flavor = sym->attr.flavor;
1817 new_sym->attr.function = sym->attr.function;
1819 /* Ensure that the interface is available and that
1820 descriptors are passed for array actual arguments. */
1821 if (sym->attr.flavor == FL_PROCEDURE)
1823 new_sym->formal = expr->symtree->n.sym->formal;
1824 new_sym->attr.always_explicit
1825 = expr->symtree->n.sym->attr.always_explicit;
1828 /* Create a fake symtree for it. */
1830 new_symtree = gfc_new_symtree (&root, sym->name);
1831 new_symtree->n.sym = new_sym;
1832 gcc_assert (new_symtree == root);
1834 /* Create a dummy->actual mapping. */
1835 sm = XCNEW (gfc_interface_sym_mapping);
1836 sm->next = mapping->syms;
1838 sm->new_sym = new_symtree;
1839 sm->expr = gfc_copy_expr (expr);
1842 /* Stabilize the argument's value. */
1843 if (!sym->attr.function && se)
1844 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1846 if (sym->ts.type == BT_CHARACTER)
1848 /* Create a copy of the dummy argument's length. */
1849 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1850 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1852 /* If the length is specified as "*", record the length that
1853 the caller is passing. We should use the callee's length
1854 in all other cases. */
1855 if (!new_sym->ts.u.cl->length && se)
1857 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1858 new_sym->ts.u.cl->backend_decl = se->string_length;
1865 /* Use the passed value as-is if the argument is a function. */
1866 if (sym->attr.flavor == FL_PROCEDURE)
1869 /* If the argument is either a string or a pointer to a string,
1870 convert it to a boundless character type. */
1871 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1873 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1874 tmp = build_pointer_type (tmp);
1875 if (sym->attr.pointer)
1876 value = build_fold_indirect_ref_loc (input_location,
1880 value = fold_convert (tmp, value);
1883 /* If the argument is a scalar, a pointer to an array or an allocatable,
1885 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1886 value = build_fold_indirect_ref_loc (input_location,
1889 /* For character(*), use the actual argument's descriptor. */
1890 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1891 value = build_fold_indirect_ref_loc (input_location,
1894 /* If the argument is an array descriptor, use it to determine
1895 information about the actual argument's shape. */
1896 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1897 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1899 /* Get the actual argument's descriptor. */
1900 desc = build_fold_indirect_ref_loc (input_location,
1903 /* Create the replacement variable. */
1904 tmp = gfc_conv_descriptor_data_get (desc);
1905 value = gfc_get_interface_mapping_array (&se->pre, sym,
1908 /* Use DESC to work out the upper bounds, strides and offset. */
1909 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1912 /* Otherwise we have a packed array. */
1913 value = gfc_get_interface_mapping_array (&se->pre, sym,
1914 PACKED_FULL, se->expr);
1916 new_sym->backend_decl = value;
1920 /* Called once all dummy argument mappings have been added to MAPPING,
1921 but before the mapping is used to evaluate expressions. Pre-evaluate
1922 the length of each argument, adding any initialization code to PRE and
1923 any finalization code to POST. */
1926 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1927 stmtblock_t * pre, stmtblock_t * post)
1929 gfc_interface_sym_mapping *sym;
1933 for (sym = mapping->syms; sym; sym = sym->next)
1934 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1935 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1937 expr = sym->new_sym->n.sym->ts.u.cl->length;
1938 gfc_apply_interface_mapping_to_expr (mapping, expr);
1939 gfc_init_se (&se, NULL);
1940 gfc_conv_expr (&se, expr);
1941 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1942 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1943 gfc_add_block_to_block (pre, &se.pre);
1944 gfc_add_block_to_block (post, &se.post);
1946 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1951 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1955 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1956 gfc_constructor_base base)
1959 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1961 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1964 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1965 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1966 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1972 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1976 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1981 for (; ref; ref = ref->next)
1985 for (n = 0; n < ref->u.ar.dimen; n++)
1987 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1988 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1989 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1991 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1998 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1999 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2005 /* Convert intrinsic function calls into result expressions. */
2008 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2016 arg1 = expr->value.function.actual->expr;
2017 if (expr->value.function.actual->next)
2018 arg2 = expr->value.function.actual->next->expr;
2022 sym = arg1->symtree->n.sym;
2024 if (sym->attr.dummy)
2029 switch (expr->value.function.isym->id)
2032 /* TODO figure out why this condition is necessary. */
2033 if (sym->attr.function
2034 && (arg1->ts.u.cl->length == NULL
2035 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2036 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2039 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2043 if (!sym->as || sym->as->rank == 0)
2046 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2048 dup = mpz_get_si (arg2->value.integer);
2053 dup = sym->as->rank;
2057 for (; d < dup; d++)
2061 if (!sym->as->upper[d] || !sym->as->lower[d])
2063 gfc_free_expr (new_expr);
2067 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2068 gfc_get_int_expr (gfc_default_integer_kind,
2070 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2072 new_expr = gfc_multiply (new_expr, tmp);
2078 case GFC_ISYM_LBOUND:
2079 case GFC_ISYM_UBOUND:
2080 /* TODO These implementations of lbound and ubound do not limit if
2081 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2083 if (!sym->as || sym->as->rank == 0)
2086 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2087 d = mpz_get_si (arg2->value.integer) - 1;
2089 /* TODO: If the need arises, this could produce an array of
2093 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2095 if (sym->as->lower[d])
2096 new_expr = gfc_copy_expr (sym->as->lower[d]);
2100 if (sym->as->upper[d])
2101 new_expr = gfc_copy_expr (sym->as->upper[d]);
2109 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2113 gfc_replace_expr (expr, new_expr);
2119 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2120 gfc_interface_mapping * mapping)
2122 gfc_formal_arglist *f;
2123 gfc_actual_arglist *actual;
2125 actual = expr->value.function.actual;
2126 f = map_expr->symtree->n.sym->formal;
2128 for (; f && actual; f = f->next, actual = actual->next)
2133 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2136 if (map_expr->symtree->n.sym->attr.dimension)
2141 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2143 for (d = 0; d < as->rank; d++)
2145 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2146 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2149 expr->value.function.esym->as = as;
2152 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2154 expr->value.function.esym->ts.u.cl->length
2155 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2157 gfc_apply_interface_mapping_to_expr (mapping,
2158 expr->value.function.esym->ts.u.cl->length);
2163 /* EXPR is a copy of an expression that appeared in the interface
2164 associated with MAPPING. Walk it recursively looking for references to
2165 dummy arguments that MAPPING maps to actual arguments. Replace each such
2166 reference with a reference to the associated actual argument. */
2169 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2172 gfc_interface_sym_mapping *sym;
2173 gfc_actual_arglist *actual;
2178 /* Copying an expression does not copy its length, so do that here. */
2179 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2181 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2182 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2185 /* Apply the mapping to any references. */
2186 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2188 /* ...and to the expression's symbol, if it has one. */
2189 /* TODO Find out why the condition on expr->symtree had to be moved into
2190 the loop rather than being outside it, as originally. */
2191 for (sym = mapping->syms; sym; sym = sym->next)
2192 if (expr->symtree && sym->old == expr->symtree->n.sym)
2194 if (sym->new_sym->n.sym->backend_decl)
2195 expr->symtree = sym->new_sym;
2197 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2200 /* ...and to subexpressions in expr->value. */
2201 switch (expr->expr_type)
2206 case EXPR_SUBSTRING:
2210 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2211 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2215 for (actual = expr->value.function.actual; actual; actual = actual->next)
2216 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2218 if (expr->value.function.esym == NULL
2219 && expr->value.function.isym != NULL
2220 && expr->value.function.actual->expr->symtree
2221 && gfc_map_intrinsic_function (expr, mapping))
2224 for (sym = mapping->syms; sym; sym = sym->next)
2225 if (sym->old == expr->value.function.esym)
2227 expr->value.function.esym = sym->new_sym->n.sym;
2228 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2229 expr->value.function.esym->result = sym->new_sym->n.sym;
2234 case EXPR_STRUCTURE:
2235 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2248 /* Evaluate interface expression EXPR using MAPPING. Store the result
2252 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2253 gfc_se * se, gfc_expr * expr)
2255 expr = gfc_copy_expr (expr);
2256 gfc_apply_interface_mapping_to_expr (mapping, expr);
2257 gfc_conv_expr (se, expr);
2258 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2259 gfc_free_expr (expr);
2263 /* Returns a reference to a temporary array into which a component of
2264 an actual argument derived type array is copied and then returned
2265 after the function call. */
2267 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2268 sym_intent intent, bool formal_ptr)
2286 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2288 gfc_init_se (&lse, NULL);
2289 gfc_init_se (&rse, NULL);
2291 /* Walk the argument expression. */
2292 rss = gfc_walk_expr (expr);
2294 gcc_assert (rss != gfc_ss_terminator);
2296 /* Initialize the scalarizer. */
2297 gfc_init_loopinfo (&loop);
2298 gfc_add_ss_to_loop (&loop, rss);
2300 /* Calculate the bounds of the scalarization. */
2301 gfc_conv_ss_startstride (&loop);
2303 /* Build an ss for the temporary. */
2304 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2305 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2307 base_type = gfc_typenode_for_spec (&expr->ts);
2308 if (GFC_ARRAY_TYPE_P (base_type)
2309 || GFC_DESCRIPTOR_TYPE_P (base_type))
2310 base_type = gfc_get_element_type (base_type);
2312 loop.temp_ss = gfc_get_ss ();;
2313 loop.temp_ss->type = GFC_SS_TEMP;
2314 loop.temp_ss->data.temp.type = base_type;
2316 if (expr->ts.type == BT_CHARACTER)
2317 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2319 loop.temp_ss->string_length = NULL;
2321 parmse->string_length = loop.temp_ss->string_length;
2322 loop.temp_ss->data.temp.dimen = loop.dimen;
2323 loop.temp_ss->next = gfc_ss_terminator;
2325 /* Associate the SS with the loop. */
2326 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2328 /* Setup the scalarizing loops. */
2329 gfc_conv_loop_setup (&loop, &expr->where);
2331 /* Pass the temporary descriptor back to the caller. */
2332 info = &loop.temp_ss->data.info;
2333 parmse->expr = info->descriptor;
2335 /* Setup the gfc_se structures. */
2336 gfc_copy_loopinfo_to_se (&lse, &loop);
2337 gfc_copy_loopinfo_to_se (&rse, &loop);
2340 lse.ss = loop.temp_ss;
2341 gfc_mark_ss_chain_used (rss, 1);
2342 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2344 /* Start the scalarized loop body. */
2345 gfc_start_scalarized_body (&loop, &body);
2347 /* Translate the expression. */
2348 gfc_conv_expr (&rse, expr);
2350 gfc_conv_tmp_array_ref (&lse);
2351 gfc_advance_se_ss_chain (&lse);
2353 if (intent != INTENT_OUT)
2355 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2356 gfc_add_expr_to_block (&body, tmp);
2357 gcc_assert (rse.ss == gfc_ss_terminator);
2358 gfc_trans_scalarizing_loops (&loop, &body);
2362 /* Make sure that the temporary declaration survives by merging
2363 all the loop declarations into the current context. */
2364 for (n = 0; n < loop.dimen; n++)
2366 gfc_merge_block_scope (&body);
2367 body = loop.code[loop.order[n]];
2369 gfc_merge_block_scope (&body);
2372 /* Add the post block after the second loop, so that any
2373 freeing of allocated memory is done at the right time. */
2374 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2376 /**********Copy the temporary back again.*********/
2378 gfc_init_se (&lse, NULL);
2379 gfc_init_se (&rse, NULL);
2381 /* Walk the argument expression. */
2382 lss = gfc_walk_expr (expr);
2383 rse.ss = loop.temp_ss;
2386 /* Initialize the scalarizer. */
2387 gfc_init_loopinfo (&loop2);
2388 gfc_add_ss_to_loop (&loop2, lss);
2390 /* Calculate the bounds of the scalarization. */
2391 gfc_conv_ss_startstride (&loop2);
2393 /* Setup the scalarizing loops. */
2394 gfc_conv_loop_setup (&loop2, &expr->where);
2396 gfc_copy_loopinfo_to_se (&lse, &loop2);
2397 gfc_copy_loopinfo_to_se (&rse, &loop2);
2399 gfc_mark_ss_chain_used (lss, 1);
2400 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2402 /* Declare the variable to hold the temporary offset and start the
2403 scalarized loop body. */
2404 offset = gfc_create_var (gfc_array_index_type, NULL);
2405 gfc_start_scalarized_body (&loop2, &body);
2407 /* Build the offsets for the temporary from the loop variables. The
2408 temporary array has lbounds of zero and strides of one in all
2409 dimensions, so this is very simple. The offset is only computed
2410 outside the innermost loop, so the overall transfer could be
2411 optimized further. */
2412 info = &rse.ss->data.info;
2413 dimen = info->dimen;
2415 tmp_index = gfc_index_zero_node;
2416 for (n = dimen - 1; n > 0; n--)
2419 tmp = rse.loop->loopvar[n];
2420 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2421 tmp, rse.loop->from[n]);
2422 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2425 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2426 rse.loop->to[n-1], rse.loop->from[n-1]);
2427 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2428 tmp_str, gfc_index_one_node);
2430 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2434 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2435 tmp_index, rse.loop->from[0]);
2436 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2438 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2439 rse.loop->loopvar[0], offset);
2441 /* Now use the offset for the reference. */
2442 tmp = build_fold_indirect_ref_loc (input_location,
2444 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2446 if (expr->ts.type == BT_CHARACTER)
2447 rse.string_length = expr->ts.u.cl->backend_decl;
2449 gfc_conv_expr (&lse, expr);
2451 gcc_assert (lse.ss == gfc_ss_terminator);
2453 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2454 gfc_add_expr_to_block (&body, tmp);
2456 /* Generate the copying loops. */
2457 gfc_trans_scalarizing_loops (&loop2, &body);
2459 /* Wrap the whole thing up by adding the second loop to the post-block
2460 and following it by the post-block of the first loop. In this way,
2461 if the temporary needs freeing, it is done after use! */
2462 if (intent != INTENT_IN)
2464 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2465 gfc_add_block_to_block (&parmse->post, &loop2.post);
2468 gfc_add_block_to_block (&parmse->post, &loop.post);
2470 gfc_cleanup_loop (&loop);
2471 gfc_cleanup_loop (&loop2);
2473 /* Pass the string length to the argument expression. */
2474 if (expr->ts.type == BT_CHARACTER)
2475 parmse->string_length = expr->ts.u.cl->backend_decl;
2477 /* Determine the offset for pointer formal arguments and set the
2481 size = gfc_index_one_node;
2482 offset = gfc_index_zero_node;
2483 for (n = 0; n < dimen; n++)
2485 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2487 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2488 tmp, gfc_index_one_node);
2489 gfc_conv_descriptor_ubound_set (&parmse->pre,
2493 gfc_conv_descriptor_lbound_set (&parmse->pre,
2496 gfc_index_one_node);
2497 size = gfc_evaluate_now (size, &parmse->pre);
2498 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2500 offset = gfc_evaluate_now (offset, &parmse->pre);
2501 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2502 rse.loop->to[n], rse.loop->from[n]);
2503 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2504 tmp, gfc_index_one_node);
2505 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2509 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2513 /* We want either the address for the data or the address of the descriptor,
2514 depending on the mode of passing array arguments. */
2516 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2518 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2524 /* Generate the code for argument list functions. */
2527 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2529 /* Pass by value for g77 %VAL(arg), pass the address
2530 indirectly for %LOC, else by reference. Thus %REF
2531 is a "do-nothing" and %LOC is the same as an F95
2533 if (strncmp (name, "%VAL", 4) == 0)
2534 gfc_conv_expr (se, expr);
2535 else if (strncmp (name, "%LOC", 4) == 0)
2537 gfc_conv_expr_reference (se, expr);
2538 se->expr = gfc_build_addr_expr (NULL, se->expr);
2540 else if (strncmp (name, "%REF", 4) == 0)
2541 gfc_conv_expr_reference (se, expr);
2543 gfc_error ("Unknown argument list function at %L", &expr->where);
2547 /* Takes a derived type expression and returns the address of a temporary
2548 class object of the 'declared' type. */
2550 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2551 gfc_typespec class_ts)
2555 gfc_symbol *declared = class_ts.u.derived;
2561 /* The derived type needs to be converted to a temporary
2563 tmp = gfc_typenode_for_spec (&class_ts);
2564 var = gfc_create_var (tmp, "class");
2567 cmp = gfc_find_component (declared, "$vptr", true, true);
2568 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2569 var, cmp->backend_decl, NULL_TREE);
2571 /* Remember the vtab corresponds to the derived type
2572 not to the class declared type. */
2573 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2575 gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
2576 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2577 gfc_add_modify (&parmse->pre, ctree,
2578 fold_convert (TREE_TYPE (ctree), tmp));
2580 /* Now set the data field. */
2581 cmp = gfc_find_component (declared, "$data", true, true);
2582 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2583 var, cmp->backend_decl, NULL_TREE);
2584 ss = gfc_walk_expr (e);
2585 if (ss == gfc_ss_terminator)
2588 gfc_conv_expr_reference (parmse, e);
2589 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2590 gfc_add_modify (&parmse->pre, ctree, tmp);
2595 gfc_conv_expr (parmse, e);
2596 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2599 /* Pass the address of the class object. */
2600 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2604 /* The following routine generates code for the intrinsic
2605 procedures from the ISO_C_BINDING module:
2607 * C_FUNLOC (function)
2608 * C_F_POINTER (subroutine)
2609 * C_F_PROCPOINTER (subroutine)
2610 * C_ASSOCIATED (function)
2611 One exception which is not handled here is C_F_POINTER with non-scalar
2612 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2615 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2616 gfc_actual_arglist * arg)
2621 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2623 if (arg->expr->rank == 0)
2624 gfc_conv_expr_reference (se, arg->expr);
2628 /* This is really the actual arg because no formal arglist is
2629 created for C_LOC. */
2630 fsym = arg->expr->symtree->n.sym;
2632 /* We should want it to do g77 calling convention. */
2634 && !(fsym->attr.pointer || fsym->attr.allocatable)
2635 && fsym->as->type != AS_ASSUMED_SHAPE;
2636 f = f || !sym->attr.always_explicit;
2638 argss = gfc_walk_expr (arg->expr);
2639 gfc_conv_array_parameter (se, arg->expr, argss, f,
2643 /* TODO -- the following two lines shouldn't be necessary, but if
2644 they're removed, a bug is exposed later in the code path.
2645 This workaround was thus introduced, but will have to be
2646 removed; please see PR 35150 for details about the issue. */
2647 se->expr = convert (pvoid_type_node, se->expr);
2648 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2652 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2654 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2655 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2656 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2657 gfc_conv_expr_reference (se, arg->expr);
2661 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2662 && arg->next->expr->rank == 0)
2663 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2665 /* Convert c_f_pointer if fptr is a scalar
2666 and convert c_f_procpointer. */
2670 gfc_init_se (&cptrse, NULL);
2671 gfc_conv_expr (&cptrse, arg->expr);
2672 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2673 gfc_add_block_to_block (&se->post, &cptrse.post);
2675 gfc_init_se (&fptrse, NULL);
2676 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2677 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2678 fptrse.want_pointer = 1;
2680 gfc_conv_expr (&fptrse, arg->next->expr);
2681 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2682 gfc_add_block_to_block (&se->post, &fptrse.post);
2684 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2685 && arg->next->expr->symtree->n.sym->attr.dummy)
2686 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2689 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2691 fold_convert (TREE_TYPE (fptrse.expr),
2696 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2701 /* Build the addr_expr for the first argument. The argument is
2702 already an *address* so we don't need to set want_pointer in
2704 gfc_init_se (&arg1se, NULL);
2705 gfc_conv_expr (&arg1se, arg->expr);
2706 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2707 gfc_add_block_to_block (&se->post, &arg1se.post);
2709 /* See if we were given two arguments. */
2710 if (arg->next == NULL)
2711 /* Only given one arg so generate a null and do a
2712 not-equal comparison against the first arg. */
2713 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2714 fold_convert (TREE_TYPE (arg1se.expr),
2715 null_pointer_node));
2721 /* Given two arguments so build the arg2se from second arg. */
2722 gfc_init_se (&arg2se, NULL);
2723 gfc_conv_expr (&arg2se, arg->next->expr);
2724 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2725 gfc_add_block_to_block (&se->post, &arg2se.post);
2727 /* Generate test to compare that the two args are equal. */
2728 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2729 arg1se.expr, arg2se.expr);
2730 /* Generate test to ensure that the first arg is not null. */
2731 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2732 arg1se.expr, null_pointer_node);
2734 /* Finally, the generated test must check that both arg1 is not
2735 NULL and that it is equal to the second arg. */
2736 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2737 not_null_expr, eq_expr);
2743 /* Nothing was done. */
2747 /* Generate code for a procedure call. Note can return se->post != NULL.
2748 If se->direct_byref is set then se->expr contains the return parameter.
2749 Return nonzero, if the call has alternate specifiers.
2750 'expr' is only needed for procedure pointer components. */
2753 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2754 gfc_actual_arglist * arg, gfc_expr * expr,
2755 VEC(tree,gc) *append_args)
2757 gfc_interface_mapping mapping;
2758 VEC(tree,gc) *arglist;
2759 VEC(tree,gc) *retargs;
2770 VEC(tree,gc) *stringargs;
2772 gfc_formal_arglist *formal;
2773 int has_alternate_specifier = 0;
2774 bool need_interface_mapping;
2781 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2782 gfc_component *comp = NULL;
2792 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2793 && conv_isocbinding_procedure (se, sym, arg))
2796 gfc_is_proc_ptr_comp (expr, &comp);
2800 if (!sym->attr.elemental)
2802 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2803 if (se->ss->useflags)
2805 gcc_assert ((!comp && gfc_return_by_reference (sym)
2806 && sym->result->attr.dimension)
2807 || (comp && comp->attr.dimension));
2808 gcc_assert (se->loop != NULL);
2810 /* Access the previously obtained result. */
2811 gfc_conv_tmp_array_ref (se);
2812 gfc_advance_se_ss_chain (se);
2816 info = &se->ss->data.info;
2821 gfc_init_block (&post);
2822 gfc_init_interface_mapping (&mapping);
2825 formal = sym->formal;
2826 need_interface_mapping = sym->attr.dimension ||
2827 (sym->ts.type == BT_CHARACTER
2828 && sym->ts.u.cl->length
2829 && sym->ts.u.cl->length->expr_type
2834 formal = comp->formal;
2835 need_interface_mapping = comp->attr.dimension ||
2836 (comp->ts.type == BT_CHARACTER
2837 && comp->ts.u.cl->length
2838 && comp->ts.u.cl->length->expr_type
2842 /* Evaluate the arguments. */
2843 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2846 fsym = formal ? formal->sym : NULL;
2847 parm_kind = MISSING;
2851 if (se->ignore_optional)
2853 /* Some intrinsics have already been resolved to the correct
2857 else if (arg->label)
2859 has_alternate_specifier = 1;
2864 /* Pass a NULL pointer for an absent arg. */
2865 gfc_init_se (&parmse, NULL);
2866 parmse.expr = null_pointer_node;
2867 if (arg->missing_arg_type == BT_CHARACTER)
2868 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2871 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2873 /* Pass a NULL pointer to denote an absent arg. */
2874 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2875 gfc_init_se (&parmse, NULL);
2876 parmse.expr = null_pointer_node;
2877 if (arg->missing_arg_type == BT_CHARACTER)
2878 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2880 else if (fsym && fsym->ts.type == BT_CLASS
2881 && e->ts.type == BT_DERIVED)
2883 /* The derived type needs to be converted to a temporary
2885 gfc_init_se (&parmse, se);
2886 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2888 else if (se->ss && se->ss->useflags)
2890 /* An elemental function inside a scalarized loop. */
2891 gfc_init_se (&parmse, se);
2892 gfc_conv_expr_reference (&parmse, e);
2893 parm_kind = ELEMENTAL;
2897 /* A scalar or transformational function. */
2898 gfc_init_se (&parmse, NULL);
2899 argss = gfc_walk_expr (e);
2901 if (argss == gfc_ss_terminator)
2903 if (e->expr_type == EXPR_VARIABLE
2904 && e->symtree->n.sym->attr.cray_pointee
2905 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2907 /* The Cray pointer needs to be converted to a pointer to
2908 a type given by the expression. */
2909 gfc_conv_expr (&parmse, e);
2910 type = build_pointer_type (TREE_TYPE (parmse.expr));
2911 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2912 parmse.expr = convert (type, tmp);
2914 else if (fsym && fsym->attr.value)
2916 if (fsym->ts.type == BT_CHARACTER
2917 && fsym->ts.is_c_interop
2918 && fsym->ns->proc_name != NULL
2919 && fsym->ns->proc_name->attr.is_bind_c)
2922 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2923 if (parmse.expr == NULL)
2924 gfc_conv_expr (&parmse, e);
2927 gfc_conv_expr (&parmse, e);
2929 else if (arg->name && arg->name[0] == '%')
2930 /* Argument list functions %VAL, %LOC and %REF are signalled
2931 through arg->name. */
2932 conv_arglist_function (&parmse, arg->expr, arg->name);
2933 else if ((e->expr_type == EXPR_FUNCTION)
2934 && ((e->value.function.esym
2935 && e->value.function.esym->result->attr.pointer)
2936 || (!e->value.function.esym
2937 && e->symtree->n.sym->attr.pointer))
2938 && fsym && fsym->attr.target)
2940 gfc_conv_expr (&parmse, e);
2941 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2943 else if (e->expr_type == EXPR_FUNCTION
2944 && e->symtree->n.sym->result
2945 && e->symtree->n.sym->result != e->symtree->n.sym
2946 && e->symtree->n.sym->result->attr.proc_pointer)
2948 /* Functions returning procedure pointers. */
2949 gfc_conv_expr (&parmse, e);
2950 if (fsym && fsym->attr.proc_pointer)
2951 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2955 gfc_conv_expr_reference (&parmse, e);
2957 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2958 allocated on entry, it must be deallocated. */
2959 if (fsym && fsym->attr.allocatable
2960 && fsym->attr.intent == INTENT_OUT)
2964 gfc_init_block (&block);
2965 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2967 gfc_add_expr_to_block (&block, tmp);
2968 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2969 parmse.expr, null_pointer_node);
2970 gfc_add_expr_to_block (&block, tmp);
2972 if (fsym->attr.optional
2973 && e->expr_type == EXPR_VARIABLE
2974 && e->symtree->n.sym->attr.optional)
2976 tmp = fold_build3 (COND_EXPR, void_type_node,
2977 gfc_conv_expr_present (e->symtree->n.sym),
2978 gfc_finish_block (&block),
2979 build_empty_stmt (input_location));
2982 tmp = gfc_finish_block (&block);
2984 gfc_add_expr_to_block (&se->pre, tmp);
2987 if (fsym && e->expr_type != EXPR_NULL
2988 && ((fsym->attr.pointer
2989 && fsym->attr.flavor != FL_PROCEDURE)
2990 || (fsym->attr.proc_pointer
2991 && !(e->expr_type == EXPR_VARIABLE
2992 && e->symtree->n.sym->attr.dummy))
2993 || (e->expr_type == EXPR_VARIABLE
2994 && gfc_is_proc_ptr_comp (e, NULL))
2995 || fsym->attr.allocatable))
2997 /* Scalar pointer dummy args require an extra level of
2998 indirection. The null pointer already contains
2999 this level of indirection. */
3000 parm_kind = SCALAR_POINTER;
3001 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3007 /* If the procedure requires an explicit interface, the actual
3008 argument is passed according to the corresponding formal
3009 argument. If the corresponding formal argument is a POINTER,
3010 ALLOCATABLE or assumed shape, we do not use g77's calling
3011 convention, and pass the address of the array descriptor
3012 instead. Otherwise we use g77's calling convention. */
3015 && !(fsym->attr.pointer || fsym->attr.allocatable)
3016 && fsym->as->type != AS_ASSUMED_SHAPE;
3018 f = f || !comp->attr.always_explicit;
3020 f = f || !sym->attr.always_explicit;
3022 if (e->expr_type == EXPR_VARIABLE
3023 && is_subref_array (e))
3024 /* The actual argument is a component reference to an
3025 array of derived types. In this case, the argument
3026 is converted to a temporary, which is passed and then
3027 written back after the procedure call. */
3028 gfc_conv_subref_array_arg (&parmse, e, f,
3029 fsym ? fsym->attr.intent : INTENT_INOUT,
3030 fsym && fsym->attr.pointer);
3032 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3035 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3036 allocated on entry, it must be deallocated. */
3037 if (fsym && fsym->attr.allocatable
3038 && fsym->attr.intent == INTENT_OUT)
3040 tmp = build_fold_indirect_ref_loc (input_location,
3042 tmp = gfc_trans_dealloc_allocated (tmp);
3043 if (fsym->attr.optional
3044 && e->expr_type == EXPR_VARIABLE
3045 && e->symtree->n.sym->attr.optional)
3046 tmp = fold_build3 (COND_EXPR, void_type_node,
3047 gfc_conv_expr_present (e->symtree->n.sym),
3048 tmp, build_empty_stmt (input_location));
3049 gfc_add_expr_to_block (&se->pre, tmp);
3054 /* The case with fsym->attr.optional is that of a user subroutine
3055 with an interface indicating an optional argument. When we call
3056 an intrinsic subroutine, however, fsym is NULL, but we might still
3057 have an optional argument, so we proceed to the substitution
3059 if (e && (fsym == NULL || fsym->attr.optional))
3061 /* If an optional argument is itself an optional dummy argument,
3062 check its presence and substitute a null if absent. This is
3063 only needed when passing an array to an elemental procedure
3064 as then array elements are accessed - or no NULL pointer is
3065 allowed and a "1" or "0" should be passed if not present.
3066 When passing a non-array-descriptor full array to a
3067 non-array-descriptor dummy, no check is needed. For
3068 array-descriptor actual to array-descriptor dummy, see
3069 PR 41911 for why a check has to be inserted.
3070 fsym == NULL is checked as intrinsics required the descriptor
3071 but do not always set fsym. */
3072 if (e->expr_type == EXPR_VARIABLE
3073 && e->symtree->n.sym->attr.optional
3074 && ((e->rank > 0 && sym->attr.elemental)
3075 || e->representation.length || e->ts.type == BT_CHARACTER
3077 && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3078 || fsym->as->type == AS_DEFERRED))))
3079 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3080 e->representation.length);
3085 /* Obtain the character length of an assumed character length
3086 length procedure from the typespec. */
3087 if (fsym->ts.type == BT_CHARACTER
3088 && parmse.string_length == NULL_TREE
3089 && e->ts.type == BT_PROCEDURE
3090 && e->symtree->n.sym->ts.type == BT_CHARACTER
3091 && e->symtree->n.sym->ts.u.cl->length != NULL
3092 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3094 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3095 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3099 if (fsym && need_interface_mapping && e)
3100 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3102 gfc_add_block_to_block (&se->pre, &parmse.pre);
3103 gfc_add_block_to_block (&post, &parmse.post);
3105 /* Allocated allocatable components of derived types must be
3106 deallocated for non-variable scalars. Non-variable arrays are
3107 dealt with in trans-array.c(gfc_conv_array_parameter). */
3108 if (e && e->ts.type == BT_DERIVED
3109 && e->ts.u.derived->attr.alloc_comp
3110 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3111 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3114 tmp = build_fold_indirect_ref_loc (input_location,
3116 parm_rank = e->rank;
3124 case (SCALAR_POINTER):
3125 tmp = build_fold_indirect_ref_loc (input_location,
3130 if (e->expr_type == EXPR_OP
3131 && e->value.op.op == INTRINSIC_PARENTHESES
3132 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3135 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3136 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3137 gfc_add_expr_to_block (&se->post, local_tmp);
3140 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3142 gfc_add_expr_to_block (&se->post, tmp);
3145 /* Add argument checking of passing an unallocated/NULL actual to
3146 a nonallocatable/nonpointer dummy. */
3148 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3150 symbol_attribute *attr;
3154 if (e->expr_type == EXPR_VARIABLE)
3155 attr = &e->symtree->n.sym->attr;
3156 else if (e->expr_type == EXPR_FUNCTION)
3158 /* For intrinsic functions, the gfc_attr are not available. */
3159 if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3160 goto end_pointer_check;
3162 if (e->symtree->n.sym->attr.generic)
3163 attr = &e->value.function.esym->attr;
3165 attr = &e->symtree->n.sym->result->attr;
3168 goto end_pointer_check;
3172 /* If the actual argument is an optional pointer/allocatable and
3173 the formal argument takes an nonpointer optional value,
3174 it is invalid to pass a non-present argument on, even
3175 though there is no technical reason for this in gfortran.
3176 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3177 tree present, null_ptr, type;
3179 if (attr->allocatable
3180 && (fsym == NULL || !fsym->attr.allocatable))
3181 asprintf (&msg, "Allocatable actual argument '%s' is not "
3182 "allocated or not present", e->symtree->n.sym->name);
3183 else if (attr->pointer
3184 && (fsym == NULL || !fsym->attr.pointer))
3185 asprintf (&msg, "Pointer actual argument '%s' is not "
3186 "associated or not present",
3187 e->symtree->n.sym->name);
3188 else if (attr->proc_pointer
3189 && (fsym == NULL || !fsym->attr.proc_pointer))
3190 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3191 "associated or not present",
3192 e->symtree->n.sym->name);
3194 goto end_pointer_check;
3196 present = gfc_conv_expr_present (e->symtree->n.sym);
3197 type = TREE_TYPE (present);
3198 present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3199 fold_convert (type, null_pointer_node));
3200 type = TREE_TYPE (parmse.expr);
3201 null_ptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3202 fold_convert (type, null_pointer_node));
3203 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3208 if (attr->allocatable
3209 && (fsym == NULL || !fsym->attr.allocatable))
3210 asprintf (&msg, "Allocatable actual argument '%s' is not "
3211 "allocated", e->symtree->n.sym->name);
3212 else if (attr->pointer
3213 && (fsym == NULL || !fsym->attr.pointer))
3214 asprintf (&msg, "Pointer actual argument '%s' is not "
3215 "associated", e->symtree->n.sym->name);
3216 else if (attr->proc_pointer
3217 && (fsym == NULL || !fsym->attr.proc_pointer))
3218 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3219 "associated", e->symtree->n.sym->name);
3221 goto end_pointer_check;
3224 cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3225 fold_convert (TREE_TYPE (parmse.expr),
3226 null_pointer_node));
3229 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3236 /* Character strings are passed as two parameters, a length and a
3237 pointer - except for Bind(c) which only passes the pointer. */
3238 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3239 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3241 VEC_safe_push (tree, gc, arglist, parmse.expr);
3243 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3250 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3251 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3252 else if (ts.type == BT_CHARACTER)
3254 if (ts.u.cl->length == NULL)
3256 /* Assumed character length results are not allowed by 5.1.1.5 of the
3257 standard and are trapped in resolve.c; except in the case of SPREAD
3258 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3259 we take the character length of the first argument for the result.
3260 For dummies, we have to look through the formal argument list for
3261 this function and use the character length found there.*/
3262 if (!sym->attr.dummy)
3263 cl.backend_decl = VEC_index (tree, stringargs, 0);
3266 formal = sym->ns->proc_name->formal;
3267 for (; formal; formal = formal->next)
3268 if (strcmp (formal->sym->name, sym->name) == 0)
3269 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3276 /* Calculate the length of the returned string. */
3277 gfc_init_se (&parmse, NULL);
3278 if (need_interface_mapping)
3279 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3281 gfc_conv_expr (&parmse, ts.u.cl->length);
3282 gfc_add_block_to_block (&se->pre, &parmse.pre);
3283 gfc_add_block_to_block (&se->post, &parmse.post);
3285 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3286 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3287 build_int_cst (gfc_charlen_type_node, 0));
3288 cl.backend_decl = tmp;
3291 /* Set up a charlen structure for it. */
3296 len = cl.backend_decl;
3299 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3300 || (!comp && gfc_return_by_reference (sym));
3303 if (se->direct_byref)
3305 /* Sometimes, too much indirection can be applied; e.g. for
3306 function_result = array_valued_recursive_function. */
3307 if (TREE_TYPE (TREE_TYPE (se->expr))
3308 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3309 && GFC_DESCRIPTOR_TYPE_P
3310 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3311 se->expr = build_fold_indirect_ref_loc (input_location,
3314 result = build_fold_indirect_ref_loc (input_location,
3316 VEC_safe_push (tree, gc, retargs, se->expr);
3318 else if (comp && comp->attr.dimension)
3320 gcc_assert (se->loop && info);
3322 /* Set the type of the array. */
3323 tmp = gfc_typenode_for_spec (&comp->ts);
3324 info->dimen = se->loop->dimen;
3326 /* Evaluate the bounds of the result, if known. */
3327 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3329 /* Create a temporary to store the result. In case the function
3330 returns a pointer, the temporary will be a shallow copy and
3331 mustn't be deallocated. */
3332 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3333 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3334 NULL_TREE, false, !comp->attr.pointer,
3335 callee_alloc, &se->ss->expr->where);
3337 /* Pass the temporary as the first argument. */
3338 result = info->descriptor;
3339 tmp = gfc_build_addr_expr (NULL_TREE, result);
3340 VEC_safe_push (tree, gc, retargs, tmp);
3342 else if (!comp && sym->result->attr.dimension)
3344 gcc_assert (se->loop && info);
3346 /* Set the type of the array. */
3347 tmp = gfc_typenode_for_spec (&ts);
3348 info->dimen = se->loop->dimen;
3350 /* Evaluate the bounds of the result, if known. */
3351 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3353 /* Create a temporary to store the result. In case the function
3354 returns a pointer, the temporary will be a shallow copy and
3355 mustn't be deallocated. */
3356 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3357 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3358 NULL_TREE, false, !sym->attr.pointer,
3359 callee_alloc, &se->ss->expr->where);
3361 /* Pass the temporary as the first argument. */
3362 result = info->descriptor;
3363 tmp = gfc_build_addr_expr (NULL_TREE, result);
3364 VEC_safe_push (tree, gc, retargs, tmp);
3366 else if (ts.type == BT_CHARACTER)
3368 /* Pass the string length. */
3369 type = gfc_get_character_type (ts.kind, ts.u.cl);
3370 type = build_pointer_type (type);
3372 /* Return an address to a char[0:len-1]* temporary for
3373 character pointers. */
3374 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3375 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3377 var = gfc_create_var (type, "pstr");
3379 if ((!comp && sym->attr.allocatable)
3380 || (comp && comp->attr.allocatable))
3381 gfc_add_modify (&se->pre, var,
3382 fold_convert (TREE_TYPE (var),
3383 null_pointer_node));
3385 /* Provide an address expression for the function arguments. */
3386 var = gfc_build_addr_expr (NULL_TREE, var);
3389 var = gfc_conv_string_tmp (se, type, len);
3391 VEC_safe_push (tree, gc, retargs, var);
3395 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3397 type = gfc_get_complex_type (ts.kind);
3398 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3399 VEC_safe_push (tree, gc, retargs, var);
3402 /* Add the string length to the argument list. */
3403 if (ts.type == BT_CHARACTER)
3404 VEC_safe_push (tree, gc, retargs, len);
3406 gfc_free_interface_mapping (&mapping);
3408 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3409 arglen = (VEC_length (tree, arglist)
3410 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3411 VEC_reserve_exact (tree, gc, retargs, arglen);
3413 /* Add the return arguments. */
3414 VEC_splice (tree, retargs, arglist);
3416 /* Add the hidden string length parameters to the arguments. */
3417 VEC_splice (tree, retargs, stringargs);
3419 /* We may want to append extra arguments here. This is used e.g. for
3420 calls to libgfortran_matmul_??, which need extra information. */
3421 if (!VEC_empty (tree, append_args))
3422 VEC_splice (tree, retargs, append_args);
3425 /* Generate the actual call. */
3426 conv_function_val (se, sym, expr);
3428 /* If there are alternate return labels, function type should be
3429 integer. Can't modify the type in place though, since it can be shared
3430 with other functions. For dummy arguments, the typing is done to
3431 to this result, even if it has to be repeated for each call. */
3432 if (has_alternate_specifier
3433 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3435 if (!sym->attr.dummy)
3437 TREE_TYPE (sym->backend_decl)
3438 = build_function_type (integer_type_node,
3439 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3440 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3443 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3446 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3447 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3449 /* If we have a pointer function, but we don't want a pointer, e.g.
3452 where f is pointer valued, we have to dereference the result. */
3453 if (!se->want_pointer && !byref
3454 && (sym->attr.pointer || sym->attr.allocatable)
3455 && !gfc_is_proc_ptr_comp (expr, NULL))
3456 se->expr = build_fold_indirect_ref_loc (input_location,
3459 /* f2c calling conventions require a scalar default real function to
3460 return a double precision result. Convert this back to default
3461 real. We only care about the cases that can happen in Fortran 77.
3463 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3464 && sym->ts.kind == gfc_default_real_kind
3465 && !sym->attr.always_explicit)
3466 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3468 /* A pure function may still have side-effects - it may modify its
3470 TREE_SIDE_EFFECTS (se->expr) = 1;
3472 if (!sym->attr.pure)
3473 TREE_SIDE_EFFECTS (se->expr) = 1;
3478 /* Add the function call to the pre chain. There is no expression. */
3479 gfc_add_expr_to_block (&se->pre, se->expr);
3480 se->expr = NULL_TREE;
3482 if (!se->direct_byref)
3484 if (sym->attr.dimension || (comp && comp->attr.dimension))
3486 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3488 /* Check the data pointer hasn't been modified. This would
3489 happen in a function returning a pointer. */
3490 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3491 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3493 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3496 se->expr = info->descriptor;
3497 /* Bundle in the string length. */
3498 se->string_length = len;
3500 else if (ts.type == BT_CHARACTER)
3502 /* Dereference for character pointer results. */
3503 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3504 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3505 se->expr = build_fold_indirect_ref_loc (input_location, var);
3509 se->string_length = len;
3513 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3514 se->expr = build_fold_indirect_ref_loc (input_location, var);
3519 /* Follow the function call with the argument post block. */
3522 gfc_add_block_to_block (&se->pre, &post);
3524 /* Transformational functions of derived types with allocatable
3525 components must have the result allocatable components copied. */
3526 arg = expr->value.function.actual;
3527 if (result && arg && expr->rank
3528 && expr->value.function.isym
3529 && expr->value.function.isym->transformational
3530 && arg->expr->ts.type == BT_DERIVED
3531 && arg->expr->ts.u.derived->attr.alloc_comp)
3534 /* Copy the allocatable components. We have to use a
3535 temporary here to prevent source allocatable components
3536 from being corrupted. */
3537 tmp2 = gfc_evaluate_now (result, &se->pre);
3538 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3539 result, tmp2, expr->rank);
3540 gfc_add_expr_to_block (&se->pre, tmp);
3541 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3543 gfc_add_expr_to_block (&se->pre, tmp);
3545 /* Finally free the temporary's data field. */
3546 tmp = gfc_conv_descriptor_data_get (tmp2);
3547 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3548 gfc_add_expr_to_block (&se->pre, tmp);
3552 gfc_add_block_to_block (&se->post, &post);
3554 return has_alternate_specifier;
3558 /* Fill a character string with spaces. */
3561 fill_with_spaces (tree start, tree type, tree size)
3563 stmtblock_t block, loop;
3564 tree i, el, exit_label, cond, tmp;
3566 /* For a simple char type, we can call memset(). */
3567 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3568 return build_call_expr_loc (input_location,
3569 built_in_decls[BUILT_IN_MEMSET], 3, start,
3570 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3571 lang_hooks.to_target_charset (' ')),
3574 /* Otherwise, we use a loop:
3575 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3579 /* Initialize variables. */
3580 gfc_init_block (&block);
3581 i = gfc_create_var (sizetype, "i");
3582 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3583 el = gfc_create_var (build_pointer_type (type), "el");
3584 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3585 exit_label = gfc_build_label_decl (NULL_TREE);
3586 TREE_USED (exit_label) = 1;
3590 gfc_init_block (&loop);
3592 /* Exit condition. */
3593 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3594 fold_convert (sizetype, integer_zero_node));
3595 tmp = build1_v (GOTO_EXPR, exit_label);
3596 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3597 build_empty_stmt (input_location));
3598 gfc_add_expr_to_block (&loop, tmp);
3601 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3602 build_int_cst (type,
3603 lang_hooks.to_target_charset (' ')));
3605 /* Increment loop variables. */
3606 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3607 TYPE_SIZE_UNIT (type)));
3608 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3610 TYPE_SIZE_UNIT (type)));
3612 /* Making the loop... actually loop! */
3613 tmp = gfc_finish_block (&loop);
3614 tmp = build1_v (LOOP_EXPR, tmp);
3615 gfc_add_expr_to_block (&block, tmp);
3617 /* The exit label. */
3618 tmp = build1_v (LABEL_EXPR, exit_label);
3619 gfc_add_expr_to_block (&block, tmp);
3622 return gfc_finish_block (&block);
3626 /* Generate code to copy a string. */
3629 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3630 int dkind, tree slength, tree src, int skind)
3632 tree tmp, dlen, slen;
3641 stmtblock_t tempblock;
3643 gcc_assert (dkind == skind);
3645 if (slength != NULL_TREE)
3647 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3648 ssc = gfc_string_to_single_character (slen, src, skind);
3652 slen = build_int_cst (size_type_node, 1);
3656 if (dlength != NULL_TREE)
3658 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3659 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3663 dlen = build_int_cst (size_type_node, 1);
3667 /* Assign directly if the types are compatible. */
3668 if (dsc != NULL_TREE && ssc != NULL_TREE
3669 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3671 gfc_add_modify (block, dsc, ssc);
3675 /* Do nothing if the destination length is zero. */
3676 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3677 build_int_cst (size_type_node, 0));
3679 /* The following code was previously in _gfortran_copy_string:
3681 // The two strings may overlap so we use memmove.
3683 copy_string (GFC_INTEGER_4 destlen, char * dest,
3684 GFC_INTEGER_4 srclen, const char * src)
3686 if (srclen >= destlen)
3688 // This will truncate if too long.
3689 memmove (dest, src, destlen);
3693 memmove (dest, src, srclen);
3695 memset (&dest[srclen], ' ', destlen - srclen);
3699 We're now doing it here for better optimization, but the logic
3702 /* For non-default character kinds, we have to multiply the string
3703 length by the base type size. */
3704 chartype = gfc_get_char_type (dkind);
3705 slen = fold_build2 (MULT_EXPR, size_type_node,
3706 fold_convert (size_type_node, slen),
3707 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3708 dlen = fold_build2 (MULT_EXPR, size_type_node,
3709 fold_convert (size_type_node, dlen),
3710 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3713 dest = fold_convert (pvoid_type_node, dest);
3715 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3718 src = fold_convert (pvoid_type_node, src);
3720 src = gfc_build_addr_expr (pvoid_type_node, src);
3722 /* Truncate string if source is too long. */
3723 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3724 tmp2 = build_call_expr_loc (input_location,
3725 built_in_decls[BUILT_IN_MEMMOVE],
3726 3, dest, src, dlen);
3728 /* Else copy and pad with spaces. */
3729 tmp3 = build_call_expr_loc (input_location,
3730 built_in_decls[BUILT_IN_MEMMOVE],
3731 3, dest, src, slen);
3733 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3734 fold_convert (sizetype, slen));
3735 tmp4 = fill_with_spaces (tmp4, chartype,
3736 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3739 gfc_init_block (&tempblock);
3740 gfc_add_expr_to_block (&tempblock, tmp3);
3741 gfc_add_expr_to_block (&tempblock, tmp4);
3742 tmp3 = gfc_finish_block (&tempblock);
3744 /* The whole copy_string function is there. */
3745 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3746 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3747 build_empty_stmt (input_location));
3748 gfc_add_expr_to_block (block, tmp);
3752 /* Translate a statement function.
3753 The value of a statement function reference is obtained by evaluating the
3754 expression using the values of the actual arguments for the values of the
3755 corresponding dummy arguments. */
3758 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3762 gfc_formal_arglist *fargs;
3763 gfc_actual_arglist *args;
3766 gfc_saved_var *saved_vars;
3772 sym = expr->symtree->n.sym;
3773 args = expr->value.function.actual;
3774 gfc_init_se (&lse, NULL);
3775 gfc_init_se (&rse, NULL);
3778 for (fargs = sym->formal; fargs; fargs = fargs->next)
3780 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3781 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3783 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3785 /* Each dummy shall be specified, explicitly or implicitly, to be
3787 gcc_assert (fargs->sym->attr.dimension == 0);
3790 /* Create a temporary to hold the value. */
3791 type = gfc_typenode_for_spec (&fsym->ts);
3792 temp_vars[n] = gfc_create_var (type, fsym->name);
3794 if (fsym->ts.type == BT_CHARACTER)
3796 /* Copy string arguments. */
3799 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3800 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3802 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3803 tmp = gfc_build_addr_expr (build_pointer_type (type),
3806 gfc_conv_expr (&rse, args->expr);
3807 gfc_conv_string_parameter (&rse);
3808 gfc_add_block_to_block (&se->pre, &lse.pre);
3809 gfc_add_block_to_block (&se->pre, &rse.pre);
3811 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3812 rse.string_length, rse.expr, fsym->ts.kind);
3813 gfc_add_block_to_block (&se->pre, &lse.post);
3814 gfc_add_block_to_block (&se->pre, &rse.post);
3818 /* For everything else, just evaluate the expression. */
3819 gfc_conv_expr (&lse, args->expr);
3821 gfc_add_block_to_block (&se->pre, &lse.pre);
3822 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3823 gfc_add_block_to_block (&se->pre, &lse.post);
3829 /* Use the temporary variables in place of the real ones. */
3830 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3831 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3833 gfc_conv_expr (se, sym->value);
3835 if (sym->ts.type == BT_CHARACTER)
3837 gfc_conv_const_charlen (sym->ts.u.cl);
3839 /* Force the expression to the correct length. */
3840 if (!INTEGER_CST_P (se->string_length)
3841 || tree_int_cst_lt (se->string_length,
3842 sym->ts.u.cl->backend_decl))
3844 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3845 tmp = gfc_create_var (type, sym->name);
3846 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3847 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3848 sym->ts.kind, se->string_length, se->expr,
3852 se->string_length = sym->ts.u.cl->backend_decl;
3855 /* Restore the original variables. */
3856 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3857 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3858 gfc_free (saved_vars);
3862 /* Translate a function expression. */
3865 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3869 if (expr->value.function.isym)
3871 gfc_conv_intrinsic_function (se, expr);
3875 /* We distinguish statement functions from general functions to improve
3876 runtime performance. */
3877 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3879 gfc_conv_statement_function (se, expr);
3883 /* expr.value.function.esym is the resolved (specific) function symbol for
3884 most functions. However this isn't set for dummy procedures. */
3885 sym = expr->value.function.esym;
3887 sym = expr->symtree->n.sym;
3889 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
3893 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3896 is_zero_initializer_p (gfc_expr * expr)
3898 if (expr->expr_type != EXPR_CONSTANT)
3901 /* We ignore constants with prescribed memory representations for now. */
3902 if (expr->representation.string)
3905 switch (expr->ts.type)
3908 return mpz_cmp_si (expr->value.integer, 0) == 0;
3911 return mpfr_zero_p (expr->value.real)
3912 && MPFR_SIGN (expr->value.real) >= 0;
3915 return expr->value.logical == 0;
3918 return mpfr_zero_p (mpc_realref (expr->value.complex))
3919 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
3920 && mpfr_zero_p (mpc_imagref (expr->value.complex))
3921 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
3931 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3933 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3934 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3936 gfc_conv_tmp_array_ref (se);
3937 gfc_advance_se_ss_chain (se);
3941 /* Build a static initializer. EXPR is the expression for the initial value.
3942 The other parameters describe the variable of the component being
3943 initialized. EXPR may be null. */
3946 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3947 bool array, bool pointer)
3951 if (!(expr || pointer))
3954 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3955 (these are the only two iso_c_binding derived types that can be
3956 used as initialization expressions). If so, we need to modify
3957 the 'expr' to be that for a (void *). */
3958 if (expr != NULL && expr->ts.type == BT_DERIVED
3959 && expr->ts.is_iso_c && expr->ts.u.derived)
3961 gfc_symbol *derived = expr->ts.u.derived;
3963 /* The derived symbol has already been converted to a (void *). Use
3965 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
3966 expr->ts.f90_type = derived->ts.f90_type;
3968 gfc_init_se (&se, NULL);
3969 gfc_conv_constant (&se, expr);
3975 /* Arrays need special handling. */
3977 return gfc_build_null_descriptor (type);
3978 /* Special case assigning an array to zero. */
3979 else if (is_zero_initializer_p (expr))
3980 return build_constructor (type, NULL);
3982 return gfc_conv_array_initializer (type, expr);
3985 return fold_convert (type, null_pointer_node);
3992 gfc_init_se (&se, NULL);
3993 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
3994 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
3996 gfc_conv_structure (&se, expr, 1);
4000 return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4003 gfc_init_se (&se, NULL);
4004 gfc_conv_constant (&se, expr);
4011 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4023 gfc_start_block (&block);
4025 /* Initialize the scalarizer. */
4026 gfc_init_loopinfo (&loop);
4028 gfc_init_se (&lse, NULL);
4029 gfc_init_se (&rse, NULL);
4032 rss = gfc_walk_expr (expr);
4033 if (rss == gfc_ss_terminator)
4035 /* The rhs is scalar. Add a ss for the expression. */
4036 rss = gfc_get_ss ();
4037 rss->next = gfc_ss_terminator;
4038 rss->type = GFC_SS_SCALAR;
4042 /* Create a SS for the destination. */
4043 lss = gfc_get_ss ();
4044 lss->type = GFC_SS_COMPONENT;
4046 lss->shape = gfc_get_shape (cm->as->rank);
4047 lss->next = gfc_ss_terminator;
4048 lss->data.info.dimen = cm->as->rank;
4049 lss->data.info.descriptor = dest;
4050 lss->data.info.data = gfc_conv_array_data (dest);
4051 lss->data.info.offset = gfc_conv_array_offset (dest);
4052 for (n = 0; n < cm->as->rank; n++)
4054 lss->data.info.dim[n] = n;
4055 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4056 lss->data.info.stride[n] = gfc_index_one_node;
4058 mpz_init (lss->shape[n]);
4059 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4060 cm->as->lower[n]->value.integer);
4061 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4064 /* Associate the SS with the loop. */
4065 gfc_add_ss_to_loop (&loop, lss);
4066 gfc_add_ss_to_loop (&loop, rss);
4068 /* Calculate the bounds of the scalarization. */
4069 gfc_conv_ss_startstride (&loop);
4071 /* Setup the scalarizing loops. */
4072 gfc_conv_loop_setup (&loop, &expr->where);
4074 /* Setup the gfc_se structures. */
4075 gfc_copy_loopinfo_to_se (&lse, &loop);
4076 gfc_copy_loopinfo_to_se (&rse, &loop);
4079 gfc_mark_ss_chain_used (rss, 1);
4081 gfc_mark_ss_chain_used (lss, 1);
4083 /* Start the scalarized loop body. */
4084 gfc_start_scalarized_body (&loop, &body);
4086 gfc_conv_tmp_array_ref (&lse);
4087 if (cm->ts.type == BT_CHARACTER)
4088 lse.string_length = cm->ts.u.cl->backend_decl;
4090 gfc_conv_expr (&rse, expr);
4092 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4093 gfc_add_expr_to_block (&body, tmp);
4095 gcc_assert (rse.ss == gfc_ss_terminator);
4097 /* Generate the copying loops. */
4098 gfc_trans_scalarizing_loops (&loop, &body);
4100 /* Wrap the whole thing up. */
4101 gfc_add_block_to_block (&block, &loop.pre);
4102 gfc_add_block_to_block (&block, &loop.post);
4104 for (n = 0; n < cm->as->rank; n++)
4105 mpz_clear (lss->shape[n]);
4106 gfc_free (lss->shape);
4108 gfc_cleanup_loop (&loop);
4110 return gfc_finish_block (&block);
4115 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4126 gfc_expr *arg = NULL;
4128 gfc_start_block (&block);
4129 gfc_init_se (&se, NULL);
4131 /* Get the descriptor for the expressions. */
4132 rss = gfc_walk_expr (expr);
4133 se.want_pointer = 0;
4134 gfc_conv_expr_descriptor (&se, expr, rss);
4135 gfc_add_block_to_block (&block, &se.pre);
4136 gfc_add_modify (&block, dest, se.expr);
4138 /* Deal with arrays of derived types with allocatable components. */
4139 if (cm->ts.type == BT_DERIVED
4140 && cm->ts.u.derived->attr.alloc_comp)
4141 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4145 tmp = gfc_duplicate_allocatable (dest, se.expr,
4146 TREE_TYPE(cm->backend_decl),
4149 gfc_add_expr_to_block (&block, tmp);
4150 gfc_add_block_to_block (&block, &se.post);
4152 if (expr->expr_type != EXPR_VARIABLE)
4153 gfc_conv_descriptor_data_set (&block, se.expr,
4156 /* We need to know if the argument of a conversion function is a
4157 variable, so that the correct lower bound can be used. */
4158 if (expr->expr_type == EXPR_FUNCTION
4159 && expr->value.function.isym
4160 && expr->value.function.isym->conversion
4161 && expr->value.function.actual->expr
4162 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4163 arg = expr->value.function.actual->expr;
4165 /* Obtain the array spec of full array references. */
4167 as = gfc_get_full_arrayspec_from_expr (arg);
4169 as = gfc_get_full_arrayspec_from_expr (expr);
4171 /* Shift the lbound and ubound of temporaries to being unity,
4172 rather than zero, based. Always calculate the offset. */
4173 offset = gfc_conv_descriptor_offset_get (dest);
4174 gfc_add_modify (&block, offset, gfc_index_zero_node);
4175 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4177 for (n = 0; n < expr->rank; n++)
4182 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4183 TODO It looks as if gfc_conv_expr_descriptor should return
4184 the correct bounds and that the following should not be
4185 necessary. This would simplify gfc_conv_intrinsic_bound
4187 if (as && as->lower[n])
4190 gfc_init_se (&lbse, NULL);
4191 gfc_conv_expr (&lbse, as->lower[n]);
4192 gfc_add_block_to_block (&block, &lbse.pre);
4193 lbound = gfc_evaluate_now (lbse.expr, &block);
4197 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4198 lbound = gfc_conv_descriptor_lbound_get (tmp,
4202 lbound = gfc_conv_descriptor_lbound_get (dest,
4205 lbound = gfc_index_one_node;
4207 lbound = fold_convert (gfc_array_index_type, lbound);
4209 /* Shift the bounds and set the offset accordingly. */
4210 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4211 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4212 gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4213 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
4214 gfc_conv_descriptor_ubound_set (&block, dest,
4215 gfc_rank_cst[n], tmp);
4216 gfc_conv_descriptor_lbound_set (&block, dest,
4217 gfc_rank_cst[n], lbound);
4219 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4220 gfc_conv_descriptor_lbound_get (dest,
4222 gfc_conv_descriptor_stride_get (dest,
4224 gfc_add_modify (&block, tmp2, tmp);
4225 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4226 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4231 /* If a conversion expression has a null data pointer
4232 argument, nullify the allocatable component. */
4236 if (arg->symtree->n.sym->attr.allocatable
4237 || arg->symtree->n.sym->attr.pointer)
4239 non_null_expr = gfc_finish_block (&block);
4240 gfc_start_block (&block);
4241 gfc_conv_descriptor_data_set (&block, dest,
4243 null_expr = gfc_finish_block (&block);
4244 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4245 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4246 fold_convert (TREE_TYPE (tmp),
4247 null_pointer_node));
4248 return build3_v (COND_EXPR, tmp,
4249 null_expr, non_null_expr);
4253 return gfc_finish_block (&block);
4257 /* Assign a single component of a derived type constructor. */
4260 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4268 gfc_start_block (&block);
4270 if (cm->attr.pointer)
4272 gfc_init_se (&se, NULL);
4273 /* Pointer component. */
4274 if (cm->attr.dimension)
4276 /* Array pointer. */
4277 if (expr->expr_type == EXPR_NULL)
4278 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4281 rss = gfc_walk_expr (expr);
4282 se.direct_byref = 1;
4284 gfc_conv_expr_descriptor (&se, expr, rss);
4285 gfc_add_block_to_block (&block, &se.pre);
4286 gfc_add_block_to_block (&block, &se.post);
4291 /* Scalar pointers. */
4292 se.want_pointer = 1;
4293 gfc_conv_expr (&se, expr);
4294 gfc_add_block_to_block (&block, &se.pre);
4295 gfc_add_modify (&block, dest,
4296 fold_convert (TREE_TYPE (dest), se.expr));
4297 gfc_add_block_to_block (&block, &se.post);
4300 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4302 /* NULL initialization for CLASS components. */
4303 tmp = gfc_trans_structure_assign (dest,
4304 gfc_class_null_initializer (&cm->ts));
4305 gfc_add_expr_to_block (&block, tmp);
4307 else if (cm->attr.dimension)
4309 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4310 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4311 else if (cm->attr.allocatable)
4313 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4314 gfc_add_expr_to_block (&block, tmp);
4318 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4319 gfc_add_expr_to_block (&block, tmp);
4322 else if (expr->ts.type == BT_DERIVED)
4324 if (expr->expr_type != EXPR_STRUCTURE)
4326 gfc_init_se (&se, NULL);
4327 gfc_conv_expr (&se, expr);
4328 gfc_add_block_to_block (&block, &se.pre);
4329 gfc_add_modify (&block, dest,
4330 fold_convert (TREE_TYPE (dest), se.expr));
4331 gfc_add_block_to_block (&block, &se.post);
4335 /* Nested constructors. */
4336 tmp = gfc_trans_structure_assign (dest, expr);
4337 gfc_add_expr_to_block (&block, tmp);
4342 /* Scalar component. */
4343 gfc_init_se (&se, NULL);
4344 gfc_init_se (&lse, NULL);
4346 gfc_conv_expr (&se, expr);
4347 if (cm->ts.type == BT_CHARACTER)
4348 lse.string_length = cm->ts.u.cl->backend_decl;
4350 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4351 gfc_add_expr_to_block (&block, tmp);
4353 return gfc_finish_block (&block);
4356 /* Assign a derived type constructor to a variable. */
4359 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4367 gfc_start_block (&block);
4368 cm = expr->ts.u.derived->components;
4369 for (c = gfc_constructor_first (expr->value.constructor);
4370 c; c = gfc_constructor_next (c), cm = cm->next)
4372 /* Skip absent members in default initializers. */
4376 /* Handle c_null_(fun)ptr. */
4377 if (c && c->expr && c->expr->ts.is_iso_c)
4379 field = cm->backend_decl;
4380 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4381 dest, field, NULL_TREE);
4382 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4383 fold_convert (TREE_TYPE (tmp),
4384 null_pointer_node));
4385 gfc_add_expr_to_block (&block, tmp);
4389 field = cm->backend_decl;
4390 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4391 dest, field, NULL_TREE);
4392 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4393 gfc_add_expr_to_block (&block, tmp);
4395 return gfc_finish_block (&block);
4398 /* Build an expression for a constructor. If init is nonzero then
4399 this is part of a static variable initializer. */
4402 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4409 VEC(constructor_elt,gc) *v = NULL;
4411 gcc_assert (se->ss == NULL);
4412 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4413 type = gfc_typenode_for_spec (&expr->ts);
4417 /* Create a temporary variable and fill it in. */
4418 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4419 tmp = gfc_trans_structure_assign (se->expr, expr);
4420 gfc_add_expr_to_block (&se->pre, tmp);
4424 cm = expr->ts.u.derived->components;
4426 for (c = gfc_constructor_first (expr->value.constructor);
4427 c; c = gfc_constructor_next (c), cm = cm->next)
4429 /* Skip absent members in default initializers and allocatable
4430 components. Although the latter have a default initializer
4431 of EXPR_NULL,... by default, the static nullify is not needed
4432 since this is done every time we come into scope. */
4433 if (!c->expr || cm->attr.allocatable)
4436 if (strcmp (cm->name, "$size") == 0)
4438 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4439 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4441 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4442 && strcmp (cm->name, "$extends") == 0)
4446 vtabs = cm->initializer->symtree->n.sym;
4447 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4448 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4452 val = gfc_conv_initializer (c->expr, &cm->ts,
4453 TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4454 cm->attr.pointer || cm->attr.proc_pointer);
4456 /* Append it to the constructor list. */
4457 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4460 se->expr = build_constructor (type, v);
4462 TREE_CONSTANT (se->expr) = 1;
4466 /* Translate a substring expression. */
4469 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4475 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4477 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4478 expr->value.character.length,
4479 expr->value.character.string);
4481 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4482 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4485 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4489 /* Entry point for expression translation. Evaluates a scalar quantity.
4490 EXPR is the expression to be translated, and SE is the state structure if
4491 called from within the scalarized. */
4494 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4496 if (se->ss && se->ss->expr == expr
4497 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4499 /* Substitute a scalar expression evaluated outside the scalarization
4501 se->expr = se->ss->data.scalar.expr;
4502 if (se->ss->type == GFC_SS_REFERENCE)
4503 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4504 se->string_length = se->ss->string_length;
4505 gfc_advance_se_ss_chain (se);
4509 /* We need to convert the expressions for the iso_c_binding derived types.
4510 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4511 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4512 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4513 updated to be an integer with a kind equal to the size of a (void *). */
4514 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4515 && expr->ts.u.derived->attr.is_iso_c)
4517 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4518 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4520 /* Set expr_type to EXPR_NULL, which will result in
4521 null_pointer_node being used below. */
4522 expr->expr_type = EXPR_NULL;
4526 /* Update the type/kind of the expression to be what the new
4527 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4528 expr->ts.type = expr->ts.u.derived->ts.type;
4529 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4530 expr->ts.kind = expr->ts.u.derived->ts.kind;
4534 switch (expr->expr_type)
4537 gfc_conv_expr_op (se, expr);
4541 gfc_conv_function_expr (se, expr);
4545 gfc_conv_constant (se, expr);
4549 gfc_conv_variable (se, expr);
4553 se->expr = null_pointer_node;
4556 case EXPR_SUBSTRING:
4557 gfc_conv_substring_expr (se, expr);
4560 case EXPR_STRUCTURE:
4561 gfc_conv_structure (se, expr, 0);
4565 gfc_conv_array_constructor_expr (se, expr);
4574 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4575 of an assignment. */
4577 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4579 gfc_conv_expr (se, expr);
4580 /* All numeric lvalues should have empty post chains. If not we need to
4581 figure out a way of rewriting an lvalue so that it has no post chain. */
4582 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4585 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4586 numeric expressions. Used for scalar values where inserting cleanup code
4589 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4593 gcc_assert (expr->ts.type != BT_CHARACTER);
4594 gfc_conv_expr (se, expr);
4597 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4598 gfc_add_modify (&se->pre, val, se->expr);
4600 gfc_add_block_to_block (&se->pre, &se->post);
4604 /* Helper to translate an expression and convert it to a particular type. */
4606 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4608 gfc_conv_expr_val (se, expr);
4609 se->expr = convert (type, se->expr);
4613 /* Converts an expression so that it can be passed by reference. Scalar
4617 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4621 if (se->ss && se->ss->expr == expr
4622 && se->ss->type == GFC_SS_REFERENCE)
4624 /* Returns a reference to the scalar evaluated outside the loop
4626 gfc_conv_expr (se, expr);
4630 if (expr->ts.type == BT_CHARACTER)
4632 gfc_conv_expr (se, expr);
4633 gfc_conv_string_parameter (se);
4637 if (expr->expr_type == EXPR_VARIABLE)
4639 se->want_pointer = 1;
4640 gfc_conv_expr (se, expr);
4643 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4644 gfc_add_modify (&se->pre, var, se->expr);
4645 gfc_add_block_to_block (&se->pre, &se->post);
4651 if (expr->expr_type == EXPR_FUNCTION
4652 && ((expr->value.function.esym
4653 && expr->value.function.esym->result->attr.pointer
4654 && !expr->value.function.esym->result->attr.dimension)
4655 || (!expr->value.function.esym
4656 && expr->symtree->n.sym->attr.pointer
4657 && !expr->symtree->n.sym->attr.dimension)))
4659 se->want_pointer = 1;
4660 gfc_conv_expr (se, expr);
4661 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4662 gfc_add_modify (&se->pre, var, se->expr);
4668 gfc_conv_expr (se, expr);
4670 /* Create a temporary var to hold the value. */
4671 if (TREE_CONSTANT (se->expr))
4673 tree tmp = se->expr;
4674 STRIP_TYPE_NOPS (tmp);
4675 var = build_decl (input_location,
4676 CONST_DECL, NULL, TREE_TYPE (tmp));
4677 DECL_INITIAL (var) = tmp;
4678 TREE_STATIC (var) = 1;
4683 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4684 gfc_add_modify (&se->pre, var, se->expr);
4686 gfc_add_block_to_block (&se->pre, &se->post);
4688 /* Take the address of that value. */
4689 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4694 gfc_trans_pointer_assign (gfc_code * code)
4696 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4700 /* Generate code for a pointer assignment. */
4703 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4714 gfc_start_block (&block);
4716 gfc_init_se (&lse, NULL);
4718 lss = gfc_walk_expr (expr1);
4719 rss = gfc_walk_expr (expr2);
4720 if (lss == gfc_ss_terminator)
4722 /* Scalar pointers. */
4723 lse.want_pointer = 1;
4724 gfc_conv_expr (&lse, expr1);
4725 gcc_assert (rss == gfc_ss_terminator);
4726 gfc_init_se (&rse, NULL);
4727 rse.want_pointer = 1;
4728 gfc_conv_expr (&rse, expr2);
4730 if (expr1->symtree->n.sym->attr.proc_pointer
4731 && expr1->symtree->n.sym->attr.dummy)
4732 lse.expr = build_fold_indirect_ref_loc (input_location,
4735 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4736 && expr2->symtree->n.sym->attr.dummy)
4737 rse.expr = build_fold_indirect_ref_loc (input_location,
4740 gfc_add_block_to_block (&block, &lse.pre);
4741 gfc_add_block_to_block (&block, &rse.pre);
4743 /* Check character lengths if character expression. The test is only
4744 really added if -fbounds-check is enabled. */
4745 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4746 && !expr1->symtree->n.sym->attr.proc_pointer
4747 && !gfc_is_proc_ptr_comp (expr1, NULL))
4749 gcc_assert (expr2->ts.type == BT_CHARACTER);
4750 gcc_assert (lse.string_length && rse.string_length);
4751 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4752 lse.string_length, rse.string_length,
4756 gfc_add_modify (&block, lse.expr,
4757 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4759 gfc_add_block_to_block (&block, &rse.post);
4760 gfc_add_block_to_block (&block, &lse.post);
4765 tree strlen_rhs = NULL_TREE;
4767 /* Array pointer. */
4768 gfc_conv_expr_descriptor (&lse, expr1, lss);
4769 strlen_lhs = lse.string_length;
4770 switch (expr2->expr_type)
4773 /* Just set the data pointer to null. */
4774 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4778 /* Assign directly to the pointer's descriptor. */
4779 lse.direct_byref = 1;
4780 gfc_conv_expr_descriptor (&lse, expr2, rss);
4781 strlen_rhs = lse.string_length;
4783 /* If this is a subreference array pointer assignment, use the rhs
4784 descriptor element size for the lhs span. */
4785 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4787 decl = expr1->symtree->n.sym->backend_decl;
4788 gfc_init_se (&rse, NULL);
4789 rse.descriptor_only = 1;
4790 gfc_conv_expr (&rse, expr2);
4791 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4792 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4793 if (!INTEGER_CST_P (tmp))
4794 gfc_add_block_to_block (&lse.post, &rse.pre);
4795 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4801 /* Assign to a temporary descriptor and then copy that
4802 temporary to the pointer. */
4804 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4807 lse.direct_byref = 1;
4808 gfc_conv_expr_descriptor (&lse, expr2, rss);
4809 strlen_rhs = lse.string_length;
4810 gfc_add_modify (&lse.pre, desc, tmp);
4814 gfc_add_block_to_block (&block, &lse.pre);
4816 /* Check string lengths if applicable. The check is only really added
4817 to the output code if -fbounds-check is enabled. */
4818 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4820 gcc_assert (expr2->ts.type == BT_CHARACTER);
4821 gcc_assert (strlen_lhs && strlen_rhs);
4822 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4823 strlen_lhs, strlen_rhs, &block);
4826 gfc_add_block_to_block (&block, &lse.post);
4828 return gfc_finish_block (&block);
4832 /* Makes sure se is suitable for passing as a function string parameter. */
4833 /* TODO: Need to check all callers of this function. It may be abused. */
4836 gfc_conv_string_parameter (gfc_se * se)
4840 if (TREE_CODE (se->expr) == STRING_CST)
4842 type = TREE_TYPE (TREE_TYPE (se->expr));
4843 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4847 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4849 if (TREE_CODE (se->expr) != INDIRECT_REF)
4851 type = TREE_TYPE (se->expr);
4852 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4856 type = gfc_get_character_type_len (gfc_default_character_kind,
4858 type = build_pointer_type (type);
4859 se->expr = gfc_build_addr_expr (type, se->expr);
4863 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4864 gcc_assert (se->string_length
4865 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4869 /* Generate code for assignment of scalar variables. Includes character
4870 strings and derived types with allocatable components.
4871 If you know that the LHS has no allocations, set dealloc to false. */
4874 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4875 bool l_is_temp, bool r_is_var, bool dealloc)
4881 gfc_init_block (&block);
4883 if (ts.type == BT_CHARACTER)
4888 if (lse->string_length != NULL_TREE)
4890 gfc_conv_string_parameter (lse);
4891 gfc_add_block_to_block (&block, &lse->pre);
4892 llen = lse->string_length;
4895 if (rse->string_length != NULL_TREE)
4897 gcc_assert (rse->string_length != NULL_TREE);
4898 gfc_conv_string_parameter (rse);
4899 gfc_add_block_to_block (&block, &rse->pre);
4900 rlen = rse->string_length;
4903 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4904 rse->expr, ts.kind);
4906 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4910 /* Are the rhs and the lhs the same? */
4913 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4914 gfc_build_addr_expr (NULL_TREE, lse->expr),
4915 gfc_build_addr_expr (NULL_TREE, rse->expr));
4916 cond = gfc_evaluate_now (cond, &lse->pre);
4919 /* Deallocate the lhs allocated components as long as it is not
4920 the same as the rhs. This must be done following the assignment
4921 to prevent deallocating data that could be used in the rhs
4923 if (!l_is_temp && dealloc)
4925 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4926 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4928 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4930 gfc_add_expr_to_block (&lse->post, tmp);
4933 gfc_add_block_to_block (&block, &rse->pre);
4934 gfc_add_block_to_block (&block, &lse->pre);
4936 gfc_add_modify (&block, lse->expr,
4937 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4939 /* Do a deep copy if the rhs is a variable, if it is not the
4943 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4944 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4946 gfc_add_expr_to_block (&block, tmp);
4949 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4951 gfc_add_block_to_block (&block, &lse->pre);
4952 gfc_add_block_to_block (&block, &rse->pre);
4953 tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4954 gfc_add_modify (&block, lse->expr, tmp);
4958 gfc_add_block_to_block (&block, &lse->pre);
4959 gfc_add_block_to_block (&block, &rse->pre);
4961 gfc_add_modify (&block, lse->expr,
4962 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4965 gfc_add_block_to_block (&block, &lse->post);
4966 gfc_add_block_to_block (&block, &rse->post);
4968 return gfc_finish_block (&block);
4972 /* There are quite a lot of restrictions on the optimisation in using an
4973 array function assign without a temporary. */
4976 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
4979 bool seen_array_ref;
4981 gfc_symbol *sym = expr1->symtree->n.sym;
4983 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4984 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4987 /* Elemental functions are scalarized so that they don't need a
4988 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
4989 they would need special treatment in gfc_trans_arrayfunc_assign. */
4990 if (expr2->value.function.esym != NULL
4991 && expr2->value.function.esym->attr.elemental)
4994 /* Need a temporary if rhs is not FULL or a contiguous section. */
4995 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4998 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
4999 if (gfc_ref_needs_temporary_p (expr1->ref))
5002 /* Functions returning pointers need temporaries. */
5003 if (expr2->symtree->n.sym->attr.pointer
5004 || expr2->symtree->n.sym->attr.allocatable)
5007 /* Character array functions need temporaries unless the
5008 character lengths are the same. */
5009 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5011 if (expr1->ts.u.cl->length == NULL
5012 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5015 if (expr2->ts.u.cl->length == NULL
5016 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5019 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5020 expr2->ts.u.cl->length->value.integer) != 0)
5024 /* Check that no LHS component references appear during an array
5025 reference. This is needed because we do not have the means to
5026 span any arbitrary stride with an array descriptor. This check
5027 is not needed for the rhs because the function result has to be
5029 seen_array_ref = false;
5030 for (ref = expr1->ref; ref; ref = ref->next)
5032 if (ref->type == REF_ARRAY)
5033 seen_array_ref= true;
5034 else if (ref->type == REF_COMPONENT && seen_array_ref)
5038 /* Check for a dependency. */
5039 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5040 expr2->value.function.esym,
5041 expr2->value.function.actual,
5045 /* If we have reached here with an intrinsic function, we do not
5046 need a temporary. */
5047 if (expr2->value.function.isym)
5050 /* If the LHS is a dummy, we need a temporary if it is not
5052 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5055 /* A PURE function can unconditionally be called without a temporary. */
5056 if (expr2->value.function.esym != NULL
5057 && expr2->value.function.esym->attr.pure)
5060 /* TODO a function that could correctly be declared PURE but is not
5061 could do with returning false as well. */
5063 if (!sym->attr.use_assoc
5064 && !sym->attr.in_common
5065 && !sym->attr.pointer
5066 && !sym->attr.target
5067 && expr2->value.function.esym)
5069 /* A temporary is not needed if the function is not contained and
5070 the variable is local or host associated and not a pointer or
5072 if (!expr2->value.function.esym->attr.contained)
5075 /* A temporary is not needed if the lhs has never been host
5076 associated and the procedure is contained. */
5077 else if (!sym->attr.host_assoc)
5080 /* A temporary is not needed if the variable is local and not
5081 a pointer, a target or a result. */
5083 && expr2->value.function.esym->ns == sym->ns->parent)
5087 /* Default to temporary use. */
5092 /* Try to translate array(:) = func (...), where func is a transformational
5093 array function, without using a temporary. Returns NULL if this isn't the
5097 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5101 gfc_component *comp = NULL;
5103 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5106 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5108 gcc_assert (expr2->value.function.isym
5109 || (gfc_is_proc_ptr_comp (expr2, &comp)
5110 && comp && comp->attr.dimension)
5111 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5112 && expr2->value.function.esym->result->attr.dimension));
5114 ss = gfc_walk_expr (expr1);
5115 gcc_assert (ss != gfc_ss_terminator);
5116 gfc_init_se (&se, NULL);
5117 gfc_start_block (&se.pre);
5118 se.want_pointer = 1;
5120 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5122 if (expr1->ts.type == BT_DERIVED
5123 && expr1->ts.u.derived->attr.alloc_comp)
5126 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5128 gfc_add_expr_to_block (&se.pre, tmp);
5131 se.direct_byref = 1;
5132 se.ss = gfc_walk_expr (expr2);
5133 gcc_assert (se.ss != gfc_ss_terminator);
5134 gfc_conv_function_expr (&se, expr2);
5135 gfc_add_block_to_block (&se.pre, &se.post);
5137 return gfc_finish_block (&se.pre);
5141 /* Try to efficiently translate array(:) = 0. Return NULL if this
5145 gfc_trans_zero_assign (gfc_expr * expr)
5147 tree dest, len, type;
5151 sym = expr->symtree->n.sym;
5152 dest = gfc_get_symbol_decl (sym);
5154 type = TREE_TYPE (dest);
5155 if (POINTER_TYPE_P (type))
5156 type = TREE_TYPE (type);
5157 if (!GFC_ARRAY_TYPE_P (type))
5160 /* Determine the length of the array. */
5161 len = GFC_TYPE_ARRAY_SIZE (type);
5162 if (!len || TREE_CODE (len) != INTEGER_CST)
5165 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5166 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5167 fold_convert (gfc_array_index_type, tmp));
5169 /* If we are zeroing a local array avoid taking its address by emitting
5171 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5172 return build2 (MODIFY_EXPR, void_type_node,
5173 dest, build_constructor (TREE_TYPE (dest), NULL));
5175 /* Convert arguments to the correct types. */
5176 dest = fold_convert (pvoid_type_node, dest);
5177 len = fold_convert (size_type_node, len);
5179 /* Construct call to __builtin_memset. */
5180 tmp = build_call_expr_loc (input_location,
5181 built_in_decls[BUILT_IN_MEMSET],
5182 3, dest, integer_zero_node, len);
5183 return fold_convert (void_type_node, tmp);
5187 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5188 that constructs the call to __builtin_memcpy. */
5191 gfc_build_memcpy_call (tree dst, tree src, tree len)
5195 /* Convert arguments to the correct types. */
5196 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5197 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5199 dst = fold_convert (pvoid_type_node, dst);
5201 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5202 src = gfc_build_addr_expr (pvoid_type_node, src);
5204 src = fold_convert (pvoid_type_node, src);
5206 len = fold_convert (size_type_node, len);
5208 /* Construct call to __builtin_memcpy. */
5209 tmp = build_call_expr_loc (input_location,
5210 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5211 return fold_convert (void_type_node, tmp);
5215 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5216 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5217 source/rhs, both are gfc_full_array_ref_p which have been checked for
5221 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5223 tree dst, dlen, dtype;
5224 tree src, slen, stype;
5227 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5228 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5230 dtype = TREE_TYPE (dst);
5231 if (POINTER_TYPE_P (dtype))
5232 dtype = TREE_TYPE (dtype);
5233 stype = TREE_TYPE (src);
5234 if (POINTER_TYPE_P (stype))
5235 stype = TREE_TYPE (stype);
5237 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5240 /* Determine the lengths of the arrays. */
5241 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5242 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5244 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5245 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5246 fold_convert (gfc_array_index_type, tmp));
5248 slen = GFC_TYPE_ARRAY_SIZE (stype);
5249 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5251 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5252 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5253 fold_convert (gfc_array_index_type, tmp));
5255 /* Sanity check that they are the same. This should always be
5256 the case, as we should already have checked for conformance. */
5257 if (!tree_int_cst_equal (slen, dlen))
5260 return gfc_build_memcpy_call (dst, src, dlen);
5264 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5265 this can't be done. EXPR1 is the destination/lhs for which
5266 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5269 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5271 unsigned HOST_WIDE_INT nelem;
5277 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5281 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5282 dtype = TREE_TYPE (dst);
5283 if (POINTER_TYPE_P (dtype))
5284 dtype = TREE_TYPE (dtype);
5285 if (!GFC_ARRAY_TYPE_P (dtype))
5288 /* Determine the lengths of the array. */
5289 len = GFC_TYPE_ARRAY_SIZE (dtype);
5290 if (!len || TREE_CODE (len) != INTEGER_CST)
5293 /* Confirm that the constructor is the same size. */
5294 if (compare_tree_int (len, nelem) != 0)
5297 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5298 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5299 fold_convert (gfc_array_index_type, tmp));
5301 stype = gfc_typenode_for_spec (&expr2->ts);
5302 src = gfc_build_constant_array_constructor (expr2, stype);
5304 stype = TREE_TYPE (src);
5305 if (POINTER_TYPE_P (stype))
5306 stype = TREE_TYPE (stype);
5308 return gfc_build_memcpy_call (dst, src, len);
5312 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5313 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5314 init_flag indicates initialization expressions and dealloc that no
5315 deallocate prior assignment is needed (if in doubt, set true). */
5318 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5324 gfc_ss *lss_section;
5331 bool scalar_to_array;
5335 /* Assignment of the form lhs = rhs. */
5336 gfc_start_block (&block);
5338 gfc_init_se (&lse, NULL);
5339 gfc_init_se (&rse, NULL);
5342 lss = gfc_walk_expr (expr1);
5344 if (lss != gfc_ss_terminator)
5346 /* Allow the scalarizer to workshare array assignments. */
5347 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5348 ompws_flags |= OMPWS_SCALARIZER_WS;
5350 /* The assignment needs scalarization. */
5353 /* Find a non-scalar SS from the lhs. */
5354 while (lss_section != gfc_ss_terminator
5355 && lss_section->type != GFC_SS_SECTION)
5356 lss_section = lss_section->next;
5358 gcc_assert (lss_section != gfc_ss_terminator);
5360 /* Initialize the scalarizer. */
5361 gfc_init_loopinfo (&loop);
5364 rss = gfc_walk_expr (expr2);
5365 if (rss == gfc_ss_terminator)
5367 /* The rhs is scalar. Add a ss for the expression. */
5368 rss = gfc_get_ss ();
5369 rss->next = gfc_ss_terminator;
5370 rss->type = GFC_SS_SCALAR;
5373 /* Associate the SS with the loop. */
5374 gfc_add_ss_to_loop (&loop, lss);
5375 gfc_add_ss_to_loop (&loop, rss);
5377 /* Calculate the bounds of the scalarization. */
5378 gfc_conv_ss_startstride (&loop);
5379 /* Enable loop reversal. */
5380 for (n = 0; n < loop.dimen; n++)
5381 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5382 /* Resolve any data dependencies in the statement. */
5383 gfc_conv_resolve_dependencies (&loop, lss, rss);
5384 /* Setup the scalarizing loops. */
5385 gfc_conv_loop_setup (&loop, &expr2->where);
5387 /* Setup the gfc_se structures. */
5388 gfc_copy_loopinfo_to_se (&lse, &loop);
5389 gfc_copy_loopinfo_to_se (&rse, &loop);
5392 gfc_mark_ss_chain_used (rss, 1);
5393 if (loop.temp_ss == NULL)
5396 gfc_mark_ss_chain_used (lss, 1);
5400 lse.ss = loop.temp_ss;
5401 gfc_mark_ss_chain_used (lss, 3);
5402 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5405 /* Start the scalarized loop body. */
5406 gfc_start_scalarized_body (&loop, &body);
5409 gfc_init_block (&body);
5411 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5413 /* Translate the expression. */
5414 gfc_conv_expr (&rse, expr2);
5416 /* Stabilize a string length for temporaries. */
5417 if (expr2->ts.type == BT_CHARACTER)
5418 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5420 string_length = NULL_TREE;
5424 gfc_conv_tmp_array_ref (&lse);
5425 gfc_advance_se_ss_chain (&lse);
5426 if (expr2->ts.type == BT_CHARACTER)
5427 lse.string_length = string_length;
5430 gfc_conv_expr (&lse, expr1);
5432 /* Assignments of scalar derived types with allocatable components
5433 to arrays must be done with a deep copy and the rhs temporary
5434 must have its components deallocated afterwards. */
5435 scalar_to_array = (expr2->ts.type == BT_DERIVED
5436 && expr2->ts.u.derived->attr.alloc_comp
5437 && expr2->expr_type != EXPR_VARIABLE
5438 && !gfc_is_constant_expr (expr2)
5439 && expr1->rank && !expr2->rank);
5440 if (scalar_to_array && dealloc)
5442 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5443 gfc_add_expr_to_block (&loop.post, tmp);
5446 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5447 l_is_temp || init_flag,
5448 (expr2->expr_type == EXPR_VARIABLE)
5449 || scalar_to_array, dealloc);
5450 gfc_add_expr_to_block (&body, tmp);
5452 if (lss == gfc_ss_terminator)
5454 /* Use the scalar assignment as is. */
5455 gfc_add_block_to_block (&block, &body);
5459 gcc_assert (lse.ss == gfc_ss_terminator
5460 && rse.ss == gfc_ss_terminator);
5464 gfc_trans_scalarized_loop_boundary (&loop, &body);
5466 /* We need to copy the temporary to the actual lhs. */
5467 gfc_init_se (&lse, NULL);
5468 gfc_init_se (&rse, NULL);
5469 gfc_copy_loopinfo_to_se (&lse, &loop);
5470 gfc_copy_loopinfo_to_se (&rse, &loop);
5472 rse.ss = loop.temp_ss;
5475 gfc_conv_tmp_array_ref (&rse);
5476 gfc_advance_se_ss_chain (&rse);
5477 gfc_conv_expr (&lse, expr1);
5479 gcc_assert (lse.ss == gfc_ss_terminator
5480 && rse.ss == gfc_ss_terminator);
5482 if (expr2->ts.type == BT_CHARACTER)
5483 rse.string_length = string_length;
5485 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5486 false, false, dealloc);
5487 gfc_add_expr_to_block (&body, tmp);
5490 /* Generate the copying loops. */
5491 gfc_trans_scalarizing_loops (&loop, &body);
5493 /* Wrap the whole thing up. */
5494 gfc_add_block_to_block (&block, &loop.pre);
5495 gfc_add_block_to_block (&block, &loop.post);
5497 gfc_cleanup_loop (&loop);
5500 return gfc_finish_block (&block);
5504 /* Check whether EXPR is a copyable array. */
5507 copyable_array_p (gfc_expr * expr)
5509 if (expr->expr_type != EXPR_VARIABLE)
5512 /* First check it's an array. */
5513 if (expr->rank < 1 || !expr->ref || expr->ref->next)
5516 if (!gfc_full_array_ref_p (expr->ref, NULL))
5519 /* Next check that it's of a simple enough type. */
5520 switch (expr->ts.type)
5532 return !expr->ts.u.derived->attr.alloc_comp;
5541 /* Translate an assignment. */
5544 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5549 /* Special case a single function returning an array. */
5550 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5552 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5557 /* Special case assigning an array to zero. */
5558 if (copyable_array_p (expr1)
5559 && is_zero_initializer_p (expr2))
5561 tmp = gfc_trans_zero_assign (expr1);
5566 /* Special case copying one array to another. */
5567 if (copyable_array_p (expr1)
5568 && copyable_array_p (expr2)
5569 && gfc_compare_types (&expr1->ts, &expr2->ts)
5570 && !gfc_check_dependency (expr1, expr2, 0))
5572 tmp = gfc_trans_array_copy (expr1, expr2);
5577 /* Special case initializing an array from a constant array constructor. */
5578 if (copyable_array_p (expr1)
5579 && expr2->expr_type == EXPR_ARRAY
5580 && gfc_compare_types (&expr1->ts, &expr2->ts))
5582 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5587 /* Fallback to the scalarizer to generate explicit loops. */
5588 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
5592 gfc_trans_init_assign (gfc_code * code)
5594 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5598 gfc_trans_assign (gfc_code * code)
5600 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
5604 /* Generate code to assign typebound procedures to a derived vtab. */
5605 void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
5612 tree cond = NULL_TREE;
5616 /* Point to the first procedure pointer. */
5617 cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
5619 seen_extends = (cmp != NULL);
5621 vtb = gfc_get_symbol_decl (vtab);
5628 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5629 vtb, cmp->backend_decl, NULL_TREE);
5630 cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
5631 build_int_cst (TREE_TYPE (ctree), 0));
5635 cmp = vtab->ts.u.derived->components;
5638 gfc_init_block (&body);
5639 for (; cmp; cmp = cmp->next)
5641 gfc_symbol *target = NULL;
5643 /* Generic procedure - build its vtab. */
5644 if (cmp->ts.type == BT_DERIVED && !cmp->tb)
5646 gfc_symbol *vt = cmp->ts.interface;
5650 /* Use association loses the interface. Obtain the vtab
5652 char name[2 * GFC_MAX_SYMBOL_LEN + 8];
5653 sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
5655 gfc_find_symbol (name, vtab->ns, 0, &vt);
5660 gfc_trans_assign_vtab_procs (&body, dt, vt);
5661 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5662 vtb, cmp->backend_decl, NULL_TREE);
5663 proc = gfc_get_symbol_decl (vt);
5664 proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
5665 gfc_add_modify (&body, ctree, proc);
5669 /* This is required when typebound generic procedures are called
5670 with derived type targets. The specific procedures do not get
5671 added to the vtype, which remains "empty". */
5672 if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
5673 target = cmp->tb->u.specific->n.sym;
5677 st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
5678 if (st->n.tb && st->n.tb->u.specific)
5679 target = st->n.tb->u.specific->n.sym;
5685 ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
5686 vtb, cmp->backend_decl, NULL_TREE);
5687 proc = gfc_get_symbol_decl (target);
5688 proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
5689 gfc_add_modify (&body, ctree, proc);
5692 proc = gfc_finish_block (&body);
5695 proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
5697 gfc_add_expr_to_block (block, proc);
5701 /* Special case for initializing a CLASS variable on allocation.
5702 A MEMCPY is needed to copy the full data of the dynamic type,
5703 which may be different from the declared type. */
5706 gfc_trans_class_init_assign (gfc_code *code)
5712 gfc_start_block (&block);
5714 gfc_init_se (&dst, NULL);
5715 gfc_init_se (&src, NULL);
5716 gfc_add_component_ref (code->expr1, "$data");
5717 gfc_conv_expr (&dst, code->expr1);
5718 gfc_conv_expr (&src, code->expr2);
5719 gfc_add_block_to_block (&block, &src.pre);
5720 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
5721 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
5722 gfc_add_expr_to_block (&block, tmp);
5724 return gfc_finish_block (&block);
5728 /* Translate an assignment to a CLASS object
5729 (pointer or ordinary assignment). */
5732 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5739 gfc_start_block (&block);
5741 if (expr2->ts.type != BT_CLASS)
5743 /* Insert an additional assignment which sets the '$vptr' field. */
5744 lhs = gfc_copy_expr (expr1);
5745 gfc_add_component_ref (lhs, "$vptr");
5746 if (expr2->ts.type == BT_DERIVED)
5750 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
5752 gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
5753 rhs = gfc_get_expr ();
5754 rhs->expr_type = EXPR_VARIABLE;
5755 gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5759 else if (expr2->expr_type == EXPR_NULL)
5760 rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5764 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5765 gfc_add_expr_to_block (&block, tmp);
5767 gfc_free_expr (lhs);
5768 gfc_free_expr (rhs);
5771 /* Do the actual CLASS assignment. */
5772 if (expr2->ts.type == BT_CLASS)
5775 gfc_add_component_ref (expr1, "$data");
5777 if (op == EXEC_ASSIGN)
5778 tmp = gfc_trans_assignment (expr1, expr2, false, true);
5779 else if (op == EXEC_POINTER_ASSIGN)
5780 tmp = gfc_trans_pointer_assignment (expr1, expr2);
5784 gfc_add_expr_to_block (&block, tmp);
5786 return gfc_finish_block (&block);