1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
144 /* Fortran 2008 allows to pass null pointers and non-associated pointers
145 as actual argument to denote absent dummies. For array descriptors,
146 we thus also need to check the array descriptor. */
147 if (!sym->attr.pointer && !sym->attr.allocatable
148 && sym->as && sym->as->type == AS_ASSUMED_SHAPE
149 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
152 tmp = build_fold_indirect_ref_loc (input_location, decl);
153 tmp = gfc_conv_array_data (tmp);
154 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
155 fold_convert (TREE_TYPE (tmp), null_pointer_node));
156 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
157 boolean_type_node, cond, tmp);
164 /* Converts a missing, dummy argument into a null or zero. */
167 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
172 present = gfc_conv_expr_present (arg->symtree->n.sym);
176 /* Create a temporary and convert it to the correct type. */
177 tmp = gfc_get_int_type (kind);
178 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
181 /* Test for a NULL value. */
182 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
183 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
184 tmp = gfc_evaluate_now (tmp, &se->pre);
185 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
189 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
191 build_zero_cst (TREE_TYPE (se->expr)));
192 tmp = gfc_evaluate_now (tmp, &se->pre);
196 if (ts.type == BT_CHARACTER)
198 tmp = build_int_cst (gfc_charlen_type_node, 0);
199 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
200 present, se->string_length, tmp);
201 tmp = gfc_evaluate_now (tmp, &se->pre);
202 se->string_length = tmp;
208 /* Get the character length of an expression, looking through gfc_refs
212 gfc_get_expr_charlen (gfc_expr *e)
217 gcc_assert (e->expr_type == EXPR_VARIABLE
218 && e->ts.type == BT_CHARACTER);
220 length = NULL; /* To silence compiler warning. */
222 if (is_subref_array (e) && e->ts.u.cl->length)
225 gfc_init_se (&tmpse, NULL);
226 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
227 e->ts.u.cl->backend_decl = tmpse.expr;
231 /* First candidate: if the variable is of type CHARACTER, the
232 expression's length could be the length of the character
234 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
235 length = e->symtree->n.sym->ts.u.cl->backend_decl;
237 /* Look through the reference chain for component references. */
238 for (r = e->ref; r; r = r->next)
243 if (r->u.c.component->ts.type == BT_CHARACTER)
244 length = r->u.c.component->ts.u.cl->backend_decl;
252 /* We should never got substring references here. These will be
253 broken down by the scalarizer. */
259 gcc_assert (length != NULL);
264 /* For each character array constructor subexpression without a ts.u.cl->length,
265 replace it by its first element (if there aren't any elements, the length
266 should already be set to zero). */
269 flatten_array_ctors_without_strlen (gfc_expr* e)
271 gfc_actual_arglist* arg;
277 switch (e->expr_type)
281 flatten_array_ctors_without_strlen (e->value.op.op1);
282 flatten_array_ctors_without_strlen (e->value.op.op2);
286 /* TODO: Implement as with EXPR_FUNCTION when needed. */
290 for (arg = e->value.function.actual; arg; arg = arg->next)
291 flatten_array_ctors_without_strlen (arg->expr);
296 /* We've found what we're looking for. */
297 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
302 gcc_assert (e->value.constructor);
304 c = gfc_constructor_first (e->value.constructor);
308 flatten_array_ctors_without_strlen (new_expr);
309 gfc_replace_expr (e, new_expr);
313 /* Otherwise, fall through to handle constructor elements. */
315 for (c = gfc_constructor_first (e->value.constructor);
316 c; c = gfc_constructor_next (c))
317 flatten_array_ctors_without_strlen (c->expr);
327 /* Generate code to initialize a string length variable. Returns the
328 value. For array constructors, cl->length might be NULL and in this case,
329 the first element of the constructor is needed. expr is the original
330 expression so we can access it but can be NULL if this is not needed. */
333 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
337 gfc_init_se (&se, NULL);
341 && TREE_CODE (cl->backend_decl) == VAR_DECL)
344 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
345 "flatten" array constructors by taking their first element; all elements
346 should be the same length or a cl->length should be present. */
351 expr_flat = gfc_copy_expr (expr);
352 flatten_array_ctors_without_strlen (expr_flat);
353 gfc_resolve_expr (expr_flat);
355 gfc_conv_expr (&se, expr_flat);
356 gfc_add_block_to_block (pblock, &se.pre);
357 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
359 gfc_free_expr (expr_flat);
363 /* Convert cl->length. */
365 gcc_assert (cl->length);
367 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
368 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
369 se.expr, build_int_cst (gfc_charlen_type_node, 0));
370 gfc_add_block_to_block (pblock, &se.pre);
372 if (cl->backend_decl)
373 gfc_add_modify (pblock, cl->backend_decl, se.expr);
375 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
380 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
381 const char *name, locus *where)
390 type = gfc_get_character_type (kind, ref->u.ss.length);
391 type = build_pointer_type (type);
393 gfc_init_se (&start, se);
394 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
395 gfc_add_block_to_block (&se->pre, &start.pre);
397 if (integer_onep (start.expr))
398 gfc_conv_string_parameter (se);
403 /* Avoid multiple evaluation of substring start. */
404 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
405 start.expr = gfc_evaluate_now (start.expr, &se->pre);
407 /* Change the start of the string. */
408 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
411 tmp = build_fold_indirect_ref_loc (input_location,
413 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
414 se->expr = gfc_build_addr_expr (type, tmp);
417 /* Length = end + 1 - start. */
418 gfc_init_se (&end, se);
419 if (ref->u.ss.end == NULL)
420 end.expr = se->string_length;
423 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
424 gfc_add_block_to_block (&se->pre, &end.pre);
428 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
429 end.expr = gfc_evaluate_now (end.expr, &se->pre);
431 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
433 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
434 boolean_type_node, start.expr,
437 /* Check lower bound. */
438 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
440 build_int_cst (gfc_charlen_type_node, 1));
441 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
442 boolean_type_node, nonempty, fault);
444 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
445 "is less than one", name);
447 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
449 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
450 fold_convert (long_integer_type_node,
454 /* Check upper bound. */
455 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
456 end.expr, se->string_length);
457 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
458 boolean_type_node, nonempty, fault);
460 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
461 "exceeds string length (%%ld)", name);
463 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
464 "exceeds string length (%%ld)");
465 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
466 fold_convert (long_integer_type_node, end.expr),
467 fold_convert (long_integer_type_node,
472 /* If the start and end expressions are equal, the length is one. */
474 && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
475 tmp = build_int_cst (gfc_charlen_type_node, 1);
478 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
479 end.expr, start.expr);
480 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
481 build_int_cst (gfc_charlen_type_node, 1), tmp);
482 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
483 tmp, build_int_cst (gfc_charlen_type_node, 0));
486 se->string_length = tmp;
490 /* Convert a derived type component reference. */
493 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
500 c = ref->u.c.component;
502 gcc_assert (c->backend_decl);
504 field = c->backend_decl;
505 gcc_assert (TREE_CODE (field) == FIELD_DECL);
507 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
508 decl, field, NULL_TREE);
512 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
514 tmp = c->ts.u.cl->backend_decl;
515 /* Components must always be constant length. */
516 gcc_assert (tmp && INTEGER_CST_P (tmp));
517 se->string_length = tmp;
520 if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
521 && c->ts.type != BT_CHARACTER)
522 || c->attr.proc_pointer)
523 se->expr = build_fold_indirect_ref_loc (input_location,
528 /* This function deals with component references to components of the
529 parent type for derived type extensons. */
531 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
539 c = ref->u.c.component;
541 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
542 parent.type = REF_COMPONENT;
545 parent.u.c.component = dt->components;
547 if (dt->backend_decl == NULL)
548 gfc_get_derived_type (dt);
550 if (dt->attr.extension && dt->components)
552 if (dt->attr.is_class)
553 cmp = dt->components;
555 cmp = dt->components->next;
556 /* Return if the component is not in the parent type. */
557 for (; cmp; cmp = cmp->next)
558 if (strcmp (c->name, cmp->name) == 0)
561 /* Otherwise build the reference and call self. */
562 gfc_conv_component_ref (se, &parent);
563 parent.u.c.sym = dt->components->ts.u.derived;
564 parent.u.c.component = c;
565 conv_parent_component_references (se, &parent);
569 /* Return the contents of a variable. Also handles reference/pointer
570 variables (all Fortran pointer references are implicit). */
573 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
577 tree parent_decl = NULL_TREE;
580 bool alternate_entry;
583 sym = expr->symtree->n.sym;
586 /* Check that something hasn't gone horribly wrong. */
587 gcc_assert (se->ss != gfc_ss_terminator);
588 gcc_assert (se->ss->expr == expr);
590 /* A scalarized term. We already know the descriptor. */
591 se->expr = se->ss->data.info.descriptor;
592 se->string_length = se->ss->string_length;
593 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
594 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
599 tree se_expr = NULL_TREE;
601 se->expr = gfc_get_symbol_decl (sym);
603 /* Deal with references to a parent results or entries by storing
604 the current_function_decl and moving to the parent_decl. */
605 return_value = sym->attr.function && sym->result == sym;
606 alternate_entry = sym->attr.function && sym->attr.entry
607 && sym->result == sym;
608 entry_master = sym->attr.result
609 && sym->ns->proc_name->attr.entry_master
610 && !gfc_return_by_reference (sym->ns->proc_name);
611 if (current_function_decl)
612 parent_decl = DECL_CONTEXT (current_function_decl);
614 if ((se->expr == parent_decl && return_value)
615 || (sym->ns && sym->ns->proc_name
617 && sym->ns->proc_name->backend_decl == parent_decl
618 && (alternate_entry || entry_master)))
623 /* Special case for assigning the return value of a function.
624 Self recursive functions must have an explicit return value. */
625 if (return_value && (se->expr == current_function_decl || parent_flag))
626 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
628 /* Similarly for alternate entry points. */
629 else if (alternate_entry
630 && (sym->ns->proc_name->backend_decl == current_function_decl
633 gfc_entry_list *el = NULL;
635 for (el = sym->ns->entries; el; el = el->next)
638 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
643 else if (entry_master
644 && (sym->ns->proc_name->backend_decl == current_function_decl
646 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
651 /* Procedure actual arguments. */
652 else if (sym->attr.flavor == FL_PROCEDURE
653 && se->expr != current_function_decl)
655 if (!sym->attr.dummy && !sym->attr.proc_pointer)
657 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
658 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
664 /* Dereference the expression, where needed. Since characters
665 are entirely different from other types, they are treated
667 if (sym->ts.type == BT_CHARACTER)
669 /* Dereference character pointer dummy arguments
671 if ((sym->attr.pointer || sym->attr.allocatable)
673 || sym->attr.function
674 || sym->attr.result))
675 se->expr = build_fold_indirect_ref_loc (input_location,
679 else if (!sym->attr.value)
681 /* Dereference non-character scalar dummy arguments. */
682 if (sym->attr.dummy && !sym->attr.dimension)
683 se->expr = build_fold_indirect_ref_loc (input_location,
686 /* Dereference scalar hidden result. */
687 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
688 && (sym->attr.function || sym->attr.result)
689 && !sym->attr.dimension && !sym->attr.pointer
690 && !sym->attr.always_explicit)
691 se->expr = build_fold_indirect_ref_loc (input_location,
694 /* Dereference non-character pointer variables.
695 These must be dummies, results, or scalars. */
696 if ((sym->attr.pointer || sym->attr.allocatable
697 || gfc_is_associate_pointer (sym))
699 || sym->attr.function
701 || !sym->attr.dimension))
702 se->expr = build_fold_indirect_ref_loc (input_location,
709 /* For character variables, also get the length. */
710 if (sym->ts.type == BT_CHARACTER)
712 /* If the character length of an entry isn't set, get the length from
713 the master function instead. */
714 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
715 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
717 se->string_length = sym->ts.u.cl->backend_decl;
718 gcc_assert (se->string_length);
726 /* Return the descriptor if that's what we want and this is an array
727 section reference. */
728 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
730 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
731 /* Return the descriptor for array pointers and allocations. */
733 && ref->next == NULL && (se->descriptor_only))
736 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
737 /* Return a pointer to an element. */
741 if (ref->u.c.sym->attr.extension)
742 conv_parent_component_references (se, ref);
744 gfc_conv_component_ref (se, ref);
748 gfc_conv_substring (se, ref, expr->ts.kind,
749 expr->symtree->name, &expr->where);
758 /* Pointer assignment, allocation or pass by reference. Arrays are handled
760 if (se->want_pointer)
762 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
763 gfc_conv_string_parameter (se);
765 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
770 /* Unary ops are easy... Or they would be if ! was a valid op. */
773 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
778 gcc_assert (expr->ts.type != BT_CHARACTER);
779 /* Initialize the operand. */
780 gfc_init_se (&operand, se);
781 gfc_conv_expr_val (&operand, expr->value.op.op1);
782 gfc_add_block_to_block (&se->pre, &operand.pre);
784 type = gfc_typenode_for_spec (&expr->ts);
786 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
787 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
788 All other unary operators have an equivalent GIMPLE unary operator. */
789 if (code == TRUTH_NOT_EXPR)
790 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
791 build_int_cst (type, 0));
793 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
797 /* Expand power operator to optimal multiplications when a value is raised
798 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
799 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
800 Programming", 3rd Edition, 1998. */
802 /* This code is mostly duplicated from expand_powi in the backend.
803 We establish the "optimal power tree" lookup table with the defined size.
804 The items in the table are the exponents used to calculate the index
805 exponents. Any integer n less than the value can get an "addition chain",
806 with the first node being one. */
807 #define POWI_TABLE_SIZE 256
809 /* The table is from builtins.c. */
810 static const unsigned char powi_table[POWI_TABLE_SIZE] =
812 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
813 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
814 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
815 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
816 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
817 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
818 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
819 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
820 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
821 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
822 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
823 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
824 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
825 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
826 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
827 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
828 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
829 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
830 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
831 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
832 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
833 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
834 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
835 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
836 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
837 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
838 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
839 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
840 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
841 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
842 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
843 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
846 /* If n is larger than lookup table's max index, we use the "window
848 #define POWI_WINDOW_SIZE 3
850 /* Recursive function to expand the power operator. The temporary
851 values are put in tmpvar. The function returns tmpvar[1] ** n. */
853 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
860 if (n < POWI_TABLE_SIZE)
865 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
866 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
870 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
871 op0 = gfc_conv_powi (se, n - digit, tmpvar);
872 op1 = gfc_conv_powi (se, digit, tmpvar);
876 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
880 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
881 tmp = gfc_evaluate_now (tmp, &se->pre);
883 if (n < POWI_TABLE_SIZE)
890 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
891 return 1. Else return 0 and a call to runtime library functions
892 will have to be built. */
894 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
899 tree vartmp[POWI_TABLE_SIZE];
901 unsigned HOST_WIDE_INT n;
904 /* If exponent is too large, we won't expand it anyway, so don't bother
905 with large integer values. */
906 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
909 m = double_int_to_shwi (TREE_INT_CST (rhs));
910 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
911 of the asymmetric range of the integer type. */
912 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
914 type = TREE_TYPE (lhs);
915 sgn = tree_int_cst_sgn (rhs);
917 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
918 || optimize_size) && (m > 2 || m < -1))
924 se->expr = gfc_build_const (type, integer_one_node);
928 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
929 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
931 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
932 lhs, build_int_cst (TREE_TYPE (lhs), -1));
933 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
934 lhs, build_int_cst (TREE_TYPE (lhs), 1));
937 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
940 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
941 boolean_type_node, tmp, cond);
942 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
943 tmp, build_int_cst (type, 1),
944 build_int_cst (type, 0));
948 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
949 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
950 build_int_cst (type, -1),
951 build_int_cst (type, 0));
952 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
953 cond, build_int_cst (type, 1), tmp);
957 memset (vartmp, 0, sizeof (vartmp));
961 tmp = gfc_build_const (type, integer_one_node);
962 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
966 se->expr = gfc_conv_powi (se, n, vartmp);
972 /* Power op (**). Constant integer exponent has special handling. */
975 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
977 tree gfc_int4_type_node;
980 int res_ikind_1, res_ikind_2;
985 gfc_init_se (&lse, se);
986 gfc_conv_expr_val (&lse, expr->value.op.op1);
987 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
988 gfc_add_block_to_block (&se->pre, &lse.pre);
990 gfc_init_se (&rse, se);
991 gfc_conv_expr_val (&rse, expr->value.op.op2);
992 gfc_add_block_to_block (&se->pre, &rse.pre);
994 if (expr->value.op.op2->ts.type == BT_INTEGER
995 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
996 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
999 gfc_int4_type_node = gfc_get_int_type (4);
1001 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1002 library routine. But in the end, we have to convert the result back
1003 if this case applies -- with res_ikind_K, we keep track whether operand K
1004 falls into this case. */
1008 kind = expr->value.op.op1->ts.kind;
1009 switch (expr->value.op.op2->ts.type)
1012 ikind = expr->value.op.op2->ts.kind;
1017 rse.expr = convert (gfc_int4_type_node, rse.expr);
1018 res_ikind_2 = ikind;
1040 if (expr->value.op.op1->ts.type == BT_INTEGER)
1042 lse.expr = convert (gfc_int4_type_node, lse.expr);
1069 switch (expr->value.op.op1->ts.type)
1072 if (kind == 3) /* Case 16 was not handled properly above. */
1074 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1078 /* Use builtins for real ** int4. */
1084 fndecl = built_in_decls[BUILT_IN_POWIF];
1088 fndecl = built_in_decls[BUILT_IN_POWI];
1092 fndecl = built_in_decls[BUILT_IN_POWIL];
1096 /* Use the __builtin_powil() only if real(kind=16) is
1097 actually the C long double type. */
1098 if (!gfc_real16_is_float128)
1099 fndecl = built_in_decls[BUILT_IN_POWIL];
1107 /* If we don't have a good builtin for this, go for the
1108 library function. */
1110 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1114 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1123 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
1127 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
1135 se->expr = build_call_expr_loc (input_location,
1136 fndecl, 2, lse.expr, rse.expr);
1138 /* Convert the result back if it is of wrong integer kind. */
1139 if (res_ikind_1 != -1 && res_ikind_2 != -1)
1141 /* We want the maximum of both operand kinds as result. */
1142 if (res_ikind_1 < res_ikind_2)
1143 res_ikind_1 = res_ikind_2;
1144 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
1149 /* Generate code to allocate a string temporary. */
1152 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1157 if (gfc_can_put_var_on_stack (len))
1159 /* Create a temporary variable to hold the result. */
1160 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1161 gfc_charlen_type_node, len,
1162 build_int_cst (gfc_charlen_type_node, 1));
1163 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1165 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1166 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1168 tmp = build_array_type (TREE_TYPE (type), tmp);
1170 var = gfc_create_var (tmp, "str");
1171 var = gfc_build_addr_expr (type, var);
1175 /* Allocate a temporary to hold the result. */
1176 var = gfc_create_var (type, "pstr");
1177 tmp = gfc_call_malloc (&se->pre, type,
1178 fold_build2_loc (input_location, MULT_EXPR,
1179 TREE_TYPE (len), len,
1180 fold_convert (TREE_TYPE (len),
1181 TYPE_SIZE (type))));
1182 gfc_add_modify (&se->pre, var, tmp);
1184 /* Free the temporary afterwards. */
1185 tmp = gfc_call_free (convert (pvoid_type_node, var));
1186 gfc_add_expr_to_block (&se->post, tmp);
1193 /* Handle a string concatenation operation. A temporary will be allocated to
1197 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1200 tree len, type, var, tmp, fndecl;
1202 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1203 && expr->value.op.op2->ts.type == BT_CHARACTER);
1204 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1206 gfc_init_se (&lse, se);
1207 gfc_conv_expr (&lse, expr->value.op.op1);
1208 gfc_conv_string_parameter (&lse);
1209 gfc_init_se (&rse, se);
1210 gfc_conv_expr (&rse, expr->value.op.op2);
1211 gfc_conv_string_parameter (&rse);
1213 gfc_add_block_to_block (&se->pre, &lse.pre);
1214 gfc_add_block_to_block (&se->pre, &rse.pre);
1216 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
1217 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1218 if (len == NULL_TREE)
1220 len = fold_build2_loc (input_location, PLUS_EXPR,
1221 TREE_TYPE (lse.string_length),
1222 lse.string_length, rse.string_length);
1225 type = build_pointer_type (type);
1227 var = gfc_conv_string_tmp (se, type, len);
1229 /* Do the actual concatenation. */
1230 if (expr->ts.kind == 1)
1231 fndecl = gfor_fndecl_concat_string;
1232 else if (expr->ts.kind == 4)
1233 fndecl = gfor_fndecl_concat_string_char4;
1237 tmp = build_call_expr_loc (input_location,
1238 fndecl, 6, len, var, lse.string_length, lse.expr,
1239 rse.string_length, rse.expr);
1240 gfc_add_expr_to_block (&se->pre, tmp);
1242 /* Add the cleanup for the operands. */
1243 gfc_add_block_to_block (&se->pre, &rse.post);
1244 gfc_add_block_to_block (&se->pre, &lse.post);
1247 se->string_length = len;
1250 /* Translates an op expression. Common (binary) cases are handled by this
1251 function, others are passed on. Recursion is used in either case.
1252 We use the fact that (op1.ts == op2.ts) (except for the power
1254 Operators need no special handling for scalarized expressions as long as
1255 they call gfc_conv_simple_val to get their operands.
1256 Character strings get special handling. */
1259 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1261 enum tree_code code;
1270 switch (expr->value.op.op)
1272 case INTRINSIC_PARENTHESES:
1273 if ((expr->ts.type == BT_REAL
1274 || expr->ts.type == BT_COMPLEX)
1275 && gfc_option.flag_protect_parens)
1277 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1278 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1283 case INTRINSIC_UPLUS:
1284 gfc_conv_expr (se, expr->value.op.op1);
1287 case INTRINSIC_UMINUS:
1288 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1292 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1295 case INTRINSIC_PLUS:
1299 case INTRINSIC_MINUS:
1303 case INTRINSIC_TIMES:
1307 case INTRINSIC_DIVIDE:
1308 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1309 an integer, we must round towards zero, so we use a
1311 if (expr->ts.type == BT_INTEGER)
1312 code = TRUNC_DIV_EXPR;
1317 case INTRINSIC_POWER:
1318 gfc_conv_power_op (se, expr);
1321 case INTRINSIC_CONCAT:
1322 gfc_conv_concat_op (se, expr);
1326 code = TRUTH_ANDIF_EXPR;
1331 code = TRUTH_ORIF_EXPR;
1335 /* EQV and NEQV only work on logicals, but since we represent them
1336 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1338 case INTRINSIC_EQ_OS:
1346 case INTRINSIC_NE_OS:
1347 case INTRINSIC_NEQV:
1354 case INTRINSIC_GT_OS:
1361 case INTRINSIC_GE_OS:
1368 case INTRINSIC_LT_OS:
1375 case INTRINSIC_LE_OS:
1381 case INTRINSIC_USER:
1382 case INTRINSIC_ASSIGN:
1383 /* These should be converted into function calls by the frontend. */
1387 fatal_error ("Unknown intrinsic op");
1391 /* The only exception to this is **, which is handled separately anyway. */
1392 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1394 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1398 gfc_init_se (&lse, se);
1399 gfc_conv_expr (&lse, expr->value.op.op1);
1400 gfc_add_block_to_block (&se->pre, &lse.pre);
1403 gfc_init_se (&rse, se);
1404 gfc_conv_expr (&rse, expr->value.op.op2);
1405 gfc_add_block_to_block (&se->pre, &rse.pre);
1409 gfc_conv_string_parameter (&lse);
1410 gfc_conv_string_parameter (&rse);
1412 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1413 rse.string_length, rse.expr,
1414 expr->value.op.op1->ts.kind,
1416 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1417 gfc_add_block_to_block (&lse.post, &rse.post);
1420 type = gfc_typenode_for_spec (&expr->ts);
1424 /* The result of logical ops is always boolean_type_node. */
1425 tmp = fold_build2_loc (input_location, code, boolean_type_node,
1426 lse.expr, rse.expr);
1427 se->expr = convert (type, tmp);
1430 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
1432 /* Add the post blocks. */
1433 gfc_add_block_to_block (&se->post, &rse.post);
1434 gfc_add_block_to_block (&se->post, &lse.post);
1437 /* If a string's length is one, we convert it to a single character. */
1440 gfc_string_to_single_character (tree len, tree str, int kind)
1443 if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
1444 || !POINTER_TYPE_P (TREE_TYPE (str)))
1447 if (TREE_INT_CST_LOW (len) == 1)
1449 str = fold_convert (gfc_get_pchar_type (kind), str);
1450 return build_fold_indirect_ref_loc (input_location, str);
1454 && TREE_CODE (str) == ADDR_EXPR
1455 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1456 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1457 && array_ref_low_bound (TREE_OPERAND (str, 0))
1458 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1459 && TREE_INT_CST_LOW (len) > 1
1460 && TREE_INT_CST_LOW (len)
1461 == (unsigned HOST_WIDE_INT)
1462 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1464 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
1465 ret = build_fold_indirect_ref_loc (input_location, ret);
1466 if (TREE_CODE (ret) == INTEGER_CST)
1468 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1469 int i, length = TREE_STRING_LENGTH (string_cst);
1470 const char *ptr = TREE_STRING_POINTER (string_cst);
1472 for (i = 1; i < length; i++)
1485 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1488 if (sym->backend_decl)
1490 /* This becomes the nominal_type in
1491 function.c:assign_parm_find_data_types. */
1492 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1493 /* This becomes the passed_type in
1494 function.c:assign_parm_find_data_types. C promotes char to
1495 integer for argument passing. */
1496 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1498 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1503 /* If we have a constant character expression, make it into an
1505 if ((*expr)->expr_type == EXPR_CONSTANT)
1510 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1511 (int)(*expr)->value.character.string[0]);
1512 if ((*expr)->ts.kind != gfc_c_int_kind)
1514 /* The expr needs to be compatible with a C int. If the
1515 conversion fails, then the 2 causes an ICE. */
1516 ts.type = BT_INTEGER;
1517 ts.kind = gfc_c_int_kind;
1518 gfc_convert_type (*expr, &ts, 2);
1521 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1523 if ((*expr)->ref == NULL)
1525 se->expr = gfc_string_to_single_character
1526 (build_int_cst (integer_type_node, 1),
1527 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1529 ((*expr)->symtree->n.sym)),
1534 gfc_conv_variable (se, *expr);
1535 se->expr = gfc_string_to_single_character
1536 (build_int_cst (integer_type_node, 1),
1537 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1545 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1546 if STR is a string literal, otherwise return -1. */
1549 gfc_optimize_len_trim (tree len, tree str, int kind)
1552 && TREE_CODE (str) == ADDR_EXPR
1553 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
1554 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
1555 && array_ref_low_bound (TREE_OPERAND (str, 0))
1556 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
1557 && TREE_INT_CST_LOW (len) >= 1
1558 && TREE_INT_CST_LOW (len)
1559 == (unsigned HOST_WIDE_INT)
1560 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
1562 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
1563 folded = build_fold_indirect_ref_loc (input_location, folded);
1564 if (TREE_CODE (folded) == INTEGER_CST)
1566 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1567 int length = TREE_STRING_LENGTH (string_cst);
1568 const char *ptr = TREE_STRING_POINTER (string_cst);
1570 for (; length > 0; length--)
1571 if (ptr[length - 1] != ' ')
1580 /* Compare two strings. If they are all single characters, the result is the
1581 subtraction of them. Otherwise, we build a library call. */
1584 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
1585 enum tree_code code)
1591 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1592 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1594 sc1 = gfc_string_to_single_character (len1, str1, kind);
1595 sc2 = gfc_string_to_single_character (len2, str2, kind);
1597 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1599 /* Deal with single character specially. */
1600 sc1 = fold_convert (integer_type_node, sc1);
1601 sc2 = fold_convert (integer_type_node, sc2);
1602 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
1606 if ((code == EQ_EXPR || code == NE_EXPR)
1608 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
1610 /* If one string is a string literal with LEN_TRIM longer
1611 than the length of the second string, the strings
1613 int len = gfc_optimize_len_trim (len1, str1, kind);
1614 if (len > 0 && compare_tree_int (len2, len) < 0)
1615 return integer_one_node;
1616 len = gfc_optimize_len_trim (len2, str2, kind);
1617 if (len > 0 && compare_tree_int (len1, len) < 0)
1618 return integer_one_node;
1621 /* Build a call for the comparison. */
1623 fndecl = gfor_fndecl_compare_string;
1625 fndecl = gfor_fndecl_compare_string_char4;
1629 return build_call_expr_loc (input_location, fndecl, 4,
1630 len1, str1, len2, str2);
1634 /* Return the backend_decl for a procedure pointer component. */
1637 get_proc_ptr_comp (gfc_expr *e)
1643 gfc_init_se (&comp_se, NULL);
1644 e2 = gfc_copy_expr (e);
1645 /* We have to restore the expr type later so that gfc_free_expr frees
1646 the exact same thing that was allocated.
1647 TODO: This is ugly. */
1648 old_type = e2->expr_type;
1649 e2->expr_type = EXPR_VARIABLE;
1650 gfc_conv_expr (&comp_se, e2);
1651 e2->expr_type = old_type;
1653 return build_fold_addr_expr_loc (input_location, comp_se.expr);
1658 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
1662 if (gfc_is_proc_ptr_comp (expr, NULL))
1663 tmp = get_proc_ptr_comp (expr);
1664 else if (sym->attr.dummy)
1666 tmp = gfc_get_symbol_decl (sym);
1667 if (sym->attr.proc_pointer)
1668 tmp = build_fold_indirect_ref_loc (input_location,
1670 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1671 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1675 if (!sym->backend_decl)
1676 sym->backend_decl = gfc_get_extern_function_decl (sym);
1678 tmp = sym->backend_decl;
1680 if (sym->attr.cray_pointee)
1682 /* TODO - make the cray pointee a pointer to a procedure,
1683 assign the pointer to it and use it for the call. This
1685 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1686 gfc_get_symbol_decl (sym->cp_pointer));
1687 tmp = gfc_evaluate_now (tmp, &se->pre);
1690 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1692 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1693 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1700 /* Initialize MAPPING. */
1703 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1705 mapping->syms = NULL;
1706 mapping->charlens = NULL;
1710 /* Free all memory held by MAPPING (but not MAPPING itself). */
1713 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1715 gfc_interface_sym_mapping *sym;
1716 gfc_interface_sym_mapping *nextsym;
1718 gfc_charlen *nextcl;
1720 for (sym = mapping->syms; sym; sym = nextsym)
1722 nextsym = sym->next;
1723 sym->new_sym->n.sym->formal = NULL;
1724 gfc_free_symbol (sym->new_sym->n.sym);
1725 gfc_free_expr (sym->expr);
1726 gfc_free (sym->new_sym);
1729 for (cl = mapping->charlens; cl; cl = nextcl)
1732 gfc_free_expr (cl->length);
1738 /* Return a copy of gfc_charlen CL. Add the returned structure to
1739 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1741 static gfc_charlen *
1742 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1745 gfc_charlen *new_charlen;
1747 new_charlen = gfc_get_charlen ();
1748 new_charlen->next = mapping->charlens;
1749 new_charlen->length = gfc_copy_expr (cl->length);
1751 mapping->charlens = new_charlen;
1756 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1757 array variable that can be used as the actual argument for dummy
1758 argument SYM. Add any initialization code to BLOCK. PACKED is as
1759 for gfc_get_nodesc_array_type and DATA points to the first element
1760 in the passed array. */
1763 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1764 gfc_packed packed, tree data)
1769 type = gfc_typenode_for_spec (&sym->ts);
1770 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1771 !sym->attr.target && !sym->attr.pointer
1772 && !sym->attr.proc_pointer);
1774 var = gfc_create_var (type, "ifm");
1775 gfc_add_modify (block, var, fold_convert (type, data));
1781 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1782 and offset of descriptorless array type TYPE given that it has the same
1783 size as DESC. Add any set-up code to BLOCK. */
1786 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1793 offset = gfc_index_zero_node;
1794 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1796 dim = gfc_rank_cst[n];
1797 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1798 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1800 GFC_TYPE_ARRAY_LBOUND (type, n)
1801 = gfc_conv_descriptor_lbound_get (desc, dim);
1802 GFC_TYPE_ARRAY_UBOUND (type, n)
1803 = gfc_conv_descriptor_ubound_get (desc, dim);
1805 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1807 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1808 gfc_array_index_type,
1809 gfc_conv_descriptor_ubound_get (desc, dim),
1810 gfc_conv_descriptor_lbound_get (desc, dim));
1811 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1812 gfc_array_index_type,
1813 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
1814 tmp = gfc_evaluate_now (tmp, block);
1815 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1817 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1818 GFC_TYPE_ARRAY_LBOUND (type, n),
1819 GFC_TYPE_ARRAY_STRIDE (type, n));
1820 offset = fold_build2_loc (input_location, MINUS_EXPR,
1821 gfc_array_index_type, offset, tmp);
1823 offset = gfc_evaluate_now (offset, block);
1824 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1828 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1829 in SE. The caller may still use se->expr and se->string_length after
1830 calling this function. */
1833 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1834 gfc_symbol * sym, gfc_se * se,
1837 gfc_interface_sym_mapping *sm;
1841 gfc_symbol *new_sym;
1843 gfc_symtree *new_symtree;
1845 /* Create a new symbol to represent the actual argument. */
1846 new_sym = gfc_new_symbol (sym->name, NULL);
1847 new_sym->ts = sym->ts;
1848 new_sym->as = gfc_copy_array_spec (sym->as);
1849 new_sym->attr.referenced = 1;
1850 new_sym->attr.dimension = sym->attr.dimension;
1851 new_sym->attr.contiguous = sym->attr.contiguous;
1852 new_sym->attr.codimension = sym->attr.codimension;
1853 new_sym->attr.pointer = sym->attr.pointer;
1854 new_sym->attr.allocatable = sym->attr.allocatable;
1855 new_sym->attr.flavor = sym->attr.flavor;
1856 new_sym->attr.function = sym->attr.function;
1858 /* Ensure that the interface is available and that
1859 descriptors are passed for array actual arguments. */
1860 if (sym->attr.flavor == FL_PROCEDURE)
1862 new_sym->formal = expr->symtree->n.sym->formal;
1863 new_sym->attr.always_explicit
1864 = expr->symtree->n.sym->attr.always_explicit;
1867 /* Create a fake symtree for it. */
1869 new_symtree = gfc_new_symtree (&root, sym->name);
1870 new_symtree->n.sym = new_sym;
1871 gcc_assert (new_symtree == root);
1873 /* Create a dummy->actual mapping. */
1874 sm = XCNEW (gfc_interface_sym_mapping);
1875 sm->next = mapping->syms;
1877 sm->new_sym = new_symtree;
1878 sm->expr = gfc_copy_expr (expr);
1881 /* Stabilize the argument's value. */
1882 if (!sym->attr.function && se)
1883 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1885 if (sym->ts.type == BT_CHARACTER)
1887 /* Create a copy of the dummy argument's length. */
1888 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
1889 sm->expr->ts.u.cl = new_sym->ts.u.cl;
1891 /* If the length is specified as "*", record the length that
1892 the caller is passing. We should use the callee's length
1893 in all other cases. */
1894 if (!new_sym->ts.u.cl->length && se)
1896 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1897 new_sym->ts.u.cl->backend_decl = se->string_length;
1904 /* Use the passed value as-is if the argument is a function. */
1905 if (sym->attr.flavor == FL_PROCEDURE)
1908 /* If the argument is either a string or a pointer to a string,
1909 convert it to a boundless character type. */
1910 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1912 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1913 tmp = build_pointer_type (tmp);
1914 if (sym->attr.pointer)
1915 value = build_fold_indirect_ref_loc (input_location,
1919 value = fold_convert (tmp, value);
1922 /* If the argument is a scalar, a pointer to an array or an allocatable,
1924 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1925 value = build_fold_indirect_ref_loc (input_location,
1928 /* For character(*), use the actual argument's descriptor. */
1929 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1930 value = build_fold_indirect_ref_loc (input_location,
1933 /* If the argument is an array descriptor, use it to determine
1934 information about the actual argument's shape. */
1935 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1936 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1938 /* Get the actual argument's descriptor. */
1939 desc = build_fold_indirect_ref_loc (input_location,
1942 /* Create the replacement variable. */
1943 tmp = gfc_conv_descriptor_data_get (desc);
1944 value = gfc_get_interface_mapping_array (&se->pre, sym,
1947 /* Use DESC to work out the upper bounds, strides and offset. */
1948 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1951 /* Otherwise we have a packed array. */
1952 value = gfc_get_interface_mapping_array (&se->pre, sym,
1953 PACKED_FULL, se->expr);
1955 new_sym->backend_decl = value;
1959 /* Called once all dummy argument mappings have been added to MAPPING,
1960 but before the mapping is used to evaluate expressions. Pre-evaluate
1961 the length of each argument, adding any initialization code to PRE and
1962 any finalization code to POST. */
1965 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1966 stmtblock_t * pre, stmtblock_t * post)
1968 gfc_interface_sym_mapping *sym;
1972 for (sym = mapping->syms; sym; sym = sym->next)
1973 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1974 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
1976 expr = sym->new_sym->n.sym->ts.u.cl->length;
1977 gfc_apply_interface_mapping_to_expr (mapping, expr);
1978 gfc_init_se (&se, NULL);
1979 gfc_conv_expr (&se, expr);
1980 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1981 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1982 gfc_add_block_to_block (pre, &se.pre);
1983 gfc_add_block_to_block (post, &se.post);
1985 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
1990 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1994 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1995 gfc_constructor_base base)
1998 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2000 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
2003 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
2004 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
2005 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
2011 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2015 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
2020 for (; ref; ref = ref->next)
2024 for (n = 0; n < ref->u.ar.dimen; n++)
2026 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
2027 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
2028 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
2030 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
2037 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
2038 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
2044 /* Convert intrinsic function calls into result expressions. */
2047 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2055 arg1 = expr->value.function.actual->expr;
2056 if (expr->value.function.actual->next)
2057 arg2 = expr->value.function.actual->next->expr;
2061 sym = arg1->symtree->n.sym;
2063 if (sym->attr.dummy)
2068 switch (expr->value.function.isym->id)
2071 /* TODO figure out why this condition is necessary. */
2072 if (sym->attr.function
2073 && (arg1->ts.u.cl->length == NULL
2074 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
2075 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2078 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2082 if (!sym->as || sym->as->rank == 0)
2085 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2087 dup = mpz_get_si (arg2->value.integer);
2092 dup = sym->as->rank;
2096 for (; d < dup; d++)
2100 if (!sym->as->upper[d] || !sym->as->lower[d])
2102 gfc_free_expr (new_expr);
2106 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
2107 gfc_get_int_expr (gfc_default_integer_kind,
2109 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
2111 new_expr = gfc_multiply (new_expr, tmp);
2117 case GFC_ISYM_LBOUND:
2118 case GFC_ISYM_UBOUND:
2119 /* TODO These implementations of lbound and ubound do not limit if
2120 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2122 if (!sym->as || sym->as->rank == 0)
2125 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
2126 d = mpz_get_si (arg2->value.integer) - 1;
2128 /* TODO: If the need arises, this could produce an array of
2132 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
2134 if (sym->as->lower[d])
2135 new_expr = gfc_copy_expr (sym->as->lower[d]);
2139 if (sym->as->upper[d])
2140 new_expr = gfc_copy_expr (sym->as->upper[d]);
2148 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2152 gfc_replace_expr (expr, new_expr);
2158 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2159 gfc_interface_mapping * mapping)
2161 gfc_formal_arglist *f;
2162 gfc_actual_arglist *actual;
2164 actual = expr->value.function.actual;
2165 f = map_expr->symtree->n.sym->formal;
2167 for (; f && actual; f = f->next, actual = actual->next)
2172 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2175 if (map_expr->symtree->n.sym->attr.dimension)
2180 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2182 for (d = 0; d < as->rank; d++)
2184 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2185 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2188 expr->value.function.esym->as = as;
2191 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2193 expr->value.function.esym->ts.u.cl->length
2194 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2196 gfc_apply_interface_mapping_to_expr (mapping,
2197 expr->value.function.esym->ts.u.cl->length);
2202 /* EXPR is a copy of an expression that appeared in the interface
2203 associated with MAPPING. Walk it recursively looking for references to
2204 dummy arguments that MAPPING maps to actual arguments. Replace each such
2205 reference with a reference to the associated actual argument. */
2208 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2211 gfc_interface_sym_mapping *sym;
2212 gfc_actual_arglist *actual;
2217 /* Copying an expression does not copy its length, so do that here. */
2218 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
2220 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
2221 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
2224 /* Apply the mapping to any references. */
2225 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2227 /* ...and to the expression's symbol, if it has one. */
2228 /* TODO Find out why the condition on expr->symtree had to be moved into
2229 the loop rather than being outside it, as originally. */
2230 for (sym = mapping->syms; sym; sym = sym->next)
2231 if (expr->symtree && sym->old == expr->symtree->n.sym)
2233 if (sym->new_sym->n.sym->backend_decl)
2234 expr->symtree = sym->new_sym;
2236 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2239 /* ...and to subexpressions in expr->value. */
2240 switch (expr->expr_type)
2245 case EXPR_SUBSTRING:
2249 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2250 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2254 for (actual = expr->value.function.actual; actual; actual = actual->next)
2255 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2257 if (expr->value.function.esym == NULL
2258 && expr->value.function.isym != NULL
2259 && expr->value.function.actual->expr->symtree
2260 && gfc_map_intrinsic_function (expr, mapping))
2263 for (sym = mapping->syms; sym; sym = sym->next)
2264 if (sym->old == expr->value.function.esym)
2266 expr->value.function.esym = sym->new_sym->n.sym;
2267 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2268 expr->value.function.esym->result = sym->new_sym->n.sym;
2273 case EXPR_STRUCTURE:
2274 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2287 /* Evaluate interface expression EXPR using MAPPING. Store the result
2291 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2292 gfc_se * se, gfc_expr * expr)
2294 expr = gfc_copy_expr (expr);
2295 gfc_apply_interface_mapping_to_expr (mapping, expr);
2296 gfc_conv_expr (se, expr);
2297 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2298 gfc_free_expr (expr);
2302 /* Returns a reference to a temporary array into which a component of
2303 an actual argument derived type array is copied and then returned
2304 after the function call. */
2306 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
2307 sym_intent intent, bool formal_ptr)
2325 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2327 gfc_init_se (&lse, NULL);
2328 gfc_init_se (&rse, NULL);
2330 /* Walk the argument expression. */
2331 rss = gfc_walk_expr (expr);
2333 gcc_assert (rss != gfc_ss_terminator);
2335 /* Initialize the scalarizer. */
2336 gfc_init_loopinfo (&loop);
2337 gfc_add_ss_to_loop (&loop, rss);
2339 /* Calculate the bounds of the scalarization. */
2340 gfc_conv_ss_startstride (&loop);
2342 /* Build an ss for the temporary. */
2343 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2344 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2346 base_type = gfc_typenode_for_spec (&expr->ts);
2347 if (GFC_ARRAY_TYPE_P (base_type)
2348 || GFC_DESCRIPTOR_TYPE_P (base_type))
2349 base_type = gfc_get_element_type (base_type);
2351 loop.temp_ss = gfc_get_ss ();;
2352 loop.temp_ss->type = GFC_SS_TEMP;
2353 loop.temp_ss->data.temp.type = base_type;
2355 if (expr->ts.type == BT_CHARACTER)
2356 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2358 loop.temp_ss->string_length = NULL;
2360 parmse->string_length = loop.temp_ss->string_length;
2361 loop.temp_ss->data.temp.dimen = loop.dimen;
2362 loop.temp_ss->next = gfc_ss_terminator;
2364 /* Associate the SS with the loop. */
2365 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2367 /* Setup the scalarizing loops. */
2368 gfc_conv_loop_setup (&loop, &expr->where);
2370 /* Pass the temporary descriptor back to the caller. */
2371 info = &loop.temp_ss->data.info;
2372 parmse->expr = info->descriptor;
2374 /* Setup the gfc_se structures. */
2375 gfc_copy_loopinfo_to_se (&lse, &loop);
2376 gfc_copy_loopinfo_to_se (&rse, &loop);
2379 lse.ss = loop.temp_ss;
2380 gfc_mark_ss_chain_used (rss, 1);
2381 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2383 /* Start the scalarized loop body. */
2384 gfc_start_scalarized_body (&loop, &body);
2386 /* Translate the expression. */
2387 gfc_conv_expr (&rse, expr);
2389 gfc_conv_tmp_array_ref (&lse);
2391 if (intent != INTENT_OUT)
2393 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2394 gfc_add_expr_to_block (&body, tmp);
2395 gcc_assert (rse.ss == gfc_ss_terminator);
2396 gfc_trans_scalarizing_loops (&loop, &body);
2400 /* Make sure that the temporary declaration survives by merging
2401 all the loop declarations into the current context. */
2402 for (n = 0; n < loop.dimen; n++)
2404 gfc_merge_block_scope (&body);
2405 body = loop.code[loop.order[n]];
2407 gfc_merge_block_scope (&body);
2410 /* Add the post block after the second loop, so that any
2411 freeing of allocated memory is done at the right time. */
2412 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2414 /**********Copy the temporary back again.*********/
2416 gfc_init_se (&lse, NULL);
2417 gfc_init_se (&rse, NULL);
2419 /* Walk the argument expression. */
2420 lss = gfc_walk_expr (expr);
2421 rse.ss = loop.temp_ss;
2424 /* Initialize the scalarizer. */
2425 gfc_init_loopinfo (&loop2);
2426 gfc_add_ss_to_loop (&loop2, lss);
2428 /* Calculate the bounds of the scalarization. */
2429 gfc_conv_ss_startstride (&loop2);
2431 /* Setup the scalarizing loops. */
2432 gfc_conv_loop_setup (&loop2, &expr->where);
2434 gfc_copy_loopinfo_to_se (&lse, &loop2);
2435 gfc_copy_loopinfo_to_se (&rse, &loop2);
2437 gfc_mark_ss_chain_used (lss, 1);
2438 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2440 /* Declare the variable to hold the temporary offset and start the
2441 scalarized loop body. */
2442 offset = gfc_create_var (gfc_array_index_type, NULL);
2443 gfc_start_scalarized_body (&loop2, &body);
2445 /* Build the offsets for the temporary from the loop variables. The
2446 temporary array has lbounds of zero and strides of one in all
2447 dimensions, so this is very simple. The offset is only computed
2448 outside the innermost loop, so the overall transfer could be
2449 optimized further. */
2450 info = &rse.ss->data.info;
2451 dimen = info->dimen;
2453 tmp_index = gfc_index_zero_node;
2454 for (n = dimen - 1; n > 0; n--)
2457 tmp = rse.loop->loopvar[n];
2458 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2459 tmp, rse.loop->from[n]);
2460 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2463 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
2464 gfc_array_index_type,
2465 rse.loop->to[n-1], rse.loop->from[n-1]);
2466 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
2467 gfc_array_index_type,
2468 tmp_str, gfc_index_one_node);
2470 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
2471 gfc_array_index_type, tmp, tmp_str);
2474 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
2475 gfc_array_index_type,
2476 tmp_index, rse.loop->from[0]);
2477 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2479 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
2480 gfc_array_index_type,
2481 rse.loop->loopvar[0], offset);
2483 /* Now use the offset for the reference. */
2484 tmp = build_fold_indirect_ref_loc (input_location,
2486 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2488 if (expr->ts.type == BT_CHARACTER)
2489 rse.string_length = expr->ts.u.cl->backend_decl;
2491 gfc_conv_expr (&lse, expr);
2493 gcc_assert (lse.ss == gfc_ss_terminator);
2495 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2496 gfc_add_expr_to_block (&body, tmp);
2498 /* Generate the copying loops. */
2499 gfc_trans_scalarizing_loops (&loop2, &body);
2501 /* Wrap the whole thing up by adding the second loop to the post-block
2502 and following it by the post-block of the first loop. In this way,
2503 if the temporary needs freeing, it is done after use! */
2504 if (intent != INTENT_IN)
2506 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2507 gfc_add_block_to_block (&parmse->post, &loop2.post);
2510 gfc_add_block_to_block (&parmse->post, &loop.post);
2512 gfc_cleanup_loop (&loop);
2513 gfc_cleanup_loop (&loop2);
2515 /* Pass the string length to the argument expression. */
2516 if (expr->ts.type == BT_CHARACTER)
2517 parmse->string_length = expr->ts.u.cl->backend_decl;
2519 /* Determine the offset for pointer formal arguments and set the
2523 size = gfc_index_one_node;
2524 offset = gfc_index_zero_node;
2525 for (n = 0; n < dimen; n++)
2527 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
2529 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2530 gfc_array_index_type, tmp,
2531 gfc_index_one_node);
2532 gfc_conv_descriptor_ubound_set (&parmse->pre,
2536 gfc_conv_descriptor_lbound_set (&parmse->pre,
2539 gfc_index_one_node);
2540 size = gfc_evaluate_now (size, &parmse->pre);
2541 offset = fold_build2_loc (input_location, MINUS_EXPR,
2542 gfc_array_index_type,
2544 offset = gfc_evaluate_now (offset, &parmse->pre);
2545 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2546 gfc_array_index_type,
2547 rse.loop->to[n], rse.loop->from[n]);
2548 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2549 gfc_array_index_type,
2550 tmp, gfc_index_one_node);
2551 size = fold_build2_loc (input_location, MULT_EXPR,
2552 gfc_array_index_type, size, tmp);
2555 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
2559 /* We want either the address for the data or the address of the descriptor,
2560 depending on the mode of passing array arguments. */
2562 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2564 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2570 /* Generate the code for argument list functions. */
2573 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2575 /* Pass by value for g77 %VAL(arg), pass the address
2576 indirectly for %LOC, else by reference. Thus %REF
2577 is a "do-nothing" and %LOC is the same as an F95
2579 if (strncmp (name, "%VAL", 4) == 0)
2580 gfc_conv_expr (se, expr);
2581 else if (strncmp (name, "%LOC", 4) == 0)
2583 gfc_conv_expr_reference (se, expr);
2584 se->expr = gfc_build_addr_expr (NULL, se->expr);
2586 else if (strncmp (name, "%REF", 4) == 0)
2587 gfc_conv_expr_reference (se, expr);
2589 gfc_error ("Unknown argument list function at %L", &expr->where);
2593 /* Takes a derived type expression and returns the address of a temporary
2594 class object of the 'declared' type. */
2596 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2597 gfc_typespec class_ts)
2601 gfc_symbol *declared = class_ts.u.derived;
2607 /* The derived type needs to be converted to a temporary
2609 tmp = gfc_typenode_for_spec (&class_ts);
2610 var = gfc_create_var (tmp, "class");
2613 cmp = gfc_find_component (declared, "_vptr", true, true);
2614 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2615 TREE_TYPE (cmp->backend_decl),
2616 var, cmp->backend_decl, NULL_TREE);
2618 /* Remember the vtab corresponds to the derived type
2619 not to the class declared type. */
2620 vtab = gfc_find_derived_vtab (e->ts.u.derived);
2622 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2623 gfc_add_modify (&parmse->pre, ctree,
2624 fold_convert (TREE_TYPE (ctree), tmp));
2626 /* Now set the data field. */
2627 cmp = gfc_find_component (declared, "_data", true, true);
2628 ctree = fold_build3_loc (input_location, COMPONENT_REF,
2629 TREE_TYPE (cmp->backend_decl),
2630 var, cmp->backend_decl, NULL_TREE);
2631 ss = gfc_walk_expr (e);
2632 if (ss == gfc_ss_terminator)
2635 gfc_conv_expr_reference (parmse, e);
2636 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2637 gfc_add_modify (&parmse->pre, ctree, tmp);
2642 gfc_conv_expr (parmse, e);
2643 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2646 /* Pass the address of the class object. */
2647 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2651 /* The following routine generates code for the intrinsic
2652 procedures from the ISO_C_BINDING module:
2654 * C_FUNLOC (function)
2655 * C_F_POINTER (subroutine)
2656 * C_F_PROCPOINTER (subroutine)
2657 * C_ASSOCIATED (function)
2658 One exception which is not handled here is C_F_POINTER with non-scalar
2659 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2662 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2663 gfc_actual_arglist * arg)
2668 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2670 if (arg->expr->rank == 0)
2671 gfc_conv_expr_reference (se, arg->expr);
2675 /* This is really the actual arg because no formal arglist is
2676 created for C_LOC. */
2677 fsym = arg->expr->symtree->n.sym;
2679 /* We should want it to do g77 calling convention. */
2681 && !(fsym->attr.pointer || fsym->attr.allocatable)
2682 && fsym->as->type != AS_ASSUMED_SHAPE;
2683 f = f || !sym->attr.always_explicit;
2685 argss = gfc_walk_expr (arg->expr);
2686 gfc_conv_array_parameter (se, arg->expr, argss, f,
2690 /* TODO -- the following two lines shouldn't be necessary, but if
2691 they're removed, a bug is exposed later in the code path.
2692 This workaround was thus introduced, but will have to be
2693 removed; please see PR 35150 for details about the issue. */
2694 se->expr = convert (pvoid_type_node, se->expr);
2695 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2699 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2701 arg->expr->ts.type = sym->ts.u.derived->ts.type;
2702 arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2703 arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2704 gfc_conv_expr_reference (se, arg->expr);
2708 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2709 && arg->next->expr->rank == 0)
2710 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2712 /* Convert c_f_pointer if fptr is a scalar
2713 and convert c_f_procpointer. */
2717 gfc_init_se (&cptrse, NULL);
2718 gfc_conv_expr (&cptrse, arg->expr);
2719 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2720 gfc_add_block_to_block (&se->post, &cptrse.post);
2722 gfc_init_se (&fptrse, NULL);
2723 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2724 || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2725 fptrse.want_pointer = 1;
2727 gfc_conv_expr (&fptrse, arg->next->expr);
2728 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2729 gfc_add_block_to_block (&se->post, &fptrse.post);
2731 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2732 && arg->next->expr->symtree->n.sym->attr.dummy)
2733 fptrse.expr = build_fold_indirect_ref_loc (input_location,
2736 se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
2737 TREE_TYPE (fptrse.expr),
2739 fold_convert (TREE_TYPE (fptrse.expr),
2744 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2749 /* Build the addr_expr for the first argument. The argument is
2750 already an *address* so we don't need to set want_pointer in
2752 gfc_init_se (&arg1se, NULL);
2753 gfc_conv_expr (&arg1se, arg->expr);
2754 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2755 gfc_add_block_to_block (&se->post, &arg1se.post);
2757 /* See if we were given two arguments. */
2758 if (arg->next == NULL)
2759 /* Only given one arg so generate a null and do a
2760 not-equal comparison against the first arg. */
2761 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2763 fold_convert (TREE_TYPE (arg1se.expr),
2764 null_pointer_node));
2770 /* Given two arguments so build the arg2se from second arg. */
2771 gfc_init_se (&arg2se, NULL);
2772 gfc_conv_expr (&arg2se, arg->next->expr);
2773 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2774 gfc_add_block_to_block (&se->post, &arg2se.post);
2776 /* Generate test to compare that the two args are equal. */
2777 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2778 arg1se.expr, arg2se.expr);
2779 /* Generate test to ensure that the first arg is not null. */
2780 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
2782 arg1se.expr, null_pointer_node);
2784 /* Finally, the generated test must check that both arg1 is not
2785 NULL and that it is equal to the second arg. */
2786 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2788 not_null_expr, eq_expr);
2794 /* Nothing was done. */
2798 /* Generate code for a procedure call. Note can return se->post != NULL.
2799 If se->direct_byref is set then se->expr contains the return parameter.
2800 Return nonzero, if the call has alternate specifiers.
2801 'expr' is only needed for procedure pointer components. */
2804 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2805 gfc_actual_arglist * args, gfc_expr * expr,
2806 VEC(tree,gc) *append_args)
2808 gfc_interface_mapping mapping;
2809 VEC(tree,gc) *arglist;
2810 VEC(tree,gc) *retargs;
2821 VEC(tree,gc) *stringargs;
2823 gfc_formal_arglist *formal;
2824 gfc_actual_arglist *arg;
2825 int has_alternate_specifier = 0;
2826 bool need_interface_mapping;
2833 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2834 gfc_component *comp = NULL;
2844 if (sym->from_intmod == INTMOD_ISO_C_BINDING
2845 && conv_isocbinding_procedure (se, sym, args))
2848 gfc_is_proc_ptr_comp (expr, &comp);
2852 if (!sym->attr.elemental)
2854 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2855 if (se->ss->useflags)
2857 gcc_assert ((!comp && gfc_return_by_reference (sym)
2858 && sym->result->attr.dimension)
2859 || (comp && comp->attr.dimension));
2860 gcc_assert (se->loop != NULL);
2862 /* Access the previously obtained result. */
2863 gfc_conv_tmp_array_ref (se);
2867 info = &se->ss->data.info;
2872 gfc_init_block (&post);
2873 gfc_init_interface_mapping (&mapping);
2876 formal = sym->formal;
2877 need_interface_mapping = sym->attr.dimension ||
2878 (sym->ts.type == BT_CHARACTER
2879 && sym->ts.u.cl->length
2880 && sym->ts.u.cl->length->expr_type
2885 formal = comp->formal;
2886 need_interface_mapping = comp->attr.dimension ||
2887 (comp->ts.type == BT_CHARACTER
2888 && comp->ts.u.cl->length
2889 && comp->ts.u.cl->length->expr_type
2893 /* Evaluate the arguments. */
2894 for (arg = args; arg != NULL;
2895 arg = arg->next, formal = formal ? formal->next : NULL)
2898 fsym = formal ? formal->sym : NULL;
2899 parm_kind = MISSING;
2903 if (se->ignore_optional)
2905 /* Some intrinsics have already been resolved to the correct
2909 else if (arg->label)
2911 has_alternate_specifier = 1;
2916 /* Pass a NULL pointer for an absent arg. */
2917 gfc_init_se (&parmse, NULL);
2918 parmse.expr = null_pointer_node;
2919 if (arg->missing_arg_type == BT_CHARACTER)
2920 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2923 else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
2925 /* Pass a NULL pointer to denote an absent arg. */
2926 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
2927 gfc_init_se (&parmse, NULL);
2928 parmse.expr = null_pointer_node;
2929 if (arg->missing_arg_type == BT_CHARACTER)
2930 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2932 else if (fsym && fsym->ts.type == BT_CLASS
2933 && e->ts.type == BT_DERIVED)
2935 /* The derived type needs to be converted to a temporary
2937 gfc_init_se (&parmse, se);
2938 gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2940 else if (se->ss && se->ss->useflags)
2942 /* An elemental function inside a scalarized loop. */
2943 gfc_init_se (&parmse, se);
2944 gfc_conv_expr_reference (&parmse, e);
2945 parm_kind = ELEMENTAL;
2949 /* A scalar or transformational function. */
2950 gfc_init_se (&parmse, NULL);
2951 argss = gfc_walk_expr (e);
2953 if (argss == gfc_ss_terminator)
2955 if (e->expr_type == EXPR_VARIABLE
2956 && e->symtree->n.sym->attr.cray_pointee
2957 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2959 /* The Cray pointer needs to be converted to a pointer to
2960 a type given by the expression. */
2961 gfc_conv_expr (&parmse, e);
2962 type = build_pointer_type (TREE_TYPE (parmse.expr));
2963 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2964 parmse.expr = convert (type, tmp);
2966 else if (fsym && fsym->attr.value)
2968 if (fsym->ts.type == BT_CHARACTER
2969 && fsym->ts.is_c_interop
2970 && fsym->ns->proc_name != NULL
2971 && fsym->ns->proc_name->attr.is_bind_c)
2974 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2975 if (parmse.expr == NULL)
2976 gfc_conv_expr (&parmse, e);
2979 gfc_conv_expr (&parmse, e);
2981 else if (arg->name && arg->name[0] == '%')
2982 /* Argument list functions %VAL, %LOC and %REF are signalled
2983 through arg->name. */
2984 conv_arglist_function (&parmse, arg->expr, arg->name);
2985 else if ((e->expr_type == EXPR_FUNCTION)
2986 && ((e->value.function.esym
2987 && e->value.function.esym->result->attr.pointer)
2988 || (!e->value.function.esym
2989 && e->symtree->n.sym->attr.pointer))
2990 && fsym && fsym->attr.target)
2992 gfc_conv_expr (&parmse, e);
2993 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2995 else if (e->expr_type == EXPR_FUNCTION
2996 && e->symtree->n.sym->result
2997 && e->symtree->n.sym->result != e->symtree->n.sym
2998 && e->symtree->n.sym->result->attr.proc_pointer)
3000 /* Functions returning procedure pointers. */
3001 gfc_conv_expr (&parmse, e);
3002 if (fsym && fsym->attr.proc_pointer)
3003 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3007 gfc_conv_expr_reference (&parmse, e);
3009 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3010 allocated on entry, it must be deallocated. */
3011 if (fsym && fsym->attr.allocatable
3012 && fsym->attr.intent == INTENT_OUT)
3016 gfc_init_block (&block);
3017 tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
3019 gfc_add_expr_to_block (&block, tmp);
3020 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3021 void_type_node, parmse.expr,
3023 gfc_add_expr_to_block (&block, tmp);
3025 if (fsym->attr.optional
3026 && e->expr_type == EXPR_VARIABLE
3027 && e->symtree->n.sym->attr.optional)
3029 tmp = fold_build3_loc (input_location, COND_EXPR,
3031 gfc_conv_expr_present (e->symtree->n.sym),
3032 gfc_finish_block (&block),
3033 build_empty_stmt (input_location));
3036 tmp = gfc_finish_block (&block);
3038 gfc_add_expr_to_block (&se->pre, tmp);
3041 if (fsym && e->expr_type != EXPR_NULL
3042 && ((fsym->attr.pointer
3043 && fsym->attr.flavor != FL_PROCEDURE)
3044 || (fsym->attr.proc_pointer
3045 && !(e->expr_type == EXPR_VARIABLE
3046 && e->symtree->n.sym->attr.dummy))
3047 || (fsym->attr.proc_pointer
3048 && e->expr_type == EXPR_VARIABLE
3049 && gfc_is_proc_ptr_comp (e, NULL))
3050 || fsym->attr.allocatable))
3052 /* Scalar pointer dummy args require an extra level of
3053 indirection. The null pointer already contains
3054 this level of indirection. */
3055 parm_kind = SCALAR_POINTER;
3056 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3062 /* If the procedure requires an explicit interface, the actual
3063 argument is passed according to the corresponding formal
3064 argument. If the corresponding formal argument is a POINTER,
3065 ALLOCATABLE or assumed shape, we do not use g77's calling
3066 convention, and pass the address of the array descriptor
3067 instead. Otherwise we use g77's calling convention. */
3070 && !(fsym->attr.pointer || fsym->attr.allocatable)
3071 && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3073 f = f || !comp->attr.always_explicit;
3075 f = f || !sym->attr.always_explicit;
3077 /* If the argument is a function call that may not create
3078 a temporary for the result, we have to check that we
3079 can do it, i.e. that there is no alias between this
3080 argument and another one. */
3081 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
3087 intent = fsym->attr.intent;
3089 intent = INTENT_UNKNOWN;
3091 if (gfc_check_fncall_dependency (e, intent, sym, args,
3093 parmse.force_tmp = 1;
3095 iarg = e->value.function.actual->expr;
3097 /* Temporary needed if aliasing due to host association. */
3098 if (sym->attr.contained
3100 && !sym->attr.implicit_pure
3101 && !sym->attr.use_assoc
3102 && iarg->expr_type == EXPR_VARIABLE
3103 && sym->ns == iarg->symtree->n.sym->ns)
3104 parmse.force_tmp = 1;
3106 /* Ditto within module. */
3107 if (sym->attr.use_assoc
3109 && !sym->attr.implicit_pure
3110 && iarg->expr_type == EXPR_VARIABLE
3111 && sym->module == iarg->symtree->n.sym->module)
3112 parmse.force_tmp = 1;
3115 if (e->expr_type == EXPR_VARIABLE
3116 && is_subref_array (e))
3117 /* The actual argument is a component reference to an
3118 array of derived types. In this case, the argument
3119 is converted to a temporary, which is passed and then
3120 written back after the procedure call. */
3121 gfc_conv_subref_array_arg (&parmse, e, f,
3122 fsym ? fsym->attr.intent : INTENT_INOUT,
3123 fsym && fsym->attr.pointer);
3125 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3128 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3129 allocated on entry, it must be deallocated. */
3130 if (fsym && fsym->attr.allocatable
3131 && fsym->attr.intent == INTENT_OUT)
3133 tmp = build_fold_indirect_ref_loc (input_location,
3135 tmp = gfc_trans_dealloc_allocated (tmp);
3136 if (fsym->attr.optional
3137 && e->expr_type == EXPR_VARIABLE
3138 && e->symtree->n.sym->attr.optional)
3139 tmp = fold_build3_loc (input_location, COND_EXPR,
3141 gfc_conv_expr_present (e->symtree->n.sym),
3142 tmp, build_empty_stmt (input_location));
3143 gfc_add_expr_to_block (&se->pre, tmp);
3148 /* The case with fsym->attr.optional is that of a user subroutine
3149 with an interface indicating an optional argument. When we call
3150 an intrinsic subroutine, however, fsym is NULL, but we might still
3151 have an optional argument, so we proceed to the substitution
3153 if (e && (fsym == NULL || fsym->attr.optional))
3155 /* If an optional argument is itself an optional dummy argument,
3156 check its presence and substitute a null if absent. This is
3157 only needed when passing an array to an elemental procedure
3158 as then array elements are accessed - or no NULL pointer is
3159 allowed and a "1" or "0" should be passed if not present.
3160 When passing a non-array-descriptor full array to a
3161 non-array-descriptor dummy, no check is needed. For
3162 array-descriptor actual to array-descriptor dummy, see
3163 PR 41911 for why a check has to be inserted.
3164 fsym == NULL is checked as intrinsics required the descriptor
3165 but do not always set fsym. */
3166 if (e->expr_type == EXPR_VARIABLE
3167 && e->symtree->n.sym->attr.optional
3168 && ((e->rank > 0 && sym->attr.elemental)
3169 || e->representation.length || e->ts.type == BT_CHARACTER
3173 && (fsym->as->type == AS_ASSUMED_SHAPE
3174 || fsym->as->type == AS_DEFERRED))))))
3175 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3176 e->representation.length);
3181 /* Obtain the character length of an assumed character length
3182 length procedure from the typespec. */
3183 if (fsym->ts.type == BT_CHARACTER
3184 && parmse.string_length == NULL_TREE
3185 && e->ts.type == BT_PROCEDURE
3186 && e->symtree->n.sym->ts.type == BT_CHARACTER
3187 && e->symtree->n.sym->ts.u.cl->length != NULL
3188 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3190 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3191 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3195 if (fsym && need_interface_mapping && e)
3196 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3198 gfc_add_block_to_block (&se->pre, &parmse.pre);
3199 gfc_add_block_to_block (&post, &parmse.post);
3201 /* Allocated allocatable components of derived types must be
3202 deallocated for non-variable scalars. Non-variable arrays are
3203 dealt with in trans-array.c(gfc_conv_array_parameter). */
3204 if (e && e->ts.type == BT_DERIVED
3205 && e->ts.u.derived->attr.alloc_comp
3206 && !(e->symtree && e->symtree->n.sym->attr.pointer)
3207 && (e->expr_type != EXPR_VARIABLE && !e->rank))
3210 tmp = build_fold_indirect_ref_loc (input_location,
3212 parm_rank = e->rank;
3220 case (SCALAR_POINTER):
3221 tmp = build_fold_indirect_ref_loc (input_location,
3226 if (e->expr_type == EXPR_OP
3227 && e->value.op.op == INTRINSIC_PARENTHESES
3228 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3231 local_tmp = gfc_evaluate_now (tmp, &se->pre);
3232 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3233 gfc_add_expr_to_block (&se->post, local_tmp);
3236 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3238 gfc_add_expr_to_block (&se->post, tmp);
3241 /* Add argument checking of passing an unallocated/NULL actual to
3242 a nonallocatable/nonpointer dummy. */
3244 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3246 symbol_attribute attr;
3250 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
3251 attr = gfc_expr_attr (e);
3253 goto end_pointer_check;
3257 /* If the actual argument is an optional pointer/allocatable and
3258 the formal argument takes an nonpointer optional value,
3259 it is invalid to pass a non-present argument on, even
3260 though there is no technical reason for this in gfortran.
3261 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3262 tree present, null_ptr, type;
3264 if (attr.allocatable
3265 && (fsym == NULL || !fsym->attr.allocatable))
3266 asprintf (&msg, "Allocatable actual argument '%s' is not "
3267 "allocated or not present", e->symtree->n.sym->name);
3268 else if (attr.pointer
3269 && (fsym == NULL || !fsym->attr.pointer))
3270 asprintf (&msg, "Pointer actual argument '%s' is not "
3271 "associated or not present",
3272 e->symtree->n.sym->name);
3273 else if (attr.proc_pointer
3274 && (fsym == NULL || !fsym->attr.proc_pointer))
3275 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3276 "associated or not present",
3277 e->symtree->n.sym->name);
3279 goto end_pointer_check;
3281 present = gfc_conv_expr_present (e->symtree->n.sym);
3282 type = TREE_TYPE (present);
3283 present = fold_build2_loc (input_location, EQ_EXPR,
3284 boolean_type_node, present,
3286 null_pointer_node));
3287 type = TREE_TYPE (parmse.expr);
3288 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
3289 boolean_type_node, parmse.expr,
3291 null_pointer_node));
3292 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3293 boolean_type_node, present, null_ptr);
3297 if (attr.allocatable
3298 && (fsym == NULL || !fsym->attr.allocatable))
3299 asprintf (&msg, "Allocatable actual argument '%s' is not "
3300 "allocated", e->symtree->n.sym->name);
3301 else if (attr.pointer
3302 && (fsym == NULL || !fsym->attr.pointer))
3303 asprintf (&msg, "Pointer actual argument '%s' is not "
3304 "associated", e->symtree->n.sym->name);
3305 else if (attr.proc_pointer
3306 && (fsym == NULL || !fsym->attr.proc_pointer))
3307 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3308 "associated", e->symtree->n.sym->name);
3310 goto end_pointer_check;
3313 cond = fold_build2_loc (input_location, EQ_EXPR,
3314 boolean_type_node, parmse.expr,
3315 fold_convert (TREE_TYPE (parmse.expr),
3316 null_pointer_node));
3319 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3326 /* Character strings are passed as two parameters, a length and a
3327 pointer - except for Bind(c) which only passes the pointer. */
3328 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3329 VEC_safe_push (tree, gc, stringargs, parmse.string_length);
3331 VEC_safe_push (tree, gc, arglist, parmse.expr);
3333 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3340 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3341 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3342 else if (ts.type == BT_CHARACTER)
3344 if (ts.u.cl->length == NULL)
3346 /* Assumed character length results are not allowed by 5.1.1.5 of the
3347 standard and are trapped in resolve.c; except in the case of SPREAD
3348 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3349 we take the character length of the first argument for the result.
3350 For dummies, we have to look through the formal argument list for
3351 this function and use the character length found there.*/
3352 if (!sym->attr.dummy)
3353 cl.backend_decl = VEC_index (tree, stringargs, 0);
3356 formal = sym->ns->proc_name->formal;
3357 for (; formal; formal = formal->next)
3358 if (strcmp (formal->sym->name, sym->name) == 0)
3359 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3366 /* Calculate the length of the returned string. */
3367 gfc_init_se (&parmse, NULL);
3368 if (need_interface_mapping)
3369 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3371 gfc_conv_expr (&parmse, ts.u.cl->length);
3372 gfc_add_block_to_block (&se->pre, &parmse.pre);
3373 gfc_add_block_to_block (&se->post, &parmse.post);
3375 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3376 tmp = fold_build2_loc (input_location, MAX_EXPR,
3377 gfc_charlen_type_node, tmp,
3378 build_int_cst (gfc_charlen_type_node, 0));
3379 cl.backend_decl = tmp;
3382 /* Set up a charlen structure for it. */
3387 len = cl.backend_decl;
3390 byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3391 || (!comp && gfc_return_by_reference (sym));
3394 if (se->direct_byref)
3396 /* Sometimes, too much indirection can be applied; e.g. for
3397 function_result = array_valued_recursive_function. */
3398 if (TREE_TYPE (TREE_TYPE (se->expr))
3399 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3400 && GFC_DESCRIPTOR_TYPE_P
3401 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3402 se->expr = build_fold_indirect_ref_loc (input_location,
3405 /* If the lhs of an assignment x = f(..) is allocatable and
3406 f2003 is allowed, we must do the automatic reallocation.
3407 TODO - deal with intrinsics, without using a temporary. */
3408 if (gfc_option.flag_realloc_lhs
3409 && se->ss && se->ss->loop_chain
3410 && se->ss->loop_chain->is_alloc_lhs
3411 && !expr->value.function.isym
3412 && sym->result->as != NULL)
3414 /* Evaluate the bounds of the result, if known. */
3415 gfc_set_loop_bounds_from_array_spec (&mapping, se,
3418 /* Perform the automatic reallocation. */
3419 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
3421 gfc_add_expr_to_block (&se->pre, tmp);
3423 /* Pass the temporary as the first argument. */
3424 result = info->descriptor;
3427 result = build_fold_indirect_ref_loc (input_location,
3429 VEC_safe_push (tree, gc, retargs, se->expr);
3431 else if (comp && comp->attr.dimension)
3433 gcc_assert (se->loop && info);
3435 /* Set the type of the array. */
3436 tmp = gfc_typenode_for_spec (&comp->ts);
3437 info->dimen = se->loop->dimen;
3439 /* Evaluate the bounds of the result, if known. */
3440 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3442 /* If the lhs of an assignment x = f(..) is allocatable and
3443 f2003 is allowed, we must not generate the function call
3444 here but should just send back the results of the mapping.
3445 This is signalled by the function ss being flagged. */
3446 if (gfc_option.flag_realloc_lhs
3447 && se->ss && se->ss->is_alloc_lhs)
3449 gfc_free_interface_mapping (&mapping);
3450 return has_alternate_specifier;
3453 /* Create a temporary to store the result. In case the function
3454 returns a pointer, the temporary will be a shallow copy and
3455 mustn't be deallocated. */
3456 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3457 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3458 NULL_TREE, false, !comp->attr.pointer,
3459 callee_alloc, &se->ss->expr->where);
3461 /* Pass the temporary as the first argument. */
3462 result = info->descriptor;
3463 tmp = gfc_build_addr_expr (NULL_TREE, result);
3464 VEC_safe_push (tree, gc, retargs, tmp);
3466 else if (!comp && sym->result->attr.dimension)
3468 gcc_assert (se->loop && info);
3470 /* Set the type of the array. */
3471 tmp = gfc_typenode_for_spec (&ts);
3472 info->dimen = se->loop->dimen;
3474 /* Evaluate the bounds of the result, if known. */
3475 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3477 /* If the lhs of an assignment x = f(..) is allocatable and
3478 f2003 is allowed, we must not generate the function call
3479 here but should just send back the results of the mapping.
3480 This is signalled by the function ss being flagged. */
3481 if (gfc_option.flag_realloc_lhs
3482 && se->ss && se->ss->is_alloc_lhs)
3484 gfc_free_interface_mapping (&mapping);
3485 return has_alternate_specifier;
3488 /* Create a temporary to store the result. In case the function
3489 returns a pointer, the temporary will be a shallow copy and
3490 mustn't be deallocated. */
3491 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3492 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3493 NULL_TREE, false, !sym->attr.pointer,
3494 callee_alloc, &se->ss->expr->where);
3496 /* Pass the temporary as the first argument. */
3497 result = info->descriptor;
3498 tmp = gfc_build_addr_expr (NULL_TREE, result);
3499 VEC_safe_push (tree, gc, retargs, tmp);
3501 else if (ts.type == BT_CHARACTER)
3503 /* Pass the string length. */
3504 type = gfc_get_character_type (ts.kind, ts.u.cl);
3505 type = build_pointer_type (type);
3507 /* Return an address to a char[0:len-1]* temporary for
3508 character pointers. */
3509 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3510 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3512 var = gfc_create_var (type, "pstr");
3514 if ((!comp && sym->attr.allocatable)
3515 || (comp && comp->attr.allocatable))
3516 gfc_add_modify (&se->pre, var,
3517 fold_convert (TREE_TYPE (var),
3518 null_pointer_node));
3520 /* Provide an address expression for the function arguments. */
3521 var = gfc_build_addr_expr (NULL_TREE, var);
3524 var = gfc_conv_string_tmp (se, type, len);
3526 VEC_safe_push (tree, gc, retargs, var);
3530 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3532 type = gfc_get_complex_type (ts.kind);
3533 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3534 VEC_safe_push (tree, gc, retargs, var);
3537 /* Add the string length to the argument list. */
3538 if (ts.type == BT_CHARACTER)
3539 VEC_safe_push (tree, gc, retargs, len);
3541 gfc_free_interface_mapping (&mapping);
3543 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3544 arglen = (VEC_length (tree, arglist)
3545 + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
3546 VEC_reserve_exact (tree, gc, retargs, arglen);
3548 /* Add the return arguments. */
3549 VEC_splice (tree, retargs, arglist);
3551 /* Add the hidden string length parameters to the arguments. */
3552 VEC_splice (tree, retargs, stringargs);
3554 /* We may want to append extra arguments here. This is used e.g. for
3555 calls to libgfortran_matmul_??, which need extra information. */
3556 if (!VEC_empty (tree, append_args))
3557 VEC_splice (tree, retargs, append_args);
3560 /* Generate the actual call. */
3561 conv_function_val (se, sym, expr);
3563 /* If there are alternate return labels, function type should be
3564 integer. Can't modify the type in place though, since it can be shared
3565 with other functions. For dummy arguments, the typing is done to
3566 to this result, even if it has to be repeated for each call. */
3567 if (has_alternate_specifier
3568 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3570 if (!sym->attr.dummy)
3572 TREE_TYPE (sym->backend_decl)
3573 = build_function_type (integer_type_node,
3574 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3575 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3578 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3581 fntype = TREE_TYPE (TREE_TYPE (se->expr));
3582 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
3584 /* If we have a pointer function, but we don't want a pointer, e.g.
3587 where f is pointer valued, we have to dereference the result. */
3588 if (!se->want_pointer && !byref
3589 && (sym->attr.pointer || sym->attr.allocatable)
3590 && !gfc_is_proc_ptr_comp (expr, NULL))
3591 se->expr = build_fold_indirect_ref_loc (input_location,
3594 /* f2c calling conventions require a scalar default real function to
3595 return a double precision result. Convert this back to default
3596 real. We only care about the cases that can happen in Fortran 77.
3598 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3599 && sym->ts.kind == gfc_default_real_kind
3600 && !sym->attr.always_explicit)
3601 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3603 /* A pure function may still have side-effects - it may modify its
3605 TREE_SIDE_EFFECTS (se->expr) = 1;
3607 if (!sym->attr.pure)
3608 TREE_SIDE_EFFECTS (se->expr) = 1;
3613 /* Add the function call to the pre chain. There is no expression. */
3614 gfc_add_expr_to_block (&se->pre, se->expr);
3615 se->expr = NULL_TREE;
3617 if (!se->direct_byref)
3619 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
3621 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3623 /* Check the data pointer hasn't been modified. This would
3624 happen in a function returning a pointer. */
3625 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3626 tmp = fold_build2_loc (input_location, NE_EXPR,
3629 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3632 se->expr = info->descriptor;
3633 /* Bundle in the string length. */
3634 se->string_length = len;
3636 else if (ts.type == BT_CHARACTER)
3638 /* Dereference for character pointer results. */
3639 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3640 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3641 se->expr = build_fold_indirect_ref_loc (input_location, var);
3645 se->string_length = len;
3649 gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3650 se->expr = build_fold_indirect_ref_loc (input_location, var);
3655 /* Follow the function call with the argument post block. */
3658 gfc_add_block_to_block (&se->pre, &post);
3660 /* Transformational functions of derived types with allocatable
3661 components must have the result allocatable components copied. */
3662 arg = expr->value.function.actual;
3663 if (result && arg && expr->rank
3664 && expr->value.function.isym
3665 && expr->value.function.isym->transformational
3666 && arg->expr->ts.type == BT_DERIVED
3667 && arg->expr->ts.u.derived->attr.alloc_comp)
3670 /* Copy the allocatable components. We have to use a
3671 temporary here to prevent source allocatable components
3672 from being corrupted. */
3673 tmp2 = gfc_evaluate_now (result, &se->pre);
3674 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
3675 result, tmp2, expr->rank);
3676 gfc_add_expr_to_block (&se->pre, tmp);
3677 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
3679 gfc_add_expr_to_block (&se->pre, tmp);
3681 /* Finally free the temporary's data field. */
3682 tmp = gfc_conv_descriptor_data_get (tmp2);
3683 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
3684 gfc_add_expr_to_block (&se->pre, tmp);
3688 gfc_add_block_to_block (&se->post, &post);
3690 return has_alternate_specifier;
3694 /* Fill a character string with spaces. */
3697 fill_with_spaces (tree start, tree type, tree size)
3699 stmtblock_t block, loop;
3700 tree i, el, exit_label, cond, tmp;
3702 /* For a simple char type, we can call memset(). */
3703 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3704 return build_call_expr_loc (input_location,
3705 built_in_decls[BUILT_IN_MEMSET], 3, start,
3706 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3707 lang_hooks.to_target_charset (' ')),
3710 /* Otherwise, we use a loop:
3711 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3715 /* Initialize variables. */
3716 gfc_init_block (&block);
3717 i = gfc_create_var (sizetype, "i");
3718 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3719 el = gfc_create_var (build_pointer_type (type), "el");
3720 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3721 exit_label = gfc_build_label_decl (NULL_TREE);
3722 TREE_USED (exit_label) = 1;
3726 gfc_init_block (&loop);
3728 /* Exit condition. */
3729 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
3730 build_zero_cst (sizetype));
3731 tmp = build1_v (GOTO_EXPR, exit_label);
3732 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3733 build_empty_stmt (input_location));
3734 gfc_add_expr_to_block (&loop, tmp);
3737 gfc_add_modify (&loop,
3738 fold_build1_loc (input_location, INDIRECT_REF, type, el),
3739 build_int_cst (type, lang_hooks.to_target_charset (' ')));
3741 /* Increment loop variables. */
3742 gfc_add_modify (&loop, i,
3743 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
3744 TYPE_SIZE_UNIT (type)));
3745 gfc_add_modify (&loop, el,
3746 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
3747 TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3749 /* Making the loop... actually loop! */
3750 tmp = gfc_finish_block (&loop);
3751 tmp = build1_v (LOOP_EXPR, tmp);
3752 gfc_add_expr_to_block (&block, tmp);
3754 /* The exit label. */
3755 tmp = build1_v (LABEL_EXPR, exit_label);
3756 gfc_add_expr_to_block (&block, tmp);
3759 return gfc_finish_block (&block);
3763 /* Generate code to copy a string. */
3766 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3767 int dkind, tree slength, tree src, int skind)
3769 tree tmp, dlen, slen;
3778 stmtblock_t tempblock;
3780 gcc_assert (dkind == skind);
3782 if (slength != NULL_TREE)
3784 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3785 ssc = gfc_string_to_single_character (slen, src, skind);
3789 slen = build_int_cst (size_type_node, 1);
3793 if (dlength != NULL_TREE)
3795 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3796 dsc = gfc_string_to_single_character (dlen, dest, dkind);
3800 dlen = build_int_cst (size_type_node, 1);
3804 /* Assign directly if the types are compatible. */
3805 if (dsc != NULL_TREE && ssc != NULL_TREE
3806 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3808 gfc_add_modify (block, dsc, ssc);
3812 /* Do nothing if the destination length is zero. */
3813 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
3814 build_int_cst (size_type_node, 0));
3816 /* The following code was previously in _gfortran_copy_string:
3818 // The two strings may overlap so we use memmove.
3820 copy_string (GFC_INTEGER_4 destlen, char * dest,
3821 GFC_INTEGER_4 srclen, const char * src)
3823 if (srclen >= destlen)
3825 // This will truncate if too long.
3826 memmove (dest, src, destlen);
3830 memmove (dest, src, srclen);
3832 memset (&dest[srclen], ' ', destlen - srclen);
3836 We're now doing it here for better optimization, but the logic
3839 /* For non-default character kinds, we have to multiply the string
3840 length by the base type size. */
3841 chartype = gfc_get_char_type (dkind);
3842 slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3843 fold_convert (size_type_node, slen),
3844 fold_convert (size_type_node,
3845 TYPE_SIZE_UNIT (chartype)));
3846 dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3847 fold_convert (size_type_node, dlen),
3848 fold_convert (size_type_node,
3849 TYPE_SIZE_UNIT (chartype)));
3851 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
3852 dest = fold_convert (pvoid_type_node, dest);
3854 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3856 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
3857 src = fold_convert (pvoid_type_node, src);
3859 src = gfc_build_addr_expr (pvoid_type_node, src);
3861 /* Truncate string if source is too long. */
3862 cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
3864 tmp2 = build_call_expr_loc (input_location,
3865 built_in_decls[BUILT_IN_MEMMOVE],
3866 3, dest, src, dlen);
3868 /* Else copy and pad with spaces. */
3869 tmp3 = build_call_expr_loc (input_location,
3870 built_in_decls[BUILT_IN_MEMMOVE],
3871 3, dest, src, slen);
3873 tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
3874 dest, fold_convert (sizetype, slen));
3875 tmp4 = fill_with_spaces (tmp4, chartype,
3876 fold_build2_loc (input_location, MINUS_EXPR,
3877 TREE_TYPE(dlen), dlen, slen));
3879 gfc_init_block (&tempblock);
3880 gfc_add_expr_to_block (&tempblock, tmp3);
3881 gfc_add_expr_to_block (&tempblock, tmp4);
3882 tmp3 = gfc_finish_block (&tempblock);
3884 /* The whole copy_string function is there. */
3885 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
3887 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
3888 build_empty_stmt (input_location));
3889 gfc_add_expr_to_block (block, tmp);
3893 /* Translate a statement function.
3894 The value of a statement function reference is obtained by evaluating the
3895 expression using the values of the actual arguments for the values of the
3896 corresponding dummy arguments. */
3899 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3903 gfc_formal_arglist *fargs;
3904 gfc_actual_arglist *args;
3907 gfc_saved_var *saved_vars;
3913 sym = expr->symtree->n.sym;
3914 args = expr->value.function.actual;
3915 gfc_init_se (&lse, NULL);
3916 gfc_init_se (&rse, NULL);
3919 for (fargs = sym->formal; fargs; fargs = fargs->next)
3921 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3922 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3924 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3926 /* Each dummy shall be specified, explicitly or implicitly, to be
3928 gcc_assert (fargs->sym->attr.dimension == 0);
3931 if (fsym->ts.type == BT_CHARACTER)
3933 /* Copy string arguments. */
3936 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3937 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3939 /* Create a temporary to hold the value. */
3940 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
3941 fsym->ts.u.cl->backend_decl
3942 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
3944 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
3945 temp_vars[n] = gfc_create_var (type, fsym->name);
3947 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3949 gfc_conv_expr (&rse, args->expr);
3950 gfc_conv_string_parameter (&rse);
3951 gfc_add_block_to_block (&se->pre, &lse.pre);
3952 gfc_add_block_to_block (&se->pre, &rse.pre);
3954 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
3955 rse.string_length, rse.expr, fsym->ts.kind);
3956 gfc_add_block_to_block (&se->pre, &lse.post);
3957 gfc_add_block_to_block (&se->pre, &rse.post);
3961 /* For everything else, just evaluate the expression. */
3963 /* Create a temporary to hold the value. */
3964 type = gfc_typenode_for_spec (&fsym->ts);
3965 temp_vars[n] = gfc_create_var (type, fsym->name);
3967 gfc_conv_expr (&lse, args->expr);
3969 gfc_add_block_to_block (&se->pre, &lse.pre);
3970 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3971 gfc_add_block_to_block (&se->pre, &lse.post);
3977 /* Use the temporary variables in place of the real ones. */
3978 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3979 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3981 gfc_conv_expr (se, sym->value);
3983 if (sym->ts.type == BT_CHARACTER)
3985 gfc_conv_const_charlen (sym->ts.u.cl);
3987 /* Force the expression to the correct length. */
3988 if (!INTEGER_CST_P (se->string_length)
3989 || tree_int_cst_lt (se->string_length,
3990 sym->ts.u.cl->backend_decl))
3992 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3993 tmp = gfc_create_var (type, sym->name);
3994 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3995 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3996 sym->ts.kind, se->string_length, se->expr,
4000 se->string_length = sym->ts.u.cl->backend_decl;
4003 /* Restore the original variables. */
4004 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4005 gfc_restore_sym (fargs->sym, &saved_vars[n]);
4006 gfc_free (saved_vars);
4010 /* Translate a function expression. */
4013 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
4017 if (expr->value.function.isym)
4019 gfc_conv_intrinsic_function (se, expr);
4023 /* We distinguish statement functions from general functions to improve
4024 runtime performance. */
4025 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
4027 gfc_conv_statement_function (se, expr);
4031 /* expr.value.function.esym is the resolved (specific) function symbol for
4032 most functions. However this isn't set for dummy procedures. */
4033 sym = expr->value.function.esym;
4035 sym = expr->symtree->n.sym;
4037 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
4041 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4044 is_zero_initializer_p (gfc_expr * expr)
4046 if (expr->expr_type != EXPR_CONSTANT)
4049 /* We ignore constants with prescribed memory representations for now. */
4050 if (expr->representation.string)
4053 switch (expr->ts.type)
4056 return mpz_cmp_si (expr->value.integer, 0) == 0;
4059 return mpfr_zero_p (expr->value.real)
4060 && MPFR_SIGN (expr->value.real) >= 0;
4063 return expr->value.logical == 0;
4066 return mpfr_zero_p (mpc_realref (expr->value.complex))
4067 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4068 && mpfr_zero_p (mpc_imagref (expr->value.complex))
4069 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4079 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
4081 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
4082 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
4084 gfc_conv_tmp_array_ref (se);
4088 /* Build a static initializer. EXPR is the expression for the initial value.
4089 The other parameters describe the variable of the component being
4090 initialized. EXPR may be null. */
4093 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
4094 bool array, bool pointer, bool procptr)
4098 if (!(expr || pointer || procptr))
4101 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4102 (these are the only two iso_c_binding derived types that can be
4103 used as initialization expressions). If so, we need to modify
4104 the 'expr' to be that for a (void *). */
4105 if (expr != NULL && expr->ts.type == BT_DERIVED
4106 && expr->ts.is_iso_c && expr->ts.u.derived)
4108 gfc_symbol *derived = expr->ts.u.derived;
4110 /* The derived symbol has already been converted to a (void *). Use
4112 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4113 expr->ts.f90_type = derived->ts.f90_type;
4115 gfc_init_se (&se, NULL);
4116 gfc_conv_constant (&se, expr);
4117 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4121 if (array && !procptr)
4124 /* Arrays need special handling. */
4126 ctor = gfc_build_null_descriptor (type);
4127 /* Special case assigning an array to zero. */
4128 else if (is_zero_initializer_p (expr))
4129 ctor = build_constructor (type, NULL);
4131 ctor = gfc_conv_array_initializer (type, expr);
4132 TREE_STATIC (ctor) = 1;
4135 else if (pointer || procptr)
4137 if (!expr || expr->expr_type == EXPR_NULL)
4138 return fold_convert (type, null_pointer_node);
4141 gfc_init_se (&se, NULL);
4142 se.want_pointer = 1;
4143 gfc_conv_expr (&se, expr);
4144 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4154 gfc_init_se (&se, NULL);
4155 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
4156 gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
4158 gfc_conv_structure (&se, expr, 1);
4159 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
4160 TREE_STATIC (se.expr) = 1;
4165 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
4166 TREE_STATIC (ctor) = 1;
4171 gfc_init_se (&se, NULL);
4172 gfc_conv_constant (&se, expr);
4173 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4180 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4192 gfc_start_block (&block);
4194 /* Initialize the scalarizer. */
4195 gfc_init_loopinfo (&loop);
4197 gfc_init_se (&lse, NULL);
4198 gfc_init_se (&rse, NULL);
4201 rss = gfc_walk_expr (expr);
4202 if (rss == gfc_ss_terminator)
4204 /* The rhs is scalar. Add a ss for the expression. */
4205 rss = gfc_get_ss ();
4206 rss->next = gfc_ss_terminator;
4207 rss->type = GFC_SS_SCALAR;
4211 /* Create a SS for the destination. */
4212 lss = gfc_get_ss ();
4213 lss->type = GFC_SS_COMPONENT;
4215 lss->shape = gfc_get_shape (cm->as->rank);
4216 lss->next = gfc_ss_terminator;
4217 lss->data.info.dimen = cm->as->rank;
4218 lss->data.info.descriptor = dest;
4219 lss->data.info.data = gfc_conv_array_data (dest);
4220 lss->data.info.offset = gfc_conv_array_offset (dest);
4221 for (n = 0; n < cm->as->rank; n++)
4223 lss->data.info.dim[n] = n;
4224 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
4225 lss->data.info.stride[n] = gfc_index_one_node;
4227 mpz_init (lss->shape[n]);
4228 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
4229 cm->as->lower[n]->value.integer);
4230 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
4233 /* Associate the SS with the loop. */
4234 gfc_add_ss_to_loop (&loop, lss);
4235 gfc_add_ss_to_loop (&loop, rss);
4237 /* Calculate the bounds of the scalarization. */
4238 gfc_conv_ss_startstride (&loop);
4240 /* Setup the scalarizing loops. */
4241 gfc_conv_loop_setup (&loop, &expr->where);
4243 /* Setup the gfc_se structures. */
4244 gfc_copy_loopinfo_to_se (&lse, &loop);
4245 gfc_copy_loopinfo_to_se (&rse, &loop);
4248 gfc_mark_ss_chain_used (rss, 1);
4250 gfc_mark_ss_chain_used (lss, 1);
4252 /* Start the scalarized loop body. */
4253 gfc_start_scalarized_body (&loop, &body);
4255 gfc_conv_tmp_array_ref (&lse);
4256 if (cm->ts.type == BT_CHARACTER)
4257 lse.string_length = cm->ts.u.cl->backend_decl;
4259 gfc_conv_expr (&rse, expr);
4261 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
4262 gfc_add_expr_to_block (&body, tmp);
4264 gcc_assert (rse.ss == gfc_ss_terminator);
4266 /* Generate the copying loops. */
4267 gfc_trans_scalarizing_loops (&loop, &body);
4269 /* Wrap the whole thing up. */
4270 gfc_add_block_to_block (&block, &loop.pre);
4271 gfc_add_block_to_block (&block, &loop.post);
4273 for (n = 0; n < cm->as->rank; n++)
4274 mpz_clear (lss->shape[n]);
4275 gfc_free (lss->shape);
4277 gfc_cleanup_loop (&loop);
4279 return gfc_finish_block (&block);
4284 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
4295 gfc_expr *arg = NULL;
4297 gfc_start_block (&block);
4298 gfc_init_se (&se, NULL);
4300 /* Get the descriptor for the expressions. */
4301 rss = gfc_walk_expr (expr);
4302 se.want_pointer = 0;
4303 gfc_conv_expr_descriptor (&se, expr, rss);
4304 gfc_add_block_to_block (&block, &se.pre);
4305 gfc_add_modify (&block, dest, se.expr);
4307 /* Deal with arrays of derived types with allocatable components. */
4308 if (cm->ts.type == BT_DERIVED
4309 && cm->ts.u.derived->attr.alloc_comp)
4310 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
4314 tmp = gfc_duplicate_allocatable (dest, se.expr,
4315 TREE_TYPE(cm->backend_decl),
4318 gfc_add_expr_to_block (&block, tmp);
4319 gfc_add_block_to_block (&block, &se.post);
4321 if (expr->expr_type != EXPR_VARIABLE)
4322 gfc_conv_descriptor_data_set (&block, se.expr,
4325 /* We need to know if the argument of a conversion function is a
4326 variable, so that the correct lower bound can be used. */
4327 if (expr->expr_type == EXPR_FUNCTION
4328 && expr->value.function.isym
4329 && expr->value.function.isym->conversion
4330 && expr->value.function.actual->expr
4331 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
4332 arg = expr->value.function.actual->expr;
4334 /* Obtain the array spec of full array references. */
4336 as = gfc_get_full_arrayspec_from_expr (arg);
4338 as = gfc_get_full_arrayspec_from_expr (expr);
4340 /* Shift the lbound and ubound of temporaries to being unity,
4341 rather than zero, based. Always calculate the offset. */
4342 offset = gfc_conv_descriptor_offset_get (dest);
4343 gfc_add_modify (&block, offset, gfc_index_zero_node);
4344 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4346 for (n = 0; n < expr->rank; n++)
4351 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4352 TODO It looks as if gfc_conv_expr_descriptor should return
4353 the correct bounds and that the following should not be
4354 necessary. This would simplify gfc_conv_intrinsic_bound
4356 if (as && as->lower[n])
4359 gfc_init_se (&lbse, NULL);
4360 gfc_conv_expr (&lbse, as->lower[n]);
4361 gfc_add_block_to_block (&block, &lbse.pre);
4362 lbound = gfc_evaluate_now (lbse.expr, &block);
4366 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
4367 lbound = gfc_conv_descriptor_lbound_get (tmp,
4371 lbound = gfc_conv_descriptor_lbound_get (dest,
4374 lbound = gfc_index_one_node;
4376 lbound = fold_convert (gfc_array_index_type, lbound);
4378 /* Shift the bounds and set the offset accordingly. */
4379 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4380 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4381 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4382 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4384 gfc_conv_descriptor_ubound_set (&block, dest,
4385 gfc_rank_cst[n], tmp);
4386 gfc_conv_descriptor_lbound_set (&block, dest,
4387 gfc_rank_cst[n], lbound);
4389 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4390 gfc_conv_descriptor_lbound_get (dest,
4392 gfc_conv_descriptor_stride_get (dest,
4394 gfc_add_modify (&block, tmp2, tmp);
4395 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4397 gfc_conv_descriptor_offset_set (&block, dest, tmp);
4402 /* If a conversion expression has a null data pointer
4403 argument, nullify the allocatable component. */
4407 if (arg->symtree->n.sym->attr.allocatable
4408 || arg->symtree->n.sym->attr.pointer)
4410 non_null_expr = gfc_finish_block (&block);
4411 gfc_start_block (&block);
4412 gfc_conv_descriptor_data_set (&block, dest,
4414 null_expr = gfc_finish_block (&block);
4415 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4416 tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4417 fold_convert (TREE_TYPE (tmp), null_pointer_node));
4418 return build3_v (COND_EXPR, tmp,
4419 null_expr, non_null_expr);
4423 return gfc_finish_block (&block);
4427 /* Assign a single component of a derived type constructor. */
4430 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4438 gfc_start_block (&block);
4440 if (cm->attr.pointer)
4442 gfc_init_se (&se, NULL);
4443 /* Pointer component. */
4444 if (cm->attr.dimension)
4446 /* Array pointer. */
4447 if (expr->expr_type == EXPR_NULL)
4448 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4451 rss = gfc_walk_expr (expr);
4452 se.direct_byref = 1;
4454 gfc_conv_expr_descriptor (&se, expr, rss);
4455 gfc_add_block_to_block (&block, &se.pre);
4456 gfc_add_block_to_block (&block, &se.post);
4461 /* Scalar pointers. */
4462 se.want_pointer = 1;
4463 gfc_conv_expr (&se, expr);
4464 gfc_add_block_to_block (&block, &se.pre);
4465 gfc_add_modify (&block, dest,
4466 fold_convert (TREE_TYPE (dest), se.expr));
4467 gfc_add_block_to_block (&block, &se.post);
4470 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4472 /* NULL initialization for CLASS components. */
4473 tmp = gfc_trans_structure_assign (dest,
4474 gfc_class_null_initializer (&cm->ts));
4475 gfc_add_expr_to_block (&block, tmp);
4477 else if (cm->attr.dimension && !cm->attr.proc_pointer)
4479 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4480 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4481 else if (cm->attr.allocatable)
4483 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4484 gfc_add_expr_to_block (&block, tmp);
4488 tmp = gfc_trans_subarray_assign (dest, cm, expr);
4489 gfc_add_expr_to_block (&block, tmp);
4492 else if (expr->ts.type == BT_DERIVED)
4494 if (expr->expr_type != EXPR_STRUCTURE)
4496 gfc_init_se (&se, NULL);
4497 gfc_conv_expr (&se, expr);
4498 gfc_add_block_to_block (&block, &se.pre);
4499 gfc_add_modify (&block, dest,
4500 fold_convert (TREE_TYPE (dest), se.expr));
4501 gfc_add_block_to_block (&block, &se.post);
4505 /* Nested constructors. */
4506 tmp = gfc_trans_structure_assign (dest, expr);
4507 gfc_add_expr_to_block (&block, tmp);
4512 /* Scalar component. */
4513 gfc_init_se (&se, NULL);
4514 gfc_init_se (&lse, NULL);
4516 gfc_conv_expr (&se, expr);
4517 if (cm->ts.type == BT_CHARACTER)
4518 lse.string_length = cm->ts.u.cl->backend_decl;
4520 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
4521 gfc_add_expr_to_block (&block, tmp);
4523 return gfc_finish_block (&block);
4526 /* Assign a derived type constructor to a variable. */
4529 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4537 gfc_start_block (&block);
4538 cm = expr->ts.u.derived->components;
4540 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
4541 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
4542 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
4546 gcc_assert (cm->backend_decl == NULL);
4547 gfc_init_se (&se, NULL);
4548 gfc_init_se (&lse, NULL);
4549 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
4551 gfc_add_modify (&block, lse.expr,
4552 fold_convert (TREE_TYPE (lse.expr), se.expr));
4554 return gfc_finish_block (&block);
4557 for (c = gfc_constructor_first (expr->value.constructor);
4558 c; c = gfc_constructor_next (c), cm = cm->next)
4560 /* Skip absent members in default initializers. */
4564 field = cm->backend_decl;
4565 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
4566 dest, field, NULL_TREE);
4567 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4568 gfc_add_expr_to_block (&block, tmp);
4570 return gfc_finish_block (&block);
4573 /* Build an expression for a constructor. If init is nonzero then
4574 this is part of a static variable initializer. */
4577 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4584 VEC(constructor_elt,gc) *v = NULL;
4586 gcc_assert (se->ss == NULL);
4587 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4588 type = gfc_typenode_for_spec (&expr->ts);
4592 /* Create a temporary variable and fill it in. */
4593 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4594 tmp = gfc_trans_structure_assign (se->expr, expr);
4595 gfc_add_expr_to_block (&se->pre, tmp);
4599 cm = expr->ts.u.derived->components;
4601 for (c = gfc_constructor_first (expr->value.constructor);
4602 c; c = gfc_constructor_next (c), cm = cm->next)
4604 /* Skip absent members in default initializers and allocatable
4605 components. Although the latter have a default initializer
4606 of EXPR_NULL,... by default, the static nullify is not needed
4607 since this is done every time we come into scope. */
4608 if (!c->expr || cm->attr.allocatable)
4611 if (strcmp (cm->name, "_size") == 0)
4613 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4614 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4616 else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4617 && strcmp (cm->name, "_extends") == 0)
4621 vtabs = cm->initializer->symtree->n.sym;
4622 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4623 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
4627 val = gfc_conv_initializer (c->expr, &cm->ts,
4628 TREE_TYPE (cm->backend_decl),
4629 cm->attr.dimension, cm->attr.pointer,
4630 cm->attr.proc_pointer);
4632 /* Append it to the constructor list. */
4633 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4636 se->expr = build_constructor (type, v);
4638 TREE_CONSTANT (se->expr) = 1;
4642 /* Translate a substring expression. */
4645 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4651 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4653 se->expr = gfc_build_wide_string_const (expr->ts.kind,
4654 expr->value.character.length,
4655 expr->value.character.string);
4657 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4658 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4661 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4665 /* Entry point for expression translation. Evaluates a scalar quantity.
4666 EXPR is the expression to be translated, and SE is the state structure if
4667 called from within the scalarized. */
4670 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4672 if (se->ss && se->ss->expr == expr
4673 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4675 /* Substitute a scalar expression evaluated outside the scalarization
4677 se->expr = se->ss->data.scalar.expr;
4678 if (se->ss->type == GFC_SS_REFERENCE)
4679 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
4680 se->string_length = se->ss->string_length;
4681 gfc_advance_se_ss_chain (se);
4685 /* We need to convert the expressions for the iso_c_binding derived types.
4686 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4687 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4688 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4689 updated to be an integer with a kind equal to the size of a (void *). */
4690 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4691 && expr->ts.u.derived->attr.is_iso_c)
4693 if (expr->expr_type == EXPR_VARIABLE
4694 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4695 || expr->symtree->n.sym->intmod_sym_id
4696 == ISOCBINDING_NULL_FUNPTR))
4698 /* Set expr_type to EXPR_NULL, which will result in
4699 null_pointer_node being used below. */
4700 expr->expr_type = EXPR_NULL;
4704 /* Update the type/kind of the expression to be what the new
4705 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4706 expr->ts.type = expr->ts.u.derived->ts.type;
4707 expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4708 expr->ts.kind = expr->ts.u.derived->ts.kind;
4712 switch (expr->expr_type)
4715 gfc_conv_expr_op (se, expr);
4719 gfc_conv_function_expr (se, expr);
4723 gfc_conv_constant (se, expr);
4727 gfc_conv_variable (se, expr);
4731 se->expr = null_pointer_node;
4734 case EXPR_SUBSTRING:
4735 gfc_conv_substring_expr (se, expr);
4738 case EXPR_STRUCTURE:
4739 gfc_conv_structure (se, expr, 0);
4743 gfc_conv_array_constructor_expr (se, expr);
4752 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4753 of an assignment. */
4755 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4757 gfc_conv_expr (se, expr);
4758 /* All numeric lvalues should have empty post chains. If not we need to
4759 figure out a way of rewriting an lvalue so that it has no post chain. */
4760 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4763 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4764 numeric expressions. Used for scalar values where inserting cleanup code
4767 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4771 gcc_assert (expr->ts.type != BT_CHARACTER);
4772 gfc_conv_expr (se, expr);
4775 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4776 gfc_add_modify (&se->pre, val, se->expr);
4778 gfc_add_block_to_block (&se->pre, &se->post);
4782 /* Helper to translate an expression and convert it to a particular type. */
4784 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4786 gfc_conv_expr_val (se, expr);
4787 se->expr = convert (type, se->expr);
4791 /* Converts an expression so that it can be passed by reference. Scalar
4795 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4799 if (se->ss && se->ss->expr == expr
4800 && se->ss->type == GFC_SS_REFERENCE)
4802 /* Returns a reference to the scalar evaluated outside the loop
4804 gfc_conv_expr (se, expr);
4808 if (expr->ts.type == BT_CHARACTER)
4810 gfc_conv_expr (se, expr);
4811 gfc_conv_string_parameter (se);
4815 if (expr->expr_type == EXPR_VARIABLE)
4817 se->want_pointer = 1;
4818 gfc_conv_expr (se, expr);
4821 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4822 gfc_add_modify (&se->pre, var, se->expr);
4823 gfc_add_block_to_block (&se->pre, &se->post);
4829 if (expr->expr_type == EXPR_FUNCTION
4830 && ((expr->value.function.esym
4831 && expr->value.function.esym->result->attr.pointer
4832 && !expr->value.function.esym->result->attr.dimension)
4833 || (!expr->value.function.esym
4834 && expr->symtree->n.sym->attr.pointer
4835 && !expr->symtree->n.sym->attr.dimension)))
4837 se->want_pointer = 1;
4838 gfc_conv_expr (se, expr);
4839 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4840 gfc_add_modify (&se->pre, var, se->expr);
4846 gfc_conv_expr (se, expr);
4848 /* Create a temporary var to hold the value. */
4849 if (TREE_CONSTANT (se->expr))
4851 tree tmp = se->expr;
4852 STRIP_TYPE_NOPS (tmp);
4853 var = build_decl (input_location,
4854 CONST_DECL, NULL, TREE_TYPE (tmp));
4855 DECL_INITIAL (var) = tmp;
4856 TREE_STATIC (var) = 1;
4861 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4862 gfc_add_modify (&se->pre, var, se->expr);
4864 gfc_add_block_to_block (&se->pre, &se->post);
4866 /* Take the address of that value. */
4867 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4872 gfc_trans_pointer_assign (gfc_code * code)
4874 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4878 /* Generate code for a pointer assignment. */
4881 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4892 gfc_start_block (&block);
4894 gfc_init_se (&lse, NULL);
4896 lss = gfc_walk_expr (expr1);
4897 rss = gfc_walk_expr (expr2);
4898 if (lss == gfc_ss_terminator)
4900 /* Scalar pointers. */
4901 lse.want_pointer = 1;
4902 gfc_conv_expr (&lse, expr1);
4903 gcc_assert (rss == gfc_ss_terminator);
4904 gfc_init_se (&rse, NULL);
4905 rse.want_pointer = 1;
4906 gfc_conv_expr (&rse, expr2);
4908 if (expr1->symtree->n.sym->attr.proc_pointer
4909 && expr1->symtree->n.sym->attr.dummy)
4910 lse.expr = build_fold_indirect_ref_loc (input_location,
4913 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4914 && expr2->symtree->n.sym->attr.dummy)
4915 rse.expr = build_fold_indirect_ref_loc (input_location,
4918 gfc_add_block_to_block (&block, &lse.pre);
4919 gfc_add_block_to_block (&block, &rse.pre);
4921 /* Check character lengths if character expression. The test is only
4922 really added if -fbounds-check is enabled. */
4923 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4924 && !expr1->symtree->n.sym->attr.proc_pointer
4925 && !gfc_is_proc_ptr_comp (expr1, NULL))
4927 gcc_assert (expr2->ts.type == BT_CHARACTER);
4928 gcc_assert (lse.string_length && rse.string_length);
4929 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4930 lse.string_length, rse.string_length,
4934 gfc_add_modify (&block, lse.expr,
4935 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4937 gfc_add_block_to_block (&block, &rse.post);
4938 gfc_add_block_to_block (&block, &lse.post);
4945 tree strlen_rhs = NULL_TREE;
4947 /* Array pointer. Find the last reference on the LHS and if it is an
4948 array section ref, we're dealing with bounds remapping. In this case,
4949 set it to AR_FULL so that gfc_conv_expr_descriptor does
4950 not see it and process the bounds remapping afterwards explicitely. */
4951 for (remap = expr1->ref; remap; remap = remap->next)
4952 if (!remap->next && remap->type == REF_ARRAY
4953 && remap->u.ar.type == AR_SECTION)
4955 remap->u.ar.type = AR_FULL;
4958 rank_remap = (remap && remap->u.ar.end[0]);
4960 gfc_conv_expr_descriptor (&lse, expr1, lss);
4961 strlen_lhs = lse.string_length;
4964 if (expr2->expr_type == EXPR_NULL)
4966 /* Just set the data pointer to null. */
4967 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4969 else if (rank_remap)
4971 /* If we are rank-remapping, just get the RHS's descriptor and
4972 process this later on. */
4973 gfc_init_se (&rse, NULL);
4974 rse.direct_byref = 1;
4975 rse.byref_noassign = 1;
4976 gfc_conv_expr_descriptor (&rse, expr2, rss);
4977 strlen_rhs = rse.string_length;
4979 else if (expr2->expr_type == EXPR_VARIABLE)
4981 /* Assign directly to the LHS's descriptor. */
4982 lse.direct_byref = 1;
4983 gfc_conv_expr_descriptor (&lse, expr2, rss);
4984 strlen_rhs = lse.string_length;
4986 /* If this is a subreference array pointer assignment, use the rhs
4987 descriptor element size for the lhs span. */
4988 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4990 decl = expr1->symtree->n.sym->backend_decl;
4991 gfc_init_se (&rse, NULL);
4992 rse.descriptor_only = 1;
4993 gfc_conv_expr (&rse, expr2);
4994 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4995 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4996 if (!INTEGER_CST_P (tmp))
4997 gfc_add_block_to_block (&lse.post, &rse.pre);
4998 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
5003 /* Assign to a temporary descriptor and then copy that
5004 temporary to the pointer. */
5005 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
5008 lse.direct_byref = 1;
5009 gfc_conv_expr_descriptor (&lse, expr2, rss);
5010 strlen_rhs = lse.string_length;
5011 gfc_add_modify (&lse.pre, desc, tmp);
5014 gfc_add_block_to_block (&block, &lse.pre);
5016 gfc_add_block_to_block (&block, &rse.pre);
5018 /* If we do bounds remapping, update LHS descriptor accordingly. */
5022 gcc_assert (remap->u.ar.dimen == expr1->rank);
5026 /* Do rank remapping. We already have the RHS's descriptor
5027 converted in rse and now have to build the correct LHS
5028 descriptor for it. */
5032 tree lbound, ubound;
5035 dtype = gfc_conv_descriptor_dtype (desc);
5036 tmp = gfc_get_dtype (TREE_TYPE (desc));
5037 gfc_add_modify (&block, dtype, tmp);
5039 /* Copy data pointer. */
5040 data = gfc_conv_descriptor_data_get (rse.expr);
5041 gfc_conv_descriptor_data_set (&block, desc, data);
5043 /* Copy offset but adjust it such that it would correspond
5044 to a lbound of zero. */
5045 offs = gfc_conv_descriptor_offset_get (rse.expr);
5046 for (dim = 0; dim < expr2->rank; ++dim)
5048 stride = gfc_conv_descriptor_stride_get (rse.expr,
5050 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
5052 tmp = fold_build2_loc (input_location, MULT_EXPR,
5053 gfc_array_index_type, stride, lbound);
5054 offs = fold_build2_loc (input_location, PLUS_EXPR,
5055 gfc_array_index_type, offs, tmp);
5057 gfc_conv_descriptor_offset_set (&block, desc, offs);
5059 /* Set the bounds as declared for the LHS and calculate strides as
5060 well as another offset update accordingly. */
5061 stride = gfc_conv_descriptor_stride_get (rse.expr,
5063 for (dim = 0; dim < expr1->rank; ++dim)
5068 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
5070 /* Convert declared bounds. */
5071 gfc_init_se (&lower_se, NULL);
5072 gfc_init_se (&upper_se, NULL);
5073 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
5074 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
5076 gfc_add_block_to_block (&block, &lower_se.pre);
5077 gfc_add_block_to_block (&block, &upper_se.pre);
5079 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
5080 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
5082 lbound = gfc_evaluate_now (lbound, &block);
5083 ubound = gfc_evaluate_now (ubound, &block);
5085 gfc_add_block_to_block (&block, &lower_se.post);
5086 gfc_add_block_to_block (&block, &upper_se.post);
5088 /* Set bounds in descriptor. */
5089 gfc_conv_descriptor_lbound_set (&block, desc,
5090 gfc_rank_cst[dim], lbound);
5091 gfc_conv_descriptor_ubound_set (&block, desc,
5092 gfc_rank_cst[dim], ubound);
5095 stride = gfc_evaluate_now (stride, &block);
5096 gfc_conv_descriptor_stride_set (&block, desc,
5097 gfc_rank_cst[dim], stride);
5099 /* Update offset. */
5100 offs = gfc_conv_descriptor_offset_get (desc);
5101 tmp = fold_build2_loc (input_location, MULT_EXPR,
5102 gfc_array_index_type, lbound, stride);
5103 offs = fold_build2_loc (input_location, MINUS_EXPR,
5104 gfc_array_index_type, offs, tmp);
5105 offs = gfc_evaluate_now (offs, &block);
5106 gfc_conv_descriptor_offset_set (&block, desc, offs);
5108 /* Update stride. */
5109 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5110 stride = fold_build2_loc (input_location, MULT_EXPR,
5111 gfc_array_index_type, stride, tmp);
5116 /* Bounds remapping. Just shift the lower bounds. */
5118 gcc_assert (expr1->rank == expr2->rank);
5120 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
5124 gcc_assert (remap->u.ar.start[dim]);
5125 gcc_assert (!remap->u.ar.end[dim]);
5126 gfc_init_se (&lbound_se, NULL);
5127 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
5129 gfc_add_block_to_block (&block, &lbound_se.pre);
5130 gfc_conv_shift_descriptor_lbound (&block, desc,
5131 dim, lbound_se.expr);
5132 gfc_add_block_to_block (&block, &lbound_se.post);
5137 /* Check string lengths if applicable. The check is only really added
5138 to the output code if -fbounds-check is enabled. */
5139 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
5141 gcc_assert (expr2->ts.type == BT_CHARACTER);
5142 gcc_assert (strlen_lhs && strlen_rhs);
5143 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
5144 strlen_lhs, strlen_rhs, &block);
5147 /* If rank remapping was done, check with -fcheck=bounds that
5148 the target is at least as large as the pointer. */
5149 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
5155 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
5156 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
5158 lsize = gfc_evaluate_now (lsize, &block);
5159 rsize = gfc_evaluate_now (rsize, &block);
5160 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
5163 msg = _("Target of rank remapping is too small (%ld < %ld)");
5164 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
5168 gfc_add_block_to_block (&block, &lse.post);
5170 gfc_add_block_to_block (&block, &rse.post);
5173 return gfc_finish_block (&block);
5177 /* Makes sure se is suitable for passing as a function string parameter. */
5178 /* TODO: Need to check all callers of this function. It may be abused. */
5181 gfc_conv_string_parameter (gfc_se * se)
5185 if (TREE_CODE (se->expr) == STRING_CST)
5187 type = TREE_TYPE (TREE_TYPE (se->expr));
5188 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5192 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
5194 if (TREE_CODE (se->expr) != INDIRECT_REF)
5196 type = TREE_TYPE (se->expr);
5197 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
5201 type = gfc_get_character_type_len (gfc_default_character_kind,
5203 type = build_pointer_type (type);
5204 se->expr = gfc_build_addr_expr (type, se->expr);
5208 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
5209 gcc_assert (se->string_length
5210 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
5214 /* Generate code for assignment of scalar variables. Includes character
5215 strings and derived types with allocatable components.
5216 If you know that the LHS has no allocations, set dealloc to false. */
5219 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5220 bool l_is_temp, bool r_is_var, bool dealloc)
5226 gfc_init_block (&block);
5228 if (ts.type == BT_CHARACTER)
5233 if (lse->string_length != NULL_TREE)
5235 gfc_conv_string_parameter (lse);
5236 gfc_add_block_to_block (&block, &lse->pre);
5237 llen = lse->string_length;
5240 if (rse->string_length != NULL_TREE)
5242 gcc_assert (rse->string_length != NULL_TREE);
5243 gfc_conv_string_parameter (rse);
5244 gfc_add_block_to_block (&block, &rse->pre);
5245 rlen = rse->string_length;
5248 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
5249 rse->expr, ts.kind);
5251 else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5255 /* Are the rhs and the lhs the same? */
5258 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5259 gfc_build_addr_expr (NULL_TREE, lse->expr),
5260 gfc_build_addr_expr (NULL_TREE, rse->expr));
5261 cond = gfc_evaluate_now (cond, &lse->pre);
5264 /* Deallocate the lhs allocated components as long as it is not
5265 the same as the rhs. This must be done following the assignment
5266 to prevent deallocating data that could be used in the rhs
5268 if (!l_is_temp && dealloc)
5270 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5271 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5273 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5275 gfc_add_expr_to_block (&lse->post, tmp);
5278 gfc_add_block_to_block (&block, &rse->pre);
5279 gfc_add_block_to_block (&block, &lse->pre);
5281 gfc_add_modify (&block, lse->expr,
5282 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5284 /* Do a deep copy if the rhs is a variable, if it is not the
5288 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
5289 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
5291 gfc_add_expr_to_block (&block, tmp);
5294 else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5296 gfc_add_block_to_block (&block, &lse->pre);
5297 gfc_add_block_to_block (&block, &rse->pre);
5298 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
5299 TREE_TYPE (lse->expr), rse->expr);
5300 gfc_add_modify (&block, lse->expr, tmp);
5304 gfc_add_block_to_block (&block, &lse->pre);
5305 gfc_add_block_to_block (&block, &rse->pre);
5307 gfc_add_modify (&block, lse->expr,
5308 fold_convert (TREE_TYPE (lse->expr), rse->expr));
5311 gfc_add_block_to_block (&block, &lse->post);
5312 gfc_add_block_to_block (&block, &rse->post);
5314 return gfc_finish_block (&block);
5318 /* There are quite a lot of restrictions on the optimisation in using an
5319 array function assign without a temporary. */
5322 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
5325 bool seen_array_ref;
5327 gfc_symbol *sym = expr1->symtree->n.sym;
5329 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5330 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5333 /* Elemental functions are scalarized so that they don't need a
5334 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5335 they would need special treatment in gfc_trans_arrayfunc_assign. */
5336 if (expr2->value.function.esym != NULL
5337 && expr2->value.function.esym->attr.elemental)
5340 /* Need a temporary if rhs is not FULL or a contiguous section. */
5341 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5344 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5345 if (gfc_ref_needs_temporary_p (expr1->ref))
5348 /* Functions returning pointers need temporaries. */
5349 if (expr2->symtree->n.sym->attr.pointer
5350 || expr2->symtree->n.sym->attr.allocatable)
5353 /* Character array functions need temporaries unless the
5354 character lengths are the same. */
5355 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
5357 if (expr1->ts.u.cl->length == NULL
5358 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5361 if (expr2->ts.u.cl->length == NULL
5362 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5365 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
5366 expr2->ts.u.cl->length->value.integer) != 0)
5370 /* Check that no LHS component references appear during an array
5371 reference. This is needed because we do not have the means to
5372 span any arbitrary stride with an array descriptor. This check
5373 is not needed for the rhs because the function result has to be
5375 seen_array_ref = false;
5376 for (ref = expr1->ref; ref; ref = ref->next)
5378 if (ref->type == REF_ARRAY)
5379 seen_array_ref= true;
5380 else if (ref->type == REF_COMPONENT && seen_array_ref)
5384 /* Check for a dependency. */
5385 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
5386 expr2->value.function.esym,
5387 expr2->value.function.actual,
5391 /* If we have reached here with an intrinsic function, we do not
5392 need a temporary. */
5393 if (expr2->value.function.isym)
5396 /* If the LHS is a dummy, we need a temporary if it is not
5398 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
5401 /* If the lhs has been host_associated, is in common, a pointer or is
5402 a target and the function is not using a RESULT variable, aliasing
5403 can occur and a temporary is needed. */
5404 if ((sym->attr.host_assoc
5405 || sym->attr.in_common
5406 || sym->attr.pointer
5407 || sym->attr.cray_pointee
5408 || sym->attr.target)
5409 && expr2->symtree != NULL
5410 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
5413 /* A PURE function can unconditionally be called without a temporary. */
5414 if (expr2->value.function.esym != NULL
5415 && expr2->value.function.esym->attr.pure)
5418 /* Implicit_pure functions are those which could legally be declared
5420 if (expr2->value.function.esym != NULL
5421 && expr2->value.function.esym->attr.implicit_pure)
5424 if (!sym->attr.use_assoc
5425 && !sym->attr.in_common
5426 && !sym->attr.pointer
5427 && !sym->attr.target
5428 && !sym->attr.cray_pointee
5429 && expr2->value.function.esym)
5431 /* A temporary is not needed if the function is not contained and
5432 the variable is local or host associated and not a pointer or
5434 if (!expr2->value.function.esym->attr.contained)
5437 /* A temporary is not needed if the lhs has never been host
5438 associated and the procedure is contained. */
5439 else if (!sym->attr.host_assoc)
5442 /* A temporary is not needed if the variable is local and not
5443 a pointer, a target or a result. */
5445 && expr2->value.function.esym->ns == sym->ns->parent)
5449 /* Default to temporary use. */
5454 /* Provide the loop info so that the lhs descriptor can be built for
5455 reallocatable assignments from extrinsic function calls. */
5458 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
5461 /* Signal that the function call should not be made by
5462 gfc_conv_loop_setup. */
5463 se->ss->is_alloc_lhs = 1;
5464 gfc_init_loopinfo (&loop);
5465 gfc_add_ss_to_loop (&loop, *ss);
5466 gfc_add_ss_to_loop (&loop, se->ss);
5467 gfc_conv_ss_startstride (&loop);
5468 gfc_conv_loop_setup (&loop, where);
5469 gfc_copy_loopinfo_to_se (se, &loop);
5470 gfc_add_block_to_block (&se->pre, &loop.pre);
5471 gfc_add_block_to_block (&se->pre, &loop.post);
5472 se->ss->is_alloc_lhs = 0;
5477 realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
5484 /* Use the allocation done by the library. */
5485 desc = build_fold_indirect_ref_loc (input_location, se->expr);
5486 tmp = gfc_conv_descriptor_data_get (desc);
5487 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
5488 gfc_add_expr_to_block (&se->pre, tmp);
5489 gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
5490 /* Unallocated, the descriptor does not have a dtype. */
5491 tmp = gfc_conv_descriptor_dtype (desc);
5492 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
5494 offset = gfc_index_zero_node;
5495 tmp = gfc_index_one_node;
5496 /* Now reset the bounds from zero based to unity based. */
5497 for (n = 0 ; n < rank; n++)
5499 /* Accumulate the offset. */
5500 offset = fold_build2_loc (input_location, MINUS_EXPR,
5501 gfc_array_index_type,
5503 /* Now do the bounds. */
5504 gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
5505 tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
5506 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5507 gfc_array_index_type,
5508 tmp, gfc_index_one_node);
5509 gfc_conv_descriptor_lbound_set (&se->post, desc,
5511 gfc_index_one_node);
5512 gfc_conv_descriptor_ubound_set (&se->post, desc,
5513 gfc_rank_cst[n], tmp);
5515 /* The extent for the next contribution to offset. */
5516 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5517 gfc_array_index_type,
5518 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
5519 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
5520 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5521 gfc_array_index_type,
5522 tmp, gfc_index_one_node);
5524 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
5529 /* Try to translate array(:) = func (...), where func is a transformational
5530 array function, without using a temporary. Returns NULL if this isn't the
5534 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
5538 gfc_component *comp = NULL;
5540 if (arrayfunc_assign_needs_temporary (expr1, expr2))
5543 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5545 gcc_assert (expr2->value.function.isym
5546 || (gfc_is_proc_ptr_comp (expr2, &comp)
5547 && comp && comp->attr.dimension)
5548 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5549 && expr2->value.function.esym->result->attr.dimension));
5551 ss = gfc_walk_expr (expr1);
5552 gcc_assert (ss != gfc_ss_terminator);
5553 gfc_init_se (&se, NULL);
5554 gfc_start_block (&se.pre);
5555 se.want_pointer = 1;
5557 gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
5559 if (expr1->ts.type == BT_DERIVED
5560 && expr1->ts.u.derived->attr.alloc_comp)
5563 tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
5565 gfc_add_expr_to_block (&se.pre, tmp);
5568 se.direct_byref = 1;
5569 se.ss = gfc_walk_expr (expr2);
5570 gcc_assert (se.ss != gfc_ss_terminator);
5572 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5573 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5574 Clearly, this cannot be done for an allocatable function result, since
5575 the shape of the result is unknown and, in any case, the function must
5576 correctly take care of the reallocation internally. For intrinsic
5577 calls, the array data is freed and the library takes care of allocation.
5578 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5580 if (gfc_option.flag_realloc_lhs
5581 && gfc_is_reallocatable_lhs (expr1)
5582 && !gfc_expr_attr (expr1).codimension
5583 && !gfc_is_coindexed (expr1)
5584 && !(expr2->value.function.esym
5585 && expr2->value.function.esym->result->attr.allocatable))
5587 if (!expr2->value.function.isym)
5589 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
5590 ss->is_alloc_lhs = 1;
5593 realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
5596 gfc_conv_function_expr (&se, expr2);
5597 gfc_add_block_to_block (&se.pre, &se.post);
5599 return gfc_finish_block (&se.pre);
5603 /* Try to efficiently translate array(:) = 0. Return NULL if this
5607 gfc_trans_zero_assign (gfc_expr * expr)
5609 tree dest, len, type;
5613 sym = expr->symtree->n.sym;
5614 dest = gfc_get_symbol_decl (sym);
5616 type = TREE_TYPE (dest);
5617 if (POINTER_TYPE_P (type))
5618 type = TREE_TYPE (type);
5619 if (!GFC_ARRAY_TYPE_P (type))
5622 /* Determine the length of the array. */
5623 len = GFC_TYPE_ARRAY_SIZE (type);
5624 if (!len || TREE_CODE (len) != INTEGER_CST)
5627 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5628 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5629 fold_convert (gfc_array_index_type, tmp));
5631 /* If we are zeroing a local array avoid taking its address by emitting
5633 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5634 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
5635 dest, build_constructor (TREE_TYPE (dest), NULL));
5637 /* Convert arguments to the correct types. */
5638 dest = fold_convert (pvoid_type_node, dest);
5639 len = fold_convert (size_type_node, len);
5641 /* Construct call to __builtin_memset. */
5642 tmp = build_call_expr_loc (input_location,
5643 built_in_decls[BUILT_IN_MEMSET],
5644 3, dest, integer_zero_node, len);
5645 return fold_convert (void_type_node, tmp);
5649 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5650 that constructs the call to __builtin_memcpy. */
5653 gfc_build_memcpy_call (tree dst, tree src, tree len)
5657 /* Convert arguments to the correct types. */
5658 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5659 dst = gfc_build_addr_expr (pvoid_type_node, dst);
5661 dst = fold_convert (pvoid_type_node, dst);
5663 if (!POINTER_TYPE_P (TREE_TYPE (src)))
5664 src = gfc_build_addr_expr (pvoid_type_node, src);
5666 src = fold_convert (pvoid_type_node, src);
5668 len = fold_convert (size_type_node, len);
5670 /* Construct call to __builtin_memcpy. */
5671 tmp = build_call_expr_loc (input_location,
5672 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5673 return fold_convert (void_type_node, tmp);
5677 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5678 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5679 source/rhs, both are gfc_full_array_ref_p which have been checked for
5683 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5685 tree dst, dlen, dtype;
5686 tree src, slen, stype;
5689 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5690 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5692 dtype = TREE_TYPE (dst);
5693 if (POINTER_TYPE_P (dtype))
5694 dtype = TREE_TYPE (dtype);
5695 stype = TREE_TYPE (src);
5696 if (POINTER_TYPE_P (stype))
5697 stype = TREE_TYPE (stype);
5699 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5702 /* Determine the lengths of the arrays. */
5703 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5704 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5706 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5707 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5708 dlen, fold_convert (gfc_array_index_type, tmp));
5710 slen = GFC_TYPE_ARRAY_SIZE (stype);
5711 if (!slen || TREE_CODE (slen) != INTEGER_CST)
5713 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5714 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5715 slen, fold_convert (gfc_array_index_type, tmp));
5717 /* Sanity check that they are the same. This should always be
5718 the case, as we should already have checked for conformance. */
5719 if (!tree_int_cst_equal (slen, dlen))
5722 return gfc_build_memcpy_call (dst, src, dlen);
5726 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5727 this can't be done. EXPR1 is the destination/lhs for which
5728 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5731 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5733 unsigned HOST_WIDE_INT nelem;
5739 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5743 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5744 dtype = TREE_TYPE (dst);
5745 if (POINTER_TYPE_P (dtype))
5746 dtype = TREE_TYPE (dtype);
5747 if (!GFC_ARRAY_TYPE_P (dtype))
5750 /* Determine the lengths of the array. */
5751 len = GFC_TYPE_ARRAY_SIZE (dtype);
5752 if (!len || TREE_CODE (len) != INTEGER_CST)
5755 /* Confirm that the constructor is the same size. */
5756 if (compare_tree_int (len, nelem) != 0)
5759 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5760 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
5761 fold_convert (gfc_array_index_type, tmp));
5763 stype = gfc_typenode_for_spec (&expr2->ts);
5764 src = gfc_build_constant_array_constructor (expr2, stype);
5766 stype = TREE_TYPE (src);
5767 if (POINTER_TYPE_P (stype))
5768 stype = TREE_TYPE (stype);
5770 return gfc_build_memcpy_call (dst, src, len);
5774 /* Tells whether the expression is to be treated as a variable reference. */
5777 expr_is_variable (gfc_expr *expr)
5781 if (expr->expr_type == EXPR_VARIABLE)
5784 arg = gfc_get_noncopying_intrinsic_argument (expr);
5787 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5788 return expr_is_variable (arg);
5795 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5796 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5797 init_flag indicates initialization expressions and dealloc that no
5798 deallocate prior assignment is needed (if in doubt, set true). */
5801 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
5807 gfc_ss *lss_section;
5814 bool scalar_to_array;
5818 /* Assignment of the form lhs = rhs. */
5819 gfc_start_block (&block);
5821 gfc_init_se (&lse, NULL);
5822 gfc_init_se (&rse, NULL);
5825 lss = gfc_walk_expr (expr1);
5826 if (gfc_is_reallocatable_lhs (expr1)
5827 && !(expr2->expr_type == EXPR_FUNCTION
5828 && expr2->value.function.isym != NULL))
5829 lss->is_alloc_lhs = 1;
5831 if (lss != gfc_ss_terminator)
5833 /* Allow the scalarizer to workshare array assignments. */
5834 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5835 ompws_flags |= OMPWS_SCALARIZER_WS;
5837 /* The assignment needs scalarization. */
5840 /* Find a non-scalar SS from the lhs. */
5841 while (lss_section != gfc_ss_terminator
5842 && lss_section->type != GFC_SS_SECTION)
5843 lss_section = lss_section->next;
5845 gcc_assert (lss_section != gfc_ss_terminator);
5847 /* Initialize the scalarizer. */
5848 gfc_init_loopinfo (&loop);
5851 rss = gfc_walk_expr (expr2);
5852 if (rss == gfc_ss_terminator)
5854 /* The rhs is scalar. Add a ss for the expression. */
5855 rss = gfc_get_ss ();
5856 rss->next = gfc_ss_terminator;
5857 rss->type = GFC_SS_SCALAR;
5860 /* Associate the SS with the loop. */
5861 gfc_add_ss_to_loop (&loop, lss);
5862 gfc_add_ss_to_loop (&loop, rss);
5864 /* Calculate the bounds of the scalarization. */
5865 gfc_conv_ss_startstride (&loop);
5866 /* Enable loop reversal. */
5867 for (n = 0; n < loop.dimen; n++)
5868 loop.reverse[n] = GFC_REVERSE_NOT_SET;
5869 /* Resolve any data dependencies in the statement. */
5870 gfc_conv_resolve_dependencies (&loop, lss, rss);
5871 /* Setup the scalarizing loops. */
5872 gfc_conv_loop_setup (&loop, &expr2->where);
5874 /* Setup the gfc_se structures. */
5875 gfc_copy_loopinfo_to_se (&lse, &loop);
5876 gfc_copy_loopinfo_to_se (&rse, &loop);
5879 gfc_mark_ss_chain_used (rss, 1);
5880 if (loop.temp_ss == NULL)
5883 gfc_mark_ss_chain_used (lss, 1);
5887 lse.ss = loop.temp_ss;
5888 gfc_mark_ss_chain_used (lss, 3);
5889 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5892 /* Start the scalarized loop body. */
5893 gfc_start_scalarized_body (&loop, &body);
5896 gfc_init_block (&body);
5898 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5900 /* Translate the expression. */
5901 gfc_conv_expr (&rse, expr2);
5903 /* Stabilize a string length for temporaries. */
5904 if (expr2->ts.type == BT_CHARACTER)
5905 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5907 string_length = NULL_TREE;
5911 gfc_conv_tmp_array_ref (&lse);
5912 if (expr2->ts.type == BT_CHARACTER)
5913 lse.string_length = string_length;
5916 gfc_conv_expr (&lse, expr1);
5918 /* Assignments of scalar derived types with allocatable components
5919 to arrays must be done with a deep copy and the rhs temporary
5920 must have its components deallocated afterwards. */
5921 scalar_to_array = (expr2->ts.type == BT_DERIVED
5922 && expr2->ts.u.derived->attr.alloc_comp
5923 && !expr_is_variable (expr2)
5924 && !gfc_is_constant_expr (expr2)
5925 && expr1->rank && !expr2->rank);
5926 if (scalar_to_array && dealloc)
5928 tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5929 gfc_add_expr_to_block (&loop.post, tmp);
5932 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5933 l_is_temp || init_flag,
5934 expr_is_variable (expr2) || scalar_to_array,
5936 gfc_add_expr_to_block (&body, tmp);
5938 if (lss == gfc_ss_terminator)
5940 /* Use the scalar assignment as is. */
5941 gfc_add_block_to_block (&block, &body);
5945 gcc_assert (lse.ss == gfc_ss_terminator
5946 && rse.ss == gfc_ss_terminator);
5950 gfc_trans_scalarized_loop_boundary (&loop, &body);
5952 /* We need to copy the temporary to the actual lhs. */
5953 gfc_init_se (&lse, NULL);
5954 gfc_init_se (&rse, NULL);
5955 gfc_copy_loopinfo_to_se (&lse, &loop);
5956 gfc_copy_loopinfo_to_se (&rse, &loop);
5958 rse.ss = loop.temp_ss;
5961 gfc_conv_tmp_array_ref (&rse);
5962 gfc_conv_expr (&lse, expr1);
5964 gcc_assert (lse.ss == gfc_ss_terminator
5965 && rse.ss == gfc_ss_terminator);
5967 if (expr2->ts.type == BT_CHARACTER)
5968 rse.string_length = string_length;
5970 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5971 false, false, dealloc);
5972 gfc_add_expr_to_block (&body, tmp);
5975 /* Allocate or reallocate lhs of allocatable array. */
5976 if (gfc_option.flag_realloc_lhs
5977 && gfc_is_reallocatable_lhs (expr1)
5978 && !gfc_expr_attr (expr1).codimension
5979 && !gfc_is_coindexed (expr1))
5981 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
5982 if (tmp != NULL_TREE)
5983 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
5986 /* Generate the copying loops. */
5987 gfc_trans_scalarizing_loops (&loop, &body);
5989 /* Wrap the whole thing up. */
5990 gfc_add_block_to_block (&block, &loop.pre);
5991 gfc_add_block_to_block (&block, &loop.post);
5993 gfc_cleanup_loop (&loop);
5996 return gfc_finish_block (&block);
6000 /* Check whether EXPR is a copyable array. */
6003 copyable_array_p (gfc_expr * expr)
6005 if (expr->expr_type != EXPR_VARIABLE)
6008 /* First check it's an array. */
6009 if (expr->rank < 1 || !expr->ref || expr->ref->next)
6012 if (!gfc_full_array_ref_p (expr->ref, NULL))
6015 /* Next check that it's of a simple enough type. */
6016 switch (expr->ts.type)
6028 return !expr->ts.u.derived->attr.alloc_comp;
6037 /* Translate an assignment. */
6040 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
6045 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6047 gfc_error ("Assignment to deferred-length character variable at %L "
6048 "not implemented", &expr1->where);
6052 /* Special case a single function returning an array. */
6053 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
6055 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
6060 /* Special case assigning an array to zero. */
6061 if (copyable_array_p (expr1)
6062 && is_zero_initializer_p (expr2))
6064 tmp = gfc_trans_zero_assign (expr1);
6069 /* Special case copying one array to another. */
6070 if (copyable_array_p (expr1)
6071 && copyable_array_p (expr2)
6072 && gfc_compare_types (&expr1->ts, &expr2->ts)
6073 && !gfc_check_dependency (expr1, expr2, 0))
6075 tmp = gfc_trans_array_copy (expr1, expr2);
6080 /* Special case initializing an array from a constant array constructor. */
6081 if (copyable_array_p (expr1)
6082 && expr2->expr_type == EXPR_ARRAY
6083 && gfc_compare_types (&expr1->ts, &expr2->ts))
6085 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
6090 /* Fallback to the scalarizer to generate explicit loops. */
6091 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
6095 gfc_trans_init_assign (gfc_code * code)
6097 return gfc_trans_assignment (code->expr1, code->expr2, true, false);
6101 gfc_trans_assign (gfc_code * code)
6103 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
6107 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6108 A MEMCPY is needed to copy the full data from the default initializer
6109 of the dynamic type. */
6112 gfc_trans_class_init_assign (gfc_code *code)
6116 gfc_se dst,src,memsz;
6117 gfc_expr *lhs,*rhs,*sz;
6119 gfc_start_block (&block);
6121 lhs = gfc_copy_expr (code->expr1);
6122 gfc_add_data_component (lhs);
6124 rhs = gfc_copy_expr (code->expr1);
6125 gfc_add_vptr_component (rhs);
6126 gfc_add_def_init_component (rhs);
6128 sz = gfc_copy_expr (code->expr1);
6129 gfc_add_vptr_component (sz);
6130 gfc_add_size_component (sz);
6132 gfc_init_se (&dst, NULL);
6133 gfc_init_se (&src, NULL);
6134 gfc_init_se (&memsz, NULL);
6135 gfc_conv_expr (&dst, lhs);
6136 gfc_conv_expr (&src, rhs);
6137 gfc_conv_expr (&memsz, sz);
6138 gfc_add_block_to_block (&block, &src.pre);
6139 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
6140 gfc_add_expr_to_block (&block, tmp);
6142 return gfc_finish_block (&block);
6146 /* Translate an assignment to a CLASS object
6147 (pointer or ordinary assignment). */
6150 gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
6157 gfc_start_block (&block);
6159 if (expr2->ts.type != BT_CLASS)
6161 /* Insert an additional assignment which sets the '_vptr' field. */
6162 gfc_symbol *vtab = NULL;
6165 lhs = gfc_copy_expr (expr1);
6166 gfc_add_vptr_component (lhs);
6168 if (expr2->ts.type == BT_DERIVED)
6169 vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
6170 else if (expr2->expr_type == EXPR_NULL)
6171 vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
6174 rhs = gfc_get_expr ();
6175 rhs->expr_type = EXPR_VARIABLE;
6176 gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
6180 tmp = gfc_trans_pointer_assignment (lhs, rhs);
6181 gfc_add_expr_to_block (&block, tmp);
6183 gfc_free_expr (lhs);
6184 gfc_free_expr (rhs);
6187 /* Do the actual CLASS assignment. */
6188 if (expr2->ts.type == BT_CLASS)
6191 gfc_add_data_component (expr1);
6193 if (op == EXEC_ASSIGN)
6194 tmp = gfc_trans_assignment (expr1, expr2, false, true);
6195 else if (op == EXEC_POINTER_ASSIGN)
6196 tmp = gfc_trans_pointer_assignment (expr1, expr2);
6200 gfc_add_expr_to_block (&block, tmp);
6202 return gfc_finish_block (&block);