1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
53 dest
->loop
= src
->loop
;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
66 memset (se
, 0, sizeof (gfc_se
));
67 gfc_init_block (&se
->pre
);
68 gfc_init_block (&se
->post
);
73 gfc_copy_se_loopvars (se
, parent
);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se
* se
)
86 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se
* se
)
110 if (CONSTANT_CLASS_P (se
->expr
))
113 /* We need a temporary for this result. */
114 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
115 gfc_add_modify (&se
->pre
, var
, se
->expr
);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol
* sym
)
128 gcc_assert (sym
->attr
.dummy
);
130 decl
= gfc_get_symbol_decl (sym
);
131 if (TREE_CODE (decl
) != PARM_DECL
)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
137 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
140 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
141 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
144 as actual argument to denote absent dummies. For array descriptors,
145 we thus also need to check the array descriptor. */
146 if (!sym
->attr
.pointer
&& !sym
->attr
.allocatable
147 && sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
148 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
151 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
152 tmp
= gfc_conv_array_data (tmp
);
153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
154 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
155 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
156 boolean_type_node
, cond
, tmp
);
163 /* Converts a missing, dummy argument into a null or zero. */
166 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
171 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
175 /* Create a temporary and convert it to the correct type. */
176 tmp
= gfc_get_int_type (kind
);
177 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
180 /* Test for a NULL value. */
181 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
182 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
183 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
184 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
188 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
190 build_zero_cst (TREE_TYPE (se
->expr
)));
191 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
195 if (ts
.type
== BT_CHARACTER
)
197 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
198 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
199 present
, se
->string_length
, tmp
);
200 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
201 se
->string_length
= tmp
;
207 /* Get the character length of an expression, looking through gfc_refs
211 gfc_get_expr_charlen (gfc_expr
*e
)
216 gcc_assert (e
->expr_type
== EXPR_VARIABLE
217 && e
->ts
.type
== BT_CHARACTER
);
219 length
= NULL
; /* To silence compiler warning. */
221 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
224 gfc_init_se (&tmpse
, NULL
);
225 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
226 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
230 /* First candidate: if the variable is of type CHARACTER, the
231 expression's length could be the length of the character
233 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
234 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
236 /* Look through the reference chain for component references. */
237 for (r
= e
->ref
; r
; r
= r
->next
)
242 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
243 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
251 /* We should never got substring references here. These will be
252 broken down by the scalarizer. */
258 gcc_assert (length
!= NULL
);
263 /* For each character array constructor subexpression without a ts.u.cl->length,
264 replace it by its first element (if there aren't any elements, the length
265 should already be set to zero). */
268 flatten_array_ctors_without_strlen (gfc_expr
* e
)
270 gfc_actual_arglist
* arg
;
276 switch (e
->expr_type
)
280 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
281 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
285 /* TODO: Implement as with EXPR_FUNCTION when needed. */
289 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
290 flatten_array_ctors_without_strlen (arg
->expr
);
295 /* We've found what we're looking for. */
296 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
301 gcc_assert (e
->value
.constructor
);
303 c
= gfc_constructor_first (e
->value
.constructor
);
307 flatten_array_ctors_without_strlen (new_expr
);
308 gfc_replace_expr (e
, new_expr
);
312 /* Otherwise, fall through to handle constructor elements. */
314 for (c
= gfc_constructor_first (e
->value
.constructor
);
315 c
; c
= gfc_constructor_next (c
))
316 flatten_array_ctors_without_strlen (c
->expr
);
326 /* Generate code to initialize a string length variable. Returns the
327 value. For array constructors, cl->length might be NULL and in this case,
328 the first element of the constructor is needed. expr is the original
329 expression so we can access it but can be NULL if this is not needed. */
332 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
336 gfc_init_se (&se
, NULL
);
338 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
339 "flatten" array constructors by taking their first element; all elements
340 should be the same length or a cl->length should be present. */
346 expr_flat
= gfc_copy_expr (expr
);
347 flatten_array_ctors_without_strlen (expr_flat
);
348 gfc_resolve_expr (expr_flat
);
350 gfc_conv_expr (&se
, expr_flat
);
351 gfc_add_block_to_block (pblock
, &se
.pre
);
352 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
354 gfc_free_expr (expr_flat
);
358 /* Convert cl->length. */
360 gcc_assert (cl
->length
);
362 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
363 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
364 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
365 gfc_add_block_to_block (pblock
, &se
.pre
);
367 if (cl
->backend_decl
)
368 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
370 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
375 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
376 const char *name
, locus
*where
)
385 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
386 type
= build_pointer_type (type
);
388 gfc_init_se (&start
, se
);
389 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
390 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
392 if (integer_onep (start
.expr
))
393 gfc_conv_string_parameter (se
);
398 /* Avoid multiple evaluation of substring start. */
399 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
400 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
402 /* Change the start of the string. */
403 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
406 tmp
= build_fold_indirect_ref_loc (input_location
,
408 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
409 se
->expr
= gfc_build_addr_expr (type
, tmp
);
412 /* Length = end + 1 - start. */
413 gfc_init_se (&end
, se
);
414 if (ref
->u
.ss
.end
== NULL
)
415 end
.expr
= se
->string_length
;
418 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
419 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
423 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
424 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
426 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
428 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
429 boolean_type_node
, start
.expr
,
432 /* Check lower bound. */
433 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
435 build_int_cst (gfc_charlen_type_node
, 1));
436 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
437 boolean_type_node
, nonempty
, fault
);
439 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
440 "is less than one", name
);
442 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
444 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
445 fold_convert (long_integer_type_node
,
449 /* Check upper bound. */
450 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
451 end
.expr
, se
->string_length
);
452 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
453 boolean_type_node
, nonempty
, fault
);
455 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
456 "exceeds string length (%%ld)", name
);
458 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
459 "exceeds string length (%%ld)");
460 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
461 fold_convert (long_integer_type_node
, end
.expr
),
462 fold_convert (long_integer_type_node
,
467 /* If the start and end expressions are equal, the length is one. */
469 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
470 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
473 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
474 end
.expr
, start
.expr
);
475 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
476 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
477 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
478 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
481 se
->string_length
= tmp
;
485 /* Convert a derived type component reference. */
488 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
495 c
= ref
->u
.c
.component
;
497 gcc_assert (c
->backend_decl
);
499 field
= c
->backend_decl
;
500 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
502 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
503 decl
, field
, NULL_TREE
);
507 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
509 tmp
= c
->ts
.u
.cl
->backend_decl
;
510 /* Components must always be constant length. */
511 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
512 se
->string_length
= tmp
;
515 if (((c
->attr
.pointer
|| c
->attr
.allocatable
) && c
->attr
.dimension
== 0
516 && c
->ts
.type
!= BT_CHARACTER
)
517 || c
->attr
.proc_pointer
)
518 se
->expr
= build_fold_indirect_ref_loc (input_location
,
523 /* This function deals with component references to components of the
524 parent type for derived type extensons. */
526 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
534 c
= ref
->u
.c
.component
;
536 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
537 parent
.type
= REF_COMPONENT
;
540 parent
.u
.c
.component
= dt
->components
;
542 if (dt
->backend_decl
== NULL
)
543 gfc_get_derived_type (dt
);
545 if (dt
->attr
.extension
&& dt
->components
)
547 if (dt
->attr
.is_class
)
548 cmp
= dt
->components
;
550 cmp
= dt
->components
->next
;
551 /* Return if the component is not in the parent type. */
552 for (; cmp
; cmp
= cmp
->next
)
553 if (strcmp (c
->name
, cmp
->name
) == 0)
556 /* Otherwise build the reference and call self. */
557 gfc_conv_component_ref (se
, &parent
);
558 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
559 parent
.u
.c
.component
= c
;
560 conv_parent_component_references (se
, &parent
);
564 /* Return the contents of a variable. Also handles reference/pointer
565 variables (all Fortran pointer references are implicit). */
568 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
572 tree parent_decl
= NULL_TREE
;
575 bool alternate_entry
;
578 sym
= expr
->symtree
->n
.sym
;
581 /* Check that something hasn't gone horribly wrong. */
582 gcc_assert (se
->ss
!= gfc_ss_terminator
);
583 gcc_assert (se
->ss
->expr
== expr
);
585 /* A scalarized term. We already know the descriptor. */
586 se
->expr
= se
->ss
->data
.info
.descriptor
;
587 se
->string_length
= se
->ss
->string_length
;
588 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
589 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
594 tree se_expr
= NULL_TREE
;
596 se
->expr
= gfc_get_symbol_decl (sym
);
598 /* Deal with references to a parent results or entries by storing
599 the current_function_decl and moving to the parent_decl. */
600 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
601 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
602 && sym
->result
== sym
;
603 entry_master
= sym
->attr
.result
604 && sym
->ns
->proc_name
->attr
.entry_master
605 && !gfc_return_by_reference (sym
->ns
->proc_name
);
606 if (current_function_decl
)
607 parent_decl
= DECL_CONTEXT (current_function_decl
);
609 if ((se
->expr
== parent_decl
&& return_value
)
610 || (sym
->ns
&& sym
->ns
->proc_name
612 && sym
->ns
->proc_name
->backend_decl
== parent_decl
613 && (alternate_entry
|| entry_master
)))
618 /* Special case for assigning the return value of a function.
619 Self recursive functions must have an explicit return value. */
620 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
621 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
623 /* Similarly for alternate entry points. */
624 else if (alternate_entry
625 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
628 gfc_entry_list
*el
= NULL
;
630 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
633 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
638 else if (entry_master
639 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
641 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
646 /* Procedure actual arguments. */
647 else if (sym
->attr
.flavor
== FL_PROCEDURE
648 && se
->expr
!= current_function_decl
)
650 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
652 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
653 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
659 /* Dereference the expression, where needed. Since characters
660 are entirely different from other types, they are treated
662 if (sym
->ts
.type
== BT_CHARACTER
)
664 /* Dereference character pointer dummy arguments
666 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
668 || sym
->attr
.function
669 || sym
->attr
.result
))
670 se
->expr
= build_fold_indirect_ref_loc (input_location
,
674 else if (!sym
->attr
.value
)
676 /* Dereference non-character scalar dummy arguments. */
677 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
678 se
->expr
= build_fold_indirect_ref_loc (input_location
,
681 /* Dereference scalar hidden result. */
682 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
683 && (sym
->attr
.function
|| sym
->attr
.result
)
684 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
685 && !sym
->attr
.always_explicit
)
686 se
->expr
= build_fold_indirect_ref_loc (input_location
,
689 /* Dereference non-character pointer variables.
690 These must be dummies, results, or scalars. */
691 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
692 || gfc_is_associate_pointer (sym
))
694 || sym
->attr
.function
696 || !sym
->attr
.dimension
))
697 se
->expr
= build_fold_indirect_ref_loc (input_location
,
704 /* For character variables, also get the length. */
705 if (sym
->ts
.type
== BT_CHARACTER
)
707 /* If the character length of an entry isn't set, get the length from
708 the master function instead. */
709 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
710 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
712 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
713 gcc_assert (se
->string_length
);
721 /* Return the descriptor if that's what we want and this is an array
722 section reference. */
723 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
725 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
726 /* Return the descriptor for array pointers and allocations. */
728 && ref
->next
== NULL
&& (se
->descriptor_only
))
731 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
732 /* Return a pointer to an element. */
736 if (ref
->u
.c
.sym
->attr
.extension
)
737 conv_parent_component_references (se
, ref
);
739 gfc_conv_component_ref (se
, ref
);
743 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
744 expr
->symtree
->name
, &expr
->where
);
753 /* Pointer assignment, allocation or pass by reference. Arrays are handled
755 if (se
->want_pointer
)
757 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
758 gfc_conv_string_parameter (se
);
760 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
765 /* Unary ops are easy... Or they would be if ! was a valid op. */
768 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
773 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
774 /* Initialize the operand. */
775 gfc_init_se (&operand
, se
);
776 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
777 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
779 type
= gfc_typenode_for_spec (&expr
->ts
);
781 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
782 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
783 All other unary operators have an equivalent GIMPLE unary operator. */
784 if (code
== TRUTH_NOT_EXPR
)
785 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
786 build_int_cst (type
, 0));
788 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
792 /* Expand power operator to optimal multiplications when a value is raised
793 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
794 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
795 Programming", 3rd Edition, 1998. */
797 /* This code is mostly duplicated from expand_powi in the backend.
798 We establish the "optimal power tree" lookup table with the defined size.
799 The items in the table are the exponents used to calculate the index
800 exponents. Any integer n less than the value can get an "addition chain",
801 with the first node being one. */
802 #define POWI_TABLE_SIZE 256
804 /* The table is from builtins.c. */
805 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
807 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
808 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
809 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
810 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
811 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
812 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
813 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
814 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
815 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
816 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
817 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
818 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
819 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
820 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
821 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
822 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
823 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
824 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
825 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
826 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
827 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
828 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
829 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
830 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
831 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
832 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
833 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
834 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
835 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
836 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
837 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
838 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
841 /* If n is larger than lookup table's max index, we use the "window
843 #define POWI_WINDOW_SIZE 3
845 /* Recursive function to expand the power operator. The temporary
846 values are put in tmpvar. The function returns tmpvar[1] ** n. */
848 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
855 if (n
< POWI_TABLE_SIZE
)
860 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
861 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
865 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
866 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
867 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
871 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
875 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
876 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
878 if (n
< POWI_TABLE_SIZE
)
885 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
886 return 1. Else return 0 and a call to runtime library functions
887 will have to be built. */
889 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
894 tree vartmp
[POWI_TABLE_SIZE
];
896 unsigned HOST_WIDE_INT n
;
899 /* If exponent is too large, we won't expand it anyway, so don't bother
900 with large integer values. */
901 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
904 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
905 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
906 of the asymmetric range of the integer type. */
907 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
909 type
= TREE_TYPE (lhs
);
910 sgn
= tree_int_cst_sgn (rhs
);
912 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
913 || optimize_size
) && (m
> 2 || m
< -1))
919 se
->expr
= gfc_build_const (type
, integer_one_node
);
923 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
924 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
926 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
927 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
928 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
929 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
932 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
935 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
936 boolean_type_node
, tmp
, cond
);
937 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
938 tmp
, build_int_cst (type
, 1),
939 build_int_cst (type
, 0));
943 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
944 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
945 build_int_cst (type
, -1),
946 build_int_cst (type
, 0));
947 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
948 cond
, build_int_cst (type
, 1), tmp
);
952 memset (vartmp
, 0, sizeof (vartmp
));
956 tmp
= gfc_build_const (type
, integer_one_node
);
957 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
961 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
967 /* Power op (**). Constant integer exponent has special handling. */
970 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
972 tree gfc_int4_type_node
;
979 gfc_init_se (&lse
, se
);
980 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
981 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
982 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
984 gfc_init_se (&rse
, se
);
985 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
986 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
988 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
989 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
990 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
993 gfc_int4_type_node
= gfc_get_int_type (4);
995 kind
= expr
->value
.op
.op1
->ts
.kind
;
996 switch (expr
->value
.op
.op2
->ts
.type
)
999 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1004 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1026 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
1027 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1052 switch (expr
->value
.op
.op1
->ts
.type
)
1055 if (kind
== 3) /* Case 16 was not handled properly above. */
1057 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1061 /* Use builtins for real ** int4. */
1067 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1071 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1075 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1079 /* Use the __builtin_powil() only if real(kind=16) is
1080 actually the C long double type. */
1081 if (!gfc_real16_is_float128
)
1082 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1090 /* If we don't have a good builtin for this, go for the
1091 library function. */
1093 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1097 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1106 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
1110 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
1118 se
->expr
= build_call_expr_loc (input_location
,
1119 fndecl
, 2, lse
.expr
, rse
.expr
);
1123 /* Generate code to allocate a string temporary. */
1126 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1131 if (gfc_can_put_var_on_stack (len
))
1133 /* Create a temporary variable to hold the result. */
1134 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1135 gfc_charlen_type_node
, len
,
1136 build_int_cst (gfc_charlen_type_node
, 1));
1137 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1139 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1140 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1142 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1144 var
= gfc_create_var (tmp
, "str");
1145 var
= gfc_build_addr_expr (type
, var
);
1149 /* Allocate a temporary to hold the result. */
1150 var
= gfc_create_var (type
, "pstr");
1151 tmp
= gfc_call_malloc (&se
->pre
, type
,
1152 fold_build2_loc (input_location
, MULT_EXPR
,
1153 TREE_TYPE (len
), len
,
1154 fold_convert (TREE_TYPE (len
),
1155 TYPE_SIZE (type
))));
1156 gfc_add_modify (&se
->pre
, var
, tmp
);
1158 /* Free the temporary afterwards. */
1159 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1160 gfc_add_expr_to_block (&se
->post
, tmp
);
1167 /* Handle a string concatenation operation. A temporary will be allocated to
1171 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1174 tree len
, type
, var
, tmp
, fndecl
;
1176 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1177 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1178 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1180 gfc_init_se (&lse
, se
);
1181 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1182 gfc_conv_string_parameter (&lse
);
1183 gfc_init_se (&rse
, se
);
1184 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1185 gfc_conv_string_parameter (&rse
);
1187 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1188 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1190 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1191 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1192 if (len
== NULL_TREE
)
1194 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
1195 TREE_TYPE (lse
.string_length
),
1196 lse
.string_length
, rse
.string_length
);
1199 type
= build_pointer_type (type
);
1201 var
= gfc_conv_string_tmp (se
, type
, len
);
1203 /* Do the actual concatenation. */
1204 if (expr
->ts
.kind
== 1)
1205 fndecl
= gfor_fndecl_concat_string
;
1206 else if (expr
->ts
.kind
== 4)
1207 fndecl
= gfor_fndecl_concat_string_char4
;
1211 tmp
= build_call_expr_loc (input_location
,
1212 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1213 rse
.string_length
, rse
.expr
);
1214 gfc_add_expr_to_block (&se
->pre
, tmp
);
1216 /* Add the cleanup for the operands. */
1217 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1218 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1221 se
->string_length
= len
;
1224 /* Translates an op expression. Common (binary) cases are handled by this
1225 function, others are passed on. Recursion is used in either case.
1226 We use the fact that (op1.ts == op2.ts) (except for the power
1228 Operators need no special handling for scalarized expressions as long as
1229 they call gfc_conv_simple_val to get their operands.
1230 Character strings get special handling. */
1233 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1235 enum tree_code code
;
1244 switch (expr
->value
.op
.op
)
1246 case INTRINSIC_PARENTHESES
:
1247 if ((expr
->ts
.type
== BT_REAL
1248 || expr
->ts
.type
== BT_COMPLEX
)
1249 && gfc_option
.flag_protect_parens
)
1251 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1252 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1257 case INTRINSIC_UPLUS
:
1258 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1261 case INTRINSIC_UMINUS
:
1262 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1266 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1269 case INTRINSIC_PLUS
:
1273 case INTRINSIC_MINUS
:
1277 case INTRINSIC_TIMES
:
1281 case INTRINSIC_DIVIDE
:
1282 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1283 an integer, we must round towards zero, so we use a
1285 if (expr
->ts
.type
== BT_INTEGER
)
1286 code
= TRUNC_DIV_EXPR
;
1291 case INTRINSIC_POWER
:
1292 gfc_conv_power_op (se
, expr
);
1295 case INTRINSIC_CONCAT
:
1296 gfc_conv_concat_op (se
, expr
);
1300 code
= TRUTH_ANDIF_EXPR
;
1305 code
= TRUTH_ORIF_EXPR
;
1309 /* EQV and NEQV only work on logicals, but since we represent them
1310 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1312 case INTRINSIC_EQ_OS
:
1320 case INTRINSIC_NE_OS
:
1321 case INTRINSIC_NEQV
:
1328 case INTRINSIC_GT_OS
:
1335 case INTRINSIC_GE_OS
:
1342 case INTRINSIC_LT_OS
:
1349 case INTRINSIC_LE_OS
:
1355 case INTRINSIC_USER
:
1356 case INTRINSIC_ASSIGN
:
1357 /* These should be converted into function calls by the frontend. */
1361 fatal_error ("Unknown intrinsic op");
1365 /* The only exception to this is **, which is handled separately anyway. */
1366 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1368 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1372 gfc_init_se (&lse
, se
);
1373 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1374 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1377 gfc_init_se (&rse
, se
);
1378 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1379 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1383 gfc_conv_string_parameter (&lse
);
1384 gfc_conv_string_parameter (&rse
);
1386 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1387 rse
.string_length
, rse
.expr
,
1388 expr
->value
.op
.op1
->ts
.kind
,
1390 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1391 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1394 type
= gfc_typenode_for_spec (&expr
->ts
);
1398 /* The result of logical ops is always boolean_type_node. */
1399 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
1400 lse
.expr
, rse
.expr
);
1401 se
->expr
= convert (type
, tmp
);
1404 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
1406 /* Add the post blocks. */
1407 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1408 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1411 /* If a string's length is one, we convert it to a single character. */
1414 gfc_string_to_single_character (tree len
, tree str
, int kind
)
1416 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1418 if (!INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0)
1421 if (TREE_INT_CST_LOW (len
) == 1)
1423 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1424 return build_fold_indirect_ref_loc (input_location
, str
);
1428 && TREE_CODE (str
) == ADDR_EXPR
1429 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1430 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1431 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1432 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1433 && TREE_INT_CST_LOW (len
) > 1
1434 && TREE_INT_CST_LOW (len
)
1435 == (unsigned HOST_WIDE_INT
)
1436 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1438 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
1439 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
1440 if (TREE_CODE (ret
) == INTEGER_CST
)
1442 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1443 int i
, length
= TREE_STRING_LENGTH (string_cst
);
1444 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1446 for (i
= 1; i
< length
; i
++)
1459 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1462 if (sym
->backend_decl
)
1464 /* This becomes the nominal_type in
1465 function.c:assign_parm_find_data_types. */
1466 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1467 /* This becomes the passed_type in
1468 function.c:assign_parm_find_data_types. C promotes char to
1469 integer for argument passing. */
1470 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1472 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1477 /* If we have a constant character expression, make it into an
1479 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1484 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1485 (int)(*expr
)->value
.character
.string
[0]);
1486 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1488 /* The expr needs to be compatible with a C int. If the
1489 conversion fails, then the 2 causes an ICE. */
1490 ts
.type
= BT_INTEGER
;
1491 ts
.kind
= gfc_c_int_kind
;
1492 gfc_convert_type (*expr
, &ts
, 2);
1495 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1497 if ((*expr
)->ref
== NULL
)
1499 se
->expr
= gfc_string_to_single_character
1500 (build_int_cst (integer_type_node
, 1),
1501 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1503 ((*expr
)->symtree
->n
.sym
)),
1508 gfc_conv_variable (se
, *expr
);
1509 se
->expr
= gfc_string_to_single_character
1510 (build_int_cst (integer_type_node
, 1),
1511 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1519 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1520 if STR is a string literal, otherwise return -1. */
1523 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
1526 && TREE_CODE (str
) == ADDR_EXPR
1527 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1528 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1529 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1530 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1531 && TREE_INT_CST_LOW (len
) >= 1
1532 && TREE_INT_CST_LOW (len
)
1533 == (unsigned HOST_WIDE_INT
)
1534 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1536 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
1537 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
1538 if (TREE_CODE (folded
) == INTEGER_CST
)
1540 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1541 int length
= TREE_STRING_LENGTH (string_cst
);
1542 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1544 for (; length
> 0; length
--)
1545 if (ptr
[length
- 1] != ' ')
1554 /* Compare two strings. If they are all single characters, the result is the
1555 subtraction of them. Otherwise, we build a library call. */
1558 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
1559 enum tree_code code
)
1565 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1566 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1568 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
1569 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
1571 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1573 /* Deal with single character specially. */
1574 sc1
= fold_convert (integer_type_node
, sc1
);
1575 sc2
= fold_convert (integer_type_node
, sc2
);
1576 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
1580 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
1582 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
1584 /* If one string is a string literal with LEN_TRIM longer
1585 than the length of the second string, the strings
1587 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
1588 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
1589 return integer_one_node
;
1590 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
1591 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
1592 return integer_one_node
;
1595 /* Build a call for the comparison. */
1597 fndecl
= gfor_fndecl_compare_string
;
1599 fndecl
= gfor_fndecl_compare_string_char4
;
1603 return build_call_expr_loc (input_location
, fndecl
, 4,
1604 len1
, str1
, len2
, str2
);
1608 /* Return the backend_decl for a procedure pointer component. */
1611 get_proc_ptr_comp (gfc_expr
*e
)
1617 gfc_init_se (&comp_se
, NULL
);
1618 e2
= gfc_copy_expr (e
);
1619 /* We have to restore the expr type later so that gfc_free_expr frees
1620 the exact same thing that was allocated.
1621 TODO: This is ugly. */
1622 old_type
= e2
->expr_type
;
1623 e2
->expr_type
= EXPR_VARIABLE
;
1624 gfc_conv_expr (&comp_se
, e2
);
1625 e2
->expr_type
= old_type
;
1627 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1632 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1636 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1637 tmp
= get_proc_ptr_comp (expr
);
1638 else if (sym
->attr
.dummy
)
1640 tmp
= gfc_get_symbol_decl (sym
);
1641 if (sym
->attr
.proc_pointer
)
1642 tmp
= build_fold_indirect_ref_loc (input_location
,
1644 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1645 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1649 if (!sym
->backend_decl
)
1650 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1652 tmp
= sym
->backend_decl
;
1654 if (sym
->attr
.cray_pointee
)
1656 /* TODO - make the cray pointee a pointer to a procedure,
1657 assign the pointer to it and use it for the call. This
1659 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1660 gfc_get_symbol_decl (sym
->cp_pointer
));
1661 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1664 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1666 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1667 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1674 /* Initialize MAPPING. */
1677 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1679 mapping
->syms
= NULL
;
1680 mapping
->charlens
= NULL
;
1684 /* Free all memory held by MAPPING (but not MAPPING itself). */
1687 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1689 gfc_interface_sym_mapping
*sym
;
1690 gfc_interface_sym_mapping
*nextsym
;
1692 gfc_charlen
*nextcl
;
1694 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1696 nextsym
= sym
->next
;
1697 sym
->new_sym
->n
.sym
->formal
= NULL
;
1698 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1699 gfc_free_expr (sym
->expr
);
1700 gfc_free (sym
->new_sym
);
1703 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1706 gfc_free_expr (cl
->length
);
1712 /* Return a copy of gfc_charlen CL. Add the returned structure to
1713 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1715 static gfc_charlen
*
1716 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1719 gfc_charlen
*new_charlen
;
1721 new_charlen
= gfc_get_charlen ();
1722 new_charlen
->next
= mapping
->charlens
;
1723 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1725 mapping
->charlens
= new_charlen
;
1730 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1731 array variable that can be used as the actual argument for dummy
1732 argument SYM. Add any initialization code to BLOCK. PACKED is as
1733 for gfc_get_nodesc_array_type and DATA points to the first element
1734 in the passed array. */
1737 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1738 gfc_packed packed
, tree data
)
1743 type
= gfc_typenode_for_spec (&sym
->ts
);
1744 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
1745 !sym
->attr
.target
&& !sym
->attr
.pointer
1746 && !sym
->attr
.proc_pointer
);
1748 var
= gfc_create_var (type
, "ifm");
1749 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1755 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1756 and offset of descriptorless array type TYPE given that it has the same
1757 size as DESC. Add any set-up code to BLOCK. */
1760 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1767 offset
= gfc_index_zero_node
;
1768 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1770 dim
= gfc_rank_cst
[n
];
1771 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1772 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1774 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1775 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1776 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1777 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1779 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1781 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1782 gfc_array_index_type
,
1783 gfc_conv_descriptor_ubound_get (desc
, dim
),
1784 gfc_conv_descriptor_lbound_get (desc
, dim
));
1785 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1786 gfc_array_index_type
,
1787 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
1788 tmp
= gfc_evaluate_now (tmp
, block
);
1789 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1791 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1792 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1793 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1794 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1795 gfc_array_index_type
, offset
, tmp
);
1797 offset
= gfc_evaluate_now (offset
, block
);
1798 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1802 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1803 in SE. The caller may still use se->expr and se->string_length after
1804 calling this function. */
1807 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1808 gfc_symbol
* sym
, gfc_se
* se
,
1811 gfc_interface_sym_mapping
*sm
;
1815 gfc_symbol
*new_sym
;
1817 gfc_symtree
*new_symtree
;
1819 /* Create a new symbol to represent the actual argument. */
1820 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1821 new_sym
->ts
= sym
->ts
;
1822 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1823 new_sym
->attr
.referenced
= 1;
1824 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1825 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
1826 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
1827 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1828 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1829 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1830 new_sym
->attr
.function
= sym
->attr
.function
;
1832 /* Ensure that the interface is available and that
1833 descriptors are passed for array actual arguments. */
1834 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1836 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1837 new_sym
->attr
.always_explicit
1838 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1841 /* Create a fake symtree for it. */
1843 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1844 new_symtree
->n
.sym
= new_sym
;
1845 gcc_assert (new_symtree
== root
);
1847 /* Create a dummy->actual mapping. */
1848 sm
= XCNEW (gfc_interface_sym_mapping
);
1849 sm
->next
= mapping
->syms
;
1851 sm
->new_sym
= new_symtree
;
1852 sm
->expr
= gfc_copy_expr (expr
);
1855 /* Stabilize the argument's value. */
1856 if (!sym
->attr
.function
&& se
)
1857 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1859 if (sym
->ts
.type
== BT_CHARACTER
)
1861 /* Create a copy of the dummy argument's length. */
1862 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1863 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1865 /* If the length is specified as "*", record the length that
1866 the caller is passing. We should use the callee's length
1867 in all other cases. */
1868 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1870 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1871 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1878 /* Use the passed value as-is if the argument is a function. */
1879 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1882 /* If the argument is either a string or a pointer to a string,
1883 convert it to a boundless character type. */
1884 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1886 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1887 tmp
= build_pointer_type (tmp
);
1888 if (sym
->attr
.pointer
)
1889 value
= build_fold_indirect_ref_loc (input_location
,
1893 value
= fold_convert (tmp
, value
);
1896 /* If the argument is a scalar, a pointer to an array or an allocatable,
1898 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1899 value
= build_fold_indirect_ref_loc (input_location
,
1902 /* For character(*), use the actual argument's descriptor. */
1903 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1904 value
= build_fold_indirect_ref_loc (input_location
,
1907 /* If the argument is an array descriptor, use it to determine
1908 information about the actual argument's shape. */
1909 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1910 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1912 /* Get the actual argument's descriptor. */
1913 desc
= build_fold_indirect_ref_loc (input_location
,
1916 /* Create the replacement variable. */
1917 tmp
= gfc_conv_descriptor_data_get (desc
);
1918 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1921 /* Use DESC to work out the upper bounds, strides and offset. */
1922 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1925 /* Otherwise we have a packed array. */
1926 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1927 PACKED_FULL
, se
->expr
);
1929 new_sym
->backend_decl
= value
;
1933 /* Called once all dummy argument mappings have been added to MAPPING,
1934 but before the mapping is used to evaluate expressions. Pre-evaluate
1935 the length of each argument, adding any initialization code to PRE and
1936 any finalization code to POST. */
1939 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1940 stmtblock_t
* pre
, stmtblock_t
* post
)
1942 gfc_interface_sym_mapping
*sym
;
1946 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1947 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1948 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1950 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1951 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1952 gfc_init_se (&se
, NULL
);
1953 gfc_conv_expr (&se
, expr
);
1954 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1955 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1956 gfc_add_block_to_block (pre
, &se
.pre
);
1957 gfc_add_block_to_block (post
, &se
.post
);
1959 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1964 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1968 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1969 gfc_constructor_base base
)
1972 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1974 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1977 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1978 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1979 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1985 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1989 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1994 for (; ref
; ref
= ref
->next
)
1998 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2000 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2001 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2002 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2004 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2011 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2012 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2018 /* Convert intrinsic function calls into result expressions. */
2021 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2029 arg1
= expr
->value
.function
.actual
->expr
;
2030 if (expr
->value
.function
.actual
->next
)
2031 arg2
= expr
->value
.function
.actual
->next
->expr
;
2035 sym
= arg1
->symtree
->n
.sym
;
2037 if (sym
->attr
.dummy
)
2042 switch (expr
->value
.function
.isym
->id
)
2045 /* TODO figure out why this condition is necessary. */
2046 if (sym
->attr
.function
2047 && (arg1
->ts
.u
.cl
->length
== NULL
2048 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2049 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2052 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2056 if (!sym
->as
|| sym
->as
->rank
== 0)
2059 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2061 dup
= mpz_get_si (arg2
->value
.integer
);
2066 dup
= sym
->as
->rank
;
2070 for (; d
< dup
; d
++)
2074 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2076 gfc_free_expr (new_expr
);
2080 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
2081 gfc_get_int_expr (gfc_default_integer_kind
,
2083 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2085 new_expr
= gfc_multiply (new_expr
, tmp
);
2091 case GFC_ISYM_LBOUND
:
2092 case GFC_ISYM_UBOUND
:
2093 /* TODO These implementations of lbound and ubound do not limit if
2094 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2096 if (!sym
->as
|| sym
->as
->rank
== 0)
2099 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2100 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2102 /* TODO: If the need arises, this could produce an array of
2106 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2108 if (sym
->as
->lower
[d
])
2109 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2113 if (sym
->as
->upper
[d
])
2114 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2122 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2126 gfc_replace_expr (expr
, new_expr
);
2132 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2133 gfc_interface_mapping
* mapping
)
2135 gfc_formal_arglist
*f
;
2136 gfc_actual_arglist
*actual
;
2138 actual
= expr
->value
.function
.actual
;
2139 f
= map_expr
->symtree
->n
.sym
->formal
;
2141 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2146 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2149 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2154 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2156 for (d
= 0; d
< as
->rank
; d
++)
2158 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2159 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2162 expr
->value
.function
.esym
->as
= as
;
2165 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2167 expr
->value
.function
.esym
->ts
.u
.cl
->length
2168 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2170 gfc_apply_interface_mapping_to_expr (mapping
,
2171 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2176 /* EXPR is a copy of an expression that appeared in the interface
2177 associated with MAPPING. Walk it recursively looking for references to
2178 dummy arguments that MAPPING maps to actual arguments. Replace each such
2179 reference with a reference to the associated actual argument. */
2182 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2185 gfc_interface_sym_mapping
*sym
;
2186 gfc_actual_arglist
*actual
;
2191 /* Copying an expression does not copy its length, so do that here. */
2192 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2194 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2195 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2198 /* Apply the mapping to any references. */
2199 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2201 /* ...and to the expression's symbol, if it has one. */
2202 /* TODO Find out why the condition on expr->symtree had to be moved into
2203 the loop rather than being outside it, as originally. */
2204 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2205 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2207 if (sym
->new_sym
->n
.sym
->backend_decl
)
2208 expr
->symtree
= sym
->new_sym
;
2210 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2213 /* ...and to subexpressions in expr->value. */
2214 switch (expr
->expr_type
)
2219 case EXPR_SUBSTRING
:
2223 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2224 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2228 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2229 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2231 if (expr
->value
.function
.esym
== NULL
2232 && expr
->value
.function
.isym
!= NULL
2233 && expr
->value
.function
.actual
->expr
->symtree
2234 && gfc_map_intrinsic_function (expr
, mapping
))
2237 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2238 if (sym
->old
== expr
->value
.function
.esym
)
2240 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2241 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2242 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2247 case EXPR_STRUCTURE
:
2248 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2261 /* Evaluate interface expression EXPR using MAPPING. Store the result
2265 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2266 gfc_se
* se
, gfc_expr
* expr
)
2268 expr
= gfc_copy_expr (expr
);
2269 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2270 gfc_conv_expr (se
, expr
);
2271 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2272 gfc_free_expr (expr
);
2276 /* Returns a reference to a temporary array into which a component of
2277 an actual argument derived type array is copied and then returned
2278 after the function call. */
2280 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2281 sym_intent intent
, bool formal_ptr
)
2299 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2301 gfc_init_se (&lse
, NULL
);
2302 gfc_init_se (&rse
, NULL
);
2304 /* Walk the argument expression. */
2305 rss
= gfc_walk_expr (expr
);
2307 gcc_assert (rss
!= gfc_ss_terminator
);
2309 /* Initialize the scalarizer. */
2310 gfc_init_loopinfo (&loop
);
2311 gfc_add_ss_to_loop (&loop
, rss
);
2313 /* Calculate the bounds of the scalarization. */
2314 gfc_conv_ss_startstride (&loop
);
2316 /* Build an ss for the temporary. */
2317 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2318 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2320 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2321 if (GFC_ARRAY_TYPE_P (base_type
)
2322 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2323 base_type
= gfc_get_element_type (base_type
);
2325 loop
.temp_ss
= gfc_get_ss ();;
2326 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2327 loop
.temp_ss
->data
.temp
.type
= base_type
;
2329 if (expr
->ts
.type
== BT_CHARACTER
)
2330 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2332 loop
.temp_ss
->string_length
= NULL
;
2334 parmse
->string_length
= loop
.temp_ss
->string_length
;
2335 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2336 loop
.temp_ss
->next
= gfc_ss_terminator
;
2338 /* Associate the SS with the loop. */
2339 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2341 /* Setup the scalarizing loops. */
2342 gfc_conv_loop_setup (&loop
, &expr
->where
);
2344 /* Pass the temporary descriptor back to the caller. */
2345 info
= &loop
.temp_ss
->data
.info
;
2346 parmse
->expr
= info
->descriptor
;
2348 /* Setup the gfc_se structures. */
2349 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2350 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2353 lse
.ss
= loop
.temp_ss
;
2354 gfc_mark_ss_chain_used (rss
, 1);
2355 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2357 /* Start the scalarized loop body. */
2358 gfc_start_scalarized_body (&loop
, &body
);
2360 /* Translate the expression. */
2361 gfc_conv_expr (&rse
, expr
);
2363 gfc_conv_tmp_array_ref (&lse
);
2365 if (intent
!= INTENT_OUT
)
2367 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
2368 gfc_add_expr_to_block (&body
, tmp
);
2369 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2370 gfc_trans_scalarizing_loops (&loop
, &body
);
2374 /* Make sure that the temporary declaration survives by merging
2375 all the loop declarations into the current context. */
2376 for (n
= 0; n
< loop
.dimen
; n
++)
2378 gfc_merge_block_scope (&body
);
2379 body
= loop
.code
[loop
.order
[n
]];
2381 gfc_merge_block_scope (&body
);
2384 /* Add the post block after the second loop, so that any
2385 freeing of allocated memory is done at the right time. */
2386 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2388 /**********Copy the temporary back again.*********/
2390 gfc_init_se (&lse
, NULL
);
2391 gfc_init_se (&rse
, NULL
);
2393 /* Walk the argument expression. */
2394 lss
= gfc_walk_expr (expr
);
2395 rse
.ss
= loop
.temp_ss
;
2398 /* Initialize the scalarizer. */
2399 gfc_init_loopinfo (&loop2
);
2400 gfc_add_ss_to_loop (&loop2
, lss
);
2402 /* Calculate the bounds of the scalarization. */
2403 gfc_conv_ss_startstride (&loop2
);
2405 /* Setup the scalarizing loops. */
2406 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2408 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2409 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2411 gfc_mark_ss_chain_used (lss
, 1);
2412 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2414 /* Declare the variable to hold the temporary offset and start the
2415 scalarized loop body. */
2416 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2417 gfc_start_scalarized_body (&loop2
, &body
);
2419 /* Build the offsets for the temporary from the loop variables. The
2420 temporary array has lbounds of zero and strides of one in all
2421 dimensions, so this is very simple. The offset is only computed
2422 outside the innermost loop, so the overall transfer could be
2423 optimized further. */
2424 info
= &rse
.ss
->data
.info
;
2425 dimen
= info
->dimen
;
2427 tmp_index
= gfc_index_zero_node
;
2428 for (n
= dimen
- 1; n
> 0; n
--)
2431 tmp
= rse
.loop
->loopvar
[n
];
2432 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2433 tmp
, rse
.loop
->from
[n
]);
2434 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2437 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
2438 gfc_array_index_type
,
2439 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2440 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
2441 gfc_array_index_type
,
2442 tmp_str
, gfc_index_one_node
);
2444 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
2445 gfc_array_index_type
, tmp
, tmp_str
);
2448 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2449 gfc_array_index_type
,
2450 tmp_index
, rse
.loop
->from
[0]);
2451 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2453 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2454 gfc_array_index_type
,
2455 rse
.loop
->loopvar
[0], offset
);
2457 /* Now use the offset for the reference. */
2458 tmp
= build_fold_indirect_ref_loc (input_location
,
2460 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2462 if (expr
->ts
.type
== BT_CHARACTER
)
2463 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2465 gfc_conv_expr (&lse
, expr
);
2467 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2469 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
2470 gfc_add_expr_to_block (&body
, tmp
);
2472 /* Generate the copying loops. */
2473 gfc_trans_scalarizing_loops (&loop2
, &body
);
2475 /* Wrap the whole thing up by adding the second loop to the post-block
2476 and following it by the post-block of the first loop. In this way,
2477 if the temporary needs freeing, it is done after use! */
2478 if (intent
!= INTENT_IN
)
2480 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2481 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2484 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2486 gfc_cleanup_loop (&loop
);
2487 gfc_cleanup_loop (&loop2
);
2489 /* Pass the string length to the argument expression. */
2490 if (expr
->ts
.type
== BT_CHARACTER
)
2491 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2493 /* Determine the offset for pointer formal arguments and set the
2497 size
= gfc_index_one_node
;
2498 offset
= gfc_index_zero_node
;
2499 for (n
= 0; n
< dimen
; n
++)
2501 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2503 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2504 gfc_array_index_type
, tmp
,
2505 gfc_index_one_node
);
2506 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2510 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2513 gfc_index_one_node
);
2514 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2515 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2516 gfc_array_index_type
,
2518 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2519 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2520 gfc_array_index_type
,
2521 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2522 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2523 gfc_array_index_type
,
2524 tmp
, gfc_index_one_node
);
2525 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2526 gfc_array_index_type
, size
, tmp
);
2529 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2533 /* We want either the address for the data or the address of the descriptor,
2534 depending on the mode of passing array arguments. */
2536 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2538 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2544 /* Generate the code for argument list functions. */
2547 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2549 /* Pass by value for g77 %VAL(arg), pass the address
2550 indirectly for %LOC, else by reference. Thus %REF
2551 is a "do-nothing" and %LOC is the same as an F95
2553 if (strncmp (name
, "%VAL", 4) == 0)
2554 gfc_conv_expr (se
, expr
);
2555 else if (strncmp (name
, "%LOC", 4) == 0)
2557 gfc_conv_expr_reference (se
, expr
);
2558 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2560 else if (strncmp (name
, "%REF", 4) == 0)
2561 gfc_conv_expr_reference (se
, expr
);
2563 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2567 /* Takes a derived type expression and returns the address of a temporary
2568 class object of the 'declared' type. */
2570 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
2571 gfc_typespec class_ts
)
2575 gfc_symbol
*declared
= class_ts
.u
.derived
;
2581 /* The derived type needs to be converted to a temporary
2583 tmp
= gfc_typenode_for_spec (&class_ts
);
2584 var
= gfc_create_var (tmp
, "class");
2587 cmp
= gfc_find_component (declared
, "_vptr", true, true);
2588 ctree
= fold_build3_loc (input_location
, COMPONENT_REF
,
2589 TREE_TYPE (cmp
->backend_decl
),
2590 var
, cmp
->backend_decl
, NULL_TREE
);
2592 /* Remember the vtab corresponds to the derived type
2593 not to the class declared type. */
2594 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
2596 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
2597 gfc_add_modify (&parmse
->pre
, ctree
,
2598 fold_convert (TREE_TYPE (ctree
), tmp
));
2600 /* Now set the data field. */
2601 cmp
= gfc_find_component (declared
, "_data", true, true);
2602 ctree
= fold_build3_loc (input_location
, COMPONENT_REF
,
2603 TREE_TYPE (cmp
->backend_decl
),
2604 var
, cmp
->backend_decl
, NULL_TREE
);
2605 ss
= gfc_walk_expr (e
);
2606 if (ss
== gfc_ss_terminator
)
2609 gfc_conv_expr_reference (parmse
, e
);
2610 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
2611 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
2616 gfc_conv_expr (parmse
, e
);
2617 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
2620 /* Pass the address of the class object. */
2621 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2625 /* The following routine generates code for the intrinsic
2626 procedures from the ISO_C_BINDING module:
2628 * C_FUNLOC (function)
2629 * C_F_POINTER (subroutine)
2630 * C_F_PROCPOINTER (subroutine)
2631 * C_ASSOCIATED (function)
2632 One exception which is not handled here is C_F_POINTER with non-scalar
2633 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2636 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2637 gfc_actual_arglist
* arg
)
2642 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2644 if (arg
->expr
->rank
== 0)
2645 gfc_conv_expr_reference (se
, arg
->expr
);
2649 /* This is really the actual arg because no formal arglist is
2650 created for C_LOC. */
2651 fsym
= arg
->expr
->symtree
->n
.sym
;
2653 /* We should want it to do g77 calling convention. */
2655 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2656 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2657 f
= f
|| !sym
->attr
.always_explicit
;
2659 argss
= gfc_walk_expr (arg
->expr
);
2660 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2664 /* TODO -- the following two lines shouldn't be necessary, but if
2665 they're removed, a bug is exposed later in the code path.
2666 This workaround was thus introduced, but will have to be
2667 removed; please see PR 35150 for details about the issue. */
2668 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2669 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2673 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2675 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2676 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2677 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2678 gfc_conv_expr_reference (se
, arg
->expr
);
2682 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2683 && arg
->next
->expr
->rank
== 0)
2684 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2686 /* Convert c_f_pointer if fptr is a scalar
2687 and convert c_f_procpointer. */
2691 gfc_init_se (&cptrse
, NULL
);
2692 gfc_conv_expr (&cptrse
, arg
->expr
);
2693 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2694 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2696 gfc_init_se (&fptrse
, NULL
);
2697 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2698 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2699 fptrse
.want_pointer
= 1;
2701 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2702 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2703 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2705 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2706 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2707 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2710 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2711 TREE_TYPE (fptrse
.expr
),
2713 fold_convert (TREE_TYPE (fptrse
.expr
),
2718 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2723 /* Build the addr_expr for the first argument. The argument is
2724 already an *address* so we don't need to set want_pointer in
2726 gfc_init_se (&arg1se
, NULL
);
2727 gfc_conv_expr (&arg1se
, arg
->expr
);
2728 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2729 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2731 /* See if we were given two arguments. */
2732 if (arg
->next
== NULL
)
2733 /* Only given one arg so generate a null and do a
2734 not-equal comparison against the first arg. */
2735 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2737 fold_convert (TREE_TYPE (arg1se
.expr
),
2738 null_pointer_node
));
2744 /* Given two arguments so build the arg2se from second arg. */
2745 gfc_init_se (&arg2se
, NULL
);
2746 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2747 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2748 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2750 /* Generate test to compare that the two args are equal. */
2751 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2752 arg1se
.expr
, arg2se
.expr
);
2753 /* Generate test to ensure that the first arg is not null. */
2754 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
2756 arg1se
.expr
, null_pointer_node
);
2758 /* Finally, the generated test must check that both arg1 is not
2759 NULL and that it is equal to the second arg. */
2760 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2762 not_null_expr
, eq_expr
);
2768 /* Nothing was done. */
2772 /* Generate code for a procedure call. Note can return se->post != NULL.
2773 If se->direct_byref is set then se->expr contains the return parameter.
2774 Return nonzero, if the call has alternate specifiers.
2775 'expr' is only needed for procedure pointer components. */
2778 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2779 gfc_actual_arglist
* args
, gfc_expr
* expr
,
2780 VEC(tree
,gc
) *append_args
)
2782 gfc_interface_mapping mapping
;
2783 VEC(tree
,gc
) *arglist
;
2784 VEC(tree
,gc
) *retargs
;
2795 VEC(tree
,gc
) *stringargs
;
2797 gfc_formal_arglist
*formal
;
2798 gfc_actual_arglist
*arg
;
2799 int has_alternate_specifier
= 0;
2800 bool need_interface_mapping
;
2807 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2808 gfc_component
*comp
= NULL
;
2818 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2819 && conv_isocbinding_procedure (se
, sym
, args
))
2822 gfc_is_proc_ptr_comp (expr
, &comp
);
2826 if (!sym
->attr
.elemental
)
2828 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2829 if (se
->ss
->useflags
)
2831 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2832 && sym
->result
->attr
.dimension
)
2833 || (comp
&& comp
->attr
.dimension
));
2834 gcc_assert (se
->loop
!= NULL
);
2836 /* Access the previously obtained result. */
2837 gfc_conv_tmp_array_ref (se
);
2841 info
= &se
->ss
->data
.info
;
2846 gfc_init_block (&post
);
2847 gfc_init_interface_mapping (&mapping
);
2850 formal
= sym
->formal
;
2851 need_interface_mapping
= sym
->attr
.dimension
||
2852 (sym
->ts
.type
== BT_CHARACTER
2853 && sym
->ts
.u
.cl
->length
2854 && sym
->ts
.u
.cl
->length
->expr_type
2859 formal
= comp
->formal
;
2860 need_interface_mapping
= comp
->attr
.dimension
||
2861 (comp
->ts
.type
== BT_CHARACTER
2862 && comp
->ts
.u
.cl
->length
2863 && comp
->ts
.u
.cl
->length
->expr_type
2867 /* Evaluate the arguments. */
2868 for (arg
= args
; arg
!= NULL
;
2869 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2872 fsym
= formal
? formal
->sym
: NULL
;
2873 parm_kind
= MISSING
;
2877 if (se
->ignore_optional
)
2879 /* Some intrinsics have already been resolved to the correct
2883 else if (arg
->label
)
2885 has_alternate_specifier
= 1;
2890 /* Pass a NULL pointer for an absent arg. */
2891 gfc_init_se (&parmse
, NULL
);
2892 parmse
.expr
= null_pointer_node
;
2893 if (arg
->missing_arg_type
== BT_CHARACTER
)
2894 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2897 else if (arg
->expr
->expr_type
== EXPR_NULL
&& fsym
&& !fsym
->attr
.pointer
)
2899 /* Pass a NULL pointer to denote an absent arg. */
2900 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
);
2901 gfc_init_se (&parmse
, NULL
);
2902 parmse
.expr
= null_pointer_node
;
2903 if (arg
->missing_arg_type
== BT_CHARACTER
)
2904 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2906 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2907 && e
->ts
.type
== BT_DERIVED
)
2909 /* The derived type needs to be converted to a temporary
2911 gfc_init_se (&parmse
, se
);
2912 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
2914 else if (se
->ss
&& se
->ss
->useflags
)
2916 /* An elemental function inside a scalarized loop. */
2917 gfc_init_se (&parmse
, se
);
2918 gfc_conv_expr_reference (&parmse
, e
);
2919 parm_kind
= ELEMENTAL
;
2923 /* A scalar or transformational function. */
2924 gfc_init_se (&parmse
, NULL
);
2925 argss
= gfc_walk_expr (e
);
2927 if (argss
== gfc_ss_terminator
)
2929 if (e
->expr_type
== EXPR_VARIABLE
2930 && e
->symtree
->n
.sym
->attr
.cray_pointee
2931 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2933 /* The Cray pointer needs to be converted to a pointer to
2934 a type given by the expression. */
2935 gfc_conv_expr (&parmse
, e
);
2936 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2937 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2938 parmse
.expr
= convert (type
, tmp
);
2940 else if (fsym
&& fsym
->attr
.value
)
2942 if (fsym
->ts
.type
== BT_CHARACTER
2943 && fsym
->ts
.is_c_interop
2944 && fsym
->ns
->proc_name
!= NULL
2945 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2948 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2949 if (parmse
.expr
== NULL
)
2950 gfc_conv_expr (&parmse
, e
);
2953 gfc_conv_expr (&parmse
, e
);
2955 else if (arg
->name
&& arg
->name
[0] == '%')
2956 /* Argument list functions %VAL, %LOC and %REF are signalled
2957 through arg->name. */
2958 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2959 else if ((e
->expr_type
== EXPR_FUNCTION
)
2960 && ((e
->value
.function
.esym
2961 && e
->value
.function
.esym
->result
->attr
.pointer
)
2962 || (!e
->value
.function
.esym
2963 && e
->symtree
->n
.sym
->attr
.pointer
))
2964 && fsym
&& fsym
->attr
.target
)
2966 gfc_conv_expr (&parmse
, e
);
2967 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2969 else if (e
->expr_type
== EXPR_FUNCTION
2970 && e
->symtree
->n
.sym
->result
2971 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2972 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2974 /* Functions returning procedure pointers. */
2975 gfc_conv_expr (&parmse
, e
);
2976 if (fsym
&& fsym
->attr
.proc_pointer
)
2977 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2981 gfc_conv_expr_reference (&parmse
, e
);
2983 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2984 allocated on entry, it must be deallocated. */
2985 if (fsym
&& fsym
->attr
.allocatable
2986 && fsym
->attr
.intent
== INTENT_OUT
)
2990 gfc_init_block (&block
);
2991 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
2993 gfc_add_expr_to_block (&block
, tmp
);
2994 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2995 void_type_node
, parmse
.expr
,
2997 gfc_add_expr_to_block (&block
, tmp
);
2999 if (fsym
->attr
.optional
3000 && e
->expr_type
== EXPR_VARIABLE
3001 && e
->symtree
->n
.sym
->attr
.optional
)
3003 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3005 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3006 gfc_finish_block (&block
),
3007 build_empty_stmt (input_location
));
3010 tmp
= gfc_finish_block (&block
);
3012 gfc_add_expr_to_block (&se
->pre
, tmp
);
3015 if (fsym
&& e
->expr_type
!= EXPR_NULL
3016 && ((fsym
->attr
.pointer
3017 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3018 || (fsym
->attr
.proc_pointer
3019 && !(e
->expr_type
== EXPR_VARIABLE
3020 && e
->symtree
->n
.sym
->attr
.dummy
))
3021 || (e
->expr_type
== EXPR_VARIABLE
3022 && gfc_is_proc_ptr_comp (e
, NULL
))
3023 || fsym
->attr
.allocatable
))
3025 /* Scalar pointer dummy args require an extra level of
3026 indirection. The null pointer already contains
3027 this level of indirection. */
3028 parm_kind
= SCALAR_POINTER
;
3029 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3035 /* If the procedure requires an explicit interface, the actual
3036 argument is passed according to the corresponding formal
3037 argument. If the corresponding formal argument is a POINTER,
3038 ALLOCATABLE or assumed shape, we do not use g77's calling
3039 convention, and pass the address of the array descriptor
3040 instead. Otherwise we use g77's calling convention. */
3043 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3044 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3046 f
= f
|| !comp
->attr
.always_explicit
;
3048 f
= f
|| !sym
->attr
.always_explicit
;
3050 /* If the argument is a function call that may not create
3051 a temporary for the result, we have to check that we
3052 can do it, i.e. that there is no alias between this
3053 argument and another one. */
3054 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
3059 intent
= fsym
->attr
.intent
;
3061 intent
= INTENT_UNKNOWN
;
3063 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
3065 parmse
.force_tmp
= 1;
3068 if (e
->expr_type
== EXPR_VARIABLE
3069 && is_subref_array (e
))
3070 /* The actual argument is a component reference to an
3071 array of derived types. In this case, the argument
3072 is converted to a temporary, which is passed and then
3073 written back after the procedure call. */
3074 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3075 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3076 fsym
&& fsym
->attr
.pointer
);
3078 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
3081 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3082 allocated on entry, it must be deallocated. */
3083 if (fsym
&& fsym
->attr
.allocatable
3084 && fsym
->attr
.intent
== INTENT_OUT
)
3086 tmp
= build_fold_indirect_ref_loc (input_location
,
3088 tmp
= gfc_trans_dealloc_allocated (tmp
);
3089 if (fsym
->attr
.optional
3090 && e
->expr_type
== EXPR_VARIABLE
3091 && e
->symtree
->n
.sym
->attr
.optional
)
3092 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3094 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3095 tmp
, build_empty_stmt (input_location
));
3096 gfc_add_expr_to_block (&se
->pre
, tmp
);
3101 /* The case with fsym->attr.optional is that of a user subroutine
3102 with an interface indicating an optional argument. When we call
3103 an intrinsic subroutine, however, fsym is NULL, but we might still
3104 have an optional argument, so we proceed to the substitution
3106 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3108 /* If an optional argument is itself an optional dummy argument,
3109 check its presence and substitute a null if absent. This is
3110 only needed when passing an array to an elemental procedure
3111 as then array elements are accessed - or no NULL pointer is
3112 allowed and a "1" or "0" should be passed if not present.
3113 When passing a non-array-descriptor full array to a
3114 non-array-descriptor dummy, no check is needed. For
3115 array-descriptor actual to array-descriptor dummy, see
3116 PR 41911 for why a check has to be inserted.
3117 fsym == NULL is checked as intrinsics required the descriptor
3118 but do not always set fsym. */
3119 if (e
->expr_type
== EXPR_VARIABLE
3120 && e
->symtree
->n
.sym
->attr
.optional
3121 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3122 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3126 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
3127 || fsym
->as
->type
== AS_DEFERRED
))))))
3128 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3129 e
->representation
.length
);
3134 /* Obtain the character length of an assumed character length
3135 length procedure from the typespec. */
3136 if (fsym
->ts
.type
== BT_CHARACTER
3137 && parmse
.string_length
== NULL_TREE
3138 && e
->ts
.type
== BT_PROCEDURE
3139 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3140 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3141 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3143 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3144 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3148 if (fsym
&& need_interface_mapping
&& e
)
3149 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3151 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3152 gfc_add_block_to_block (&post
, &parmse
.post
);
3154 /* Allocated allocatable components of derived types must be
3155 deallocated for non-variable scalars. Non-variable arrays are
3156 dealt with in trans-array.c(gfc_conv_array_parameter). */
3157 if (e
&& e
->ts
.type
== BT_DERIVED
3158 && e
->ts
.u
.derived
->attr
.alloc_comp
3159 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3160 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3163 tmp
= build_fold_indirect_ref_loc (input_location
,
3165 parm_rank
= e
->rank
;
3173 case (SCALAR_POINTER
):
3174 tmp
= build_fold_indirect_ref_loc (input_location
,
3179 if (e
->expr_type
== EXPR_OP
3180 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3181 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3184 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3185 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3186 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3189 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3191 gfc_add_expr_to_block (&se
->post
, tmp
);
3194 /* Add argument checking of passing an unallocated/NULL actual to
3195 a nonallocatable/nonpointer dummy. */
3197 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3199 symbol_attribute attr
;
3203 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
3204 attr
= gfc_expr_attr (e
);
3206 goto end_pointer_check
;
3210 /* If the actual argument is an optional pointer/allocatable and
3211 the formal argument takes an nonpointer optional value,
3212 it is invalid to pass a non-present argument on, even
3213 though there is no technical reason for this in gfortran.
3214 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3215 tree present
, null_ptr
, type
;
3217 if (attr
.allocatable
3218 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3219 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3220 "allocated or not present", e
->symtree
->n
.sym
->name
);
3221 else if (attr
.pointer
3222 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3223 asprintf (&msg
, "Pointer actual argument '%s' is not "
3224 "associated or not present",
3225 e
->symtree
->n
.sym
->name
);
3226 else if (attr
.proc_pointer
3227 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3228 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3229 "associated or not present",
3230 e
->symtree
->n
.sym
->name
);
3232 goto end_pointer_check
;
3234 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3235 type
= TREE_TYPE (present
);
3236 present
= fold_build2_loc (input_location
, EQ_EXPR
,
3237 boolean_type_node
, present
,
3239 null_pointer_node
));
3240 type
= TREE_TYPE (parmse
.expr
);
3241 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
3242 boolean_type_node
, parmse
.expr
,
3244 null_pointer_node
));
3245 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3246 boolean_type_node
, present
, null_ptr
);
3250 if (attr
.allocatable
3251 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3252 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3253 "allocated", e
->symtree
->n
.sym
->name
);
3254 else if (attr
.pointer
3255 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3256 asprintf (&msg
, "Pointer actual argument '%s' is not "
3257 "associated", e
->symtree
->n
.sym
->name
);
3258 else if (attr
.proc_pointer
3259 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3260 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3261 "associated", e
->symtree
->n
.sym
->name
);
3263 goto end_pointer_check
;
3266 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3267 boolean_type_node
, parmse
.expr
,
3268 fold_convert (TREE_TYPE (parmse
.expr
),
3269 null_pointer_node
));
3272 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3279 /* Character strings are passed as two parameters, a length and a
3280 pointer - except for Bind(c) which only passes the pointer. */
3281 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3282 VEC_safe_push (tree
, gc
, stringargs
, parmse
.string_length
);
3284 VEC_safe_push (tree
, gc
, arglist
, parmse
.expr
);
3286 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3293 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3294 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3295 else if (ts
.type
== BT_CHARACTER
)
3297 if (ts
.u
.cl
->length
== NULL
)
3299 /* Assumed character length results are not allowed by 5.1.1.5 of the
3300 standard and are trapped in resolve.c; except in the case of SPREAD
3301 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3302 we take the character length of the first argument for the result.
3303 For dummies, we have to look through the formal argument list for
3304 this function and use the character length found there.*/
3305 if (!sym
->attr
.dummy
)
3306 cl
.backend_decl
= VEC_index (tree
, stringargs
, 0);
3309 formal
= sym
->ns
->proc_name
->formal
;
3310 for (; formal
; formal
= formal
->next
)
3311 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3312 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3319 /* Calculate the length of the returned string. */
3320 gfc_init_se (&parmse
, NULL
);
3321 if (need_interface_mapping
)
3322 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3324 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3325 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3326 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3328 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3329 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3330 gfc_charlen_type_node
, tmp
,
3331 build_int_cst (gfc_charlen_type_node
, 0));
3332 cl
.backend_decl
= tmp
;
3335 /* Set up a charlen structure for it. */
3340 len
= cl
.backend_decl
;
3343 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3344 || (!comp
&& gfc_return_by_reference (sym
));
3347 if (se
->direct_byref
)
3349 /* Sometimes, too much indirection can be applied; e.g. for
3350 function_result = array_valued_recursive_function. */
3351 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3352 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3353 && GFC_DESCRIPTOR_TYPE_P
3354 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3355 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3358 result
= build_fold_indirect_ref_loc (input_location
,
3360 VEC_safe_push (tree
, gc
, retargs
, se
->expr
);
3362 else if (comp
&& comp
->attr
.dimension
)
3364 gcc_assert (se
->loop
&& info
);
3366 /* Set the type of the array. */
3367 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3368 info
->dimen
= se
->loop
->dimen
;
3370 /* Evaluate the bounds of the result, if known. */
3371 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3373 /* Create a temporary to store the result. In case the function
3374 returns a pointer, the temporary will be a shallow copy and
3375 mustn't be deallocated. */
3376 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3377 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3378 NULL_TREE
, false, !comp
->attr
.pointer
,
3379 callee_alloc
, &se
->ss
->expr
->where
);
3381 /* Pass the temporary as the first argument. */
3382 result
= info
->descriptor
;
3383 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3384 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3386 else if (!comp
&& sym
->result
->attr
.dimension
)
3388 gcc_assert (se
->loop
&& info
);
3390 /* Set the type of the array. */
3391 tmp
= gfc_typenode_for_spec (&ts
);
3392 info
->dimen
= se
->loop
->dimen
;
3394 /* Evaluate the bounds of the result, if known. */
3395 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3397 /* Create a temporary to store the result. In case the function
3398 returns a pointer, the temporary will be a shallow copy and
3399 mustn't be deallocated. */
3400 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3401 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3402 NULL_TREE
, false, !sym
->attr
.pointer
,
3403 callee_alloc
, &se
->ss
->expr
->where
);
3405 /* Pass the temporary as the first argument. */
3406 result
= info
->descriptor
;
3407 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3408 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3410 else if (ts
.type
== BT_CHARACTER
)
3412 /* Pass the string length. */
3413 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3414 type
= build_pointer_type (type
);
3416 /* Return an address to a char[0:len-1]* temporary for
3417 character pointers. */
3418 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3419 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3421 var
= gfc_create_var (type
, "pstr");
3423 if ((!comp
&& sym
->attr
.allocatable
)
3424 || (comp
&& comp
->attr
.allocatable
))
3425 gfc_add_modify (&se
->pre
, var
,
3426 fold_convert (TREE_TYPE (var
),
3427 null_pointer_node
));
3429 /* Provide an address expression for the function arguments. */
3430 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3433 var
= gfc_conv_string_tmp (se
, type
, len
);
3435 VEC_safe_push (tree
, gc
, retargs
, var
);
3439 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3441 type
= gfc_get_complex_type (ts
.kind
);
3442 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3443 VEC_safe_push (tree
, gc
, retargs
, var
);
3446 /* Add the string length to the argument list. */
3447 if (ts
.type
== BT_CHARACTER
)
3448 VEC_safe_push (tree
, gc
, retargs
, len
);
3450 gfc_free_interface_mapping (&mapping
);
3452 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3453 arglen
= (VEC_length (tree
, arglist
)
3454 + VEC_length (tree
, stringargs
) + VEC_length (tree
, append_args
));
3455 VEC_reserve_exact (tree
, gc
, retargs
, arglen
);
3457 /* Add the return arguments. */
3458 VEC_splice (tree
, retargs
, arglist
);
3460 /* Add the hidden string length parameters to the arguments. */
3461 VEC_splice (tree
, retargs
, stringargs
);
3463 /* We may want to append extra arguments here. This is used e.g. for
3464 calls to libgfortran_matmul_??, which need extra information. */
3465 if (!VEC_empty (tree
, append_args
))
3466 VEC_splice (tree
, retargs
, append_args
);
3469 /* Generate the actual call. */
3470 conv_function_val (se
, sym
, expr
);
3472 /* If there are alternate return labels, function type should be
3473 integer. Can't modify the type in place though, since it can be shared
3474 with other functions. For dummy arguments, the typing is done to
3475 to this result, even if it has to be repeated for each call. */
3476 if (has_alternate_specifier
3477 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3479 if (!sym
->attr
.dummy
)
3481 TREE_TYPE (sym
->backend_decl
)
3482 = build_function_type (integer_type_node
,
3483 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3484 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3487 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3490 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3491 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
3493 /* If we have a pointer function, but we don't want a pointer, e.g.
3496 where f is pointer valued, we have to dereference the result. */
3497 if (!se
->want_pointer
&& !byref
3498 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3499 && !gfc_is_proc_ptr_comp (expr
, NULL
))
3500 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3503 /* f2c calling conventions require a scalar default real function to
3504 return a double precision result. Convert this back to default
3505 real. We only care about the cases that can happen in Fortran 77.
3507 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3508 && sym
->ts
.kind
== gfc_default_real_kind
3509 && !sym
->attr
.always_explicit
)
3510 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3512 /* A pure function may still have side-effects - it may modify its
3514 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3516 if (!sym
->attr
.pure
)
3517 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3522 /* Add the function call to the pre chain. There is no expression. */
3523 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3524 se
->expr
= NULL_TREE
;
3526 if (!se
->direct_byref
)
3528 if (sym
->attr
.dimension
|| (comp
&& comp
->attr
.dimension
))
3530 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3532 /* Check the data pointer hasn't been modified. This would
3533 happen in a function returning a pointer. */
3534 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3535 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
3538 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3541 se
->expr
= info
->descriptor
;
3542 /* Bundle in the string length. */
3543 se
->string_length
= len
;
3545 else if (ts
.type
== BT_CHARACTER
)
3547 /* Dereference for character pointer results. */
3548 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3549 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3550 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3554 se
->string_length
= len
;
3558 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3559 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3564 /* Follow the function call with the argument post block. */
3567 gfc_add_block_to_block (&se
->pre
, &post
);
3569 /* Transformational functions of derived types with allocatable
3570 components must have the result allocatable components copied. */
3571 arg
= expr
->value
.function
.actual
;
3572 if (result
&& arg
&& expr
->rank
3573 && expr
->value
.function
.isym
3574 && expr
->value
.function
.isym
->transformational
3575 && arg
->expr
->ts
.type
== BT_DERIVED
3576 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
3579 /* Copy the allocatable components. We have to use a
3580 temporary here to prevent source allocatable components
3581 from being corrupted. */
3582 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
3583 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
3584 result
, tmp2
, expr
->rank
);
3585 gfc_add_expr_to_block (&se
->pre
, tmp
);
3586 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
3588 gfc_add_expr_to_block (&se
->pre
, tmp
);
3590 /* Finally free the temporary's data field. */
3591 tmp
= gfc_conv_descriptor_data_get (tmp2
);
3592 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
3593 gfc_add_expr_to_block (&se
->pre
, tmp
);
3597 gfc_add_block_to_block (&se
->post
, &post
);
3599 return has_alternate_specifier
;
3603 /* Fill a character string with spaces. */
3606 fill_with_spaces (tree start
, tree type
, tree size
)
3608 stmtblock_t block
, loop
;
3609 tree i
, el
, exit_label
, cond
, tmp
;
3611 /* For a simple char type, we can call memset(). */
3612 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3613 return build_call_expr_loc (input_location
,
3614 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3615 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3616 lang_hooks
.to_target_charset (' ')),
3619 /* Otherwise, we use a loop:
3620 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3624 /* Initialize variables. */
3625 gfc_init_block (&block
);
3626 i
= gfc_create_var (sizetype
, "i");
3627 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3628 el
= gfc_create_var (build_pointer_type (type
), "el");
3629 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3630 exit_label
= gfc_build_label_decl (NULL_TREE
);
3631 TREE_USED (exit_label
) = 1;
3635 gfc_init_block (&loop
);
3637 /* Exit condition. */
3638 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
3639 build_zero_cst (sizetype
));
3640 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3641 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
3642 build_empty_stmt (input_location
));
3643 gfc_add_expr_to_block (&loop
, tmp
);
3646 gfc_add_modify (&loop
,
3647 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
3648 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
3650 /* Increment loop variables. */
3651 gfc_add_modify (&loop
, i
,
3652 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
3653 TYPE_SIZE_UNIT (type
)));
3654 gfc_add_modify (&loop
, el
,
3655 fold_build2_loc (input_location
, POINTER_PLUS_EXPR
,
3656 TREE_TYPE (el
), el
, TYPE_SIZE_UNIT (type
)));
3658 /* Making the loop... actually loop! */
3659 tmp
= gfc_finish_block (&loop
);
3660 tmp
= build1_v (LOOP_EXPR
, tmp
);
3661 gfc_add_expr_to_block (&block
, tmp
);
3663 /* The exit label. */
3664 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3665 gfc_add_expr_to_block (&block
, tmp
);
3668 return gfc_finish_block (&block
);
3672 /* Generate code to copy a string. */
3675 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3676 int dkind
, tree slength
, tree src
, int skind
)
3678 tree tmp
, dlen
, slen
;
3687 stmtblock_t tempblock
;
3689 gcc_assert (dkind
== skind
);
3691 if (slength
!= NULL_TREE
)
3693 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3694 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
3698 slen
= build_int_cst (size_type_node
, 1);
3702 if (dlength
!= NULL_TREE
)
3704 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3705 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
3709 dlen
= build_int_cst (size_type_node
, 1);
3713 /* Assign directly if the types are compatible. */
3714 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3715 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3717 gfc_add_modify (block
, dsc
, ssc
);
3721 /* Do nothing if the destination length is zero. */
3722 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
3723 build_int_cst (size_type_node
, 0));
3725 /* The following code was previously in _gfortran_copy_string:
3727 // The two strings may overlap so we use memmove.
3729 copy_string (GFC_INTEGER_4 destlen, char * dest,
3730 GFC_INTEGER_4 srclen, const char * src)
3732 if (srclen >= destlen)
3734 // This will truncate if too long.
3735 memmove (dest, src, destlen);
3739 memmove (dest, src, srclen);
3741 memset (&dest[srclen], ' ', destlen - srclen);
3745 We're now doing it here for better optimization, but the logic
3748 /* For non-default character kinds, we have to multiply the string
3749 length by the base type size. */
3750 chartype
= gfc_get_char_type (dkind
);
3751 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3752 fold_convert (size_type_node
, slen
),
3753 fold_convert (size_type_node
,
3754 TYPE_SIZE_UNIT (chartype
)));
3755 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3756 fold_convert (size_type_node
, dlen
),
3757 fold_convert (size_type_node
,
3758 TYPE_SIZE_UNIT (chartype
)));
3761 dest
= fold_convert (pvoid_type_node
, dest
);
3763 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3766 src
= fold_convert (pvoid_type_node
, src
);
3768 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3770 /* Truncate string if source is too long. */
3771 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
3773 tmp2
= build_call_expr_loc (input_location
,
3774 built_in_decls
[BUILT_IN_MEMMOVE
],
3775 3, dest
, src
, dlen
);
3777 /* Else copy and pad with spaces. */
3778 tmp3
= build_call_expr_loc (input_location
,
3779 built_in_decls
[BUILT_IN_MEMMOVE
],
3780 3, dest
, src
, slen
);
3782 tmp4
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
, TREE_TYPE (dest
),
3783 dest
, fold_convert (sizetype
, slen
));
3784 tmp4
= fill_with_spaces (tmp4
, chartype
,
3785 fold_build2_loc (input_location
, MINUS_EXPR
,
3786 TREE_TYPE(dlen
), dlen
, slen
));
3788 gfc_init_block (&tempblock
);
3789 gfc_add_expr_to_block (&tempblock
, tmp3
);
3790 gfc_add_expr_to_block (&tempblock
, tmp4
);
3791 tmp3
= gfc_finish_block (&tempblock
);
3793 /* The whole copy_string function is there. */
3794 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
3796 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
3797 build_empty_stmt (input_location
));
3798 gfc_add_expr_to_block (block
, tmp
);
3802 /* Translate a statement function.
3803 The value of a statement function reference is obtained by evaluating the
3804 expression using the values of the actual arguments for the values of the
3805 corresponding dummy arguments. */
3808 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3812 gfc_formal_arglist
*fargs
;
3813 gfc_actual_arglist
*args
;
3816 gfc_saved_var
*saved_vars
;
3822 sym
= expr
->symtree
->n
.sym
;
3823 args
= expr
->value
.function
.actual
;
3824 gfc_init_se (&lse
, NULL
);
3825 gfc_init_se (&rse
, NULL
);
3828 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3830 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3831 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3833 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3835 /* Each dummy shall be specified, explicitly or implicitly, to be
3837 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3840 /* Create a temporary to hold the value. */
3841 type
= gfc_typenode_for_spec (&fsym
->ts
);
3842 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3844 if (fsym
->ts
.type
== BT_CHARACTER
)
3846 /* Copy string arguments. */
3849 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3850 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3852 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3853 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3856 gfc_conv_expr (&rse
, args
->expr
);
3857 gfc_conv_string_parameter (&rse
);
3858 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3859 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3861 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3862 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3863 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3864 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3868 /* For everything else, just evaluate the expression. */
3869 gfc_conv_expr (&lse
, args
->expr
);
3871 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3872 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3873 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3879 /* Use the temporary variables in place of the real ones. */
3880 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3881 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3883 gfc_conv_expr (se
, sym
->value
);
3885 if (sym
->ts
.type
== BT_CHARACTER
)
3887 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3889 /* Force the expression to the correct length. */
3890 if (!INTEGER_CST_P (se
->string_length
)
3891 || tree_int_cst_lt (se
->string_length
,
3892 sym
->ts
.u
.cl
->backend_decl
))
3894 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
3895 tmp
= gfc_create_var (type
, sym
->name
);
3896 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3897 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
3898 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3902 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3905 /* Restore the original variables. */
3906 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3907 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3908 gfc_free (saved_vars
);
3912 /* Translate a function expression. */
3915 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3919 if (expr
->value
.function
.isym
)
3921 gfc_conv_intrinsic_function (se
, expr
);
3925 /* We distinguish statement functions from general functions to improve
3926 runtime performance. */
3927 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3929 gfc_conv_statement_function (se
, expr
);
3933 /* expr.value.function.esym is the resolved (specific) function symbol for
3934 most functions. However this isn't set for dummy procedures. */
3935 sym
= expr
->value
.function
.esym
;
3937 sym
= expr
->symtree
->n
.sym
;
3939 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
, NULL
);
3943 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3946 is_zero_initializer_p (gfc_expr
* expr
)
3948 if (expr
->expr_type
!= EXPR_CONSTANT
)
3951 /* We ignore constants with prescribed memory representations for now. */
3952 if (expr
->representation
.string
)
3955 switch (expr
->ts
.type
)
3958 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3961 return mpfr_zero_p (expr
->value
.real
)
3962 && MPFR_SIGN (expr
->value
.real
) >= 0;
3965 return expr
->value
.logical
== 0;
3968 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
3969 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
3970 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
3971 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
3981 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3983 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3984 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3986 gfc_conv_tmp_array_ref (se
);
3990 /* Build a static initializer. EXPR is the expression for the initial value.
3991 The other parameters describe the variable of the component being
3992 initialized. EXPR may be null. */
3995 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3996 bool array
, bool pointer
, bool procptr
)
4000 if (!(expr
|| pointer
|| procptr
))
4003 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4004 (these are the only two iso_c_binding derived types that can be
4005 used as initialization expressions). If so, we need to modify
4006 the 'expr' to be that for a (void *). */
4007 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
4008 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
4010 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
4012 /* The derived symbol has already been converted to a (void *). Use
4014 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
4015 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
4017 gfc_init_se (&se
, NULL
);
4018 gfc_conv_constant (&se
, expr
);
4019 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4023 if (array
&& !procptr
)
4026 /* Arrays need special handling. */
4028 ctor
= gfc_build_null_descriptor (type
);
4029 /* Special case assigning an array to zero. */
4030 else if (is_zero_initializer_p (expr
))
4031 ctor
= build_constructor (type
, NULL
);
4033 ctor
= gfc_conv_array_initializer (type
, expr
);
4034 TREE_STATIC (ctor
) = 1;
4037 else if (pointer
|| procptr
)
4039 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
4040 return fold_convert (type
, null_pointer_node
);
4043 gfc_init_se (&se
, NULL
);
4044 se
.want_pointer
= 1;
4045 gfc_conv_expr (&se
, expr
);
4046 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4056 gfc_init_se (&se
, NULL
);
4057 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4058 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
4060 gfc_conv_structure (&se
, expr
, 1);
4061 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
4062 TREE_STATIC (se
.expr
) = 1;
4067 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
4068 TREE_STATIC (ctor
) = 1;
4073 gfc_init_se (&se
, NULL
);
4074 gfc_conv_constant (&se
, expr
);
4075 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4082 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4094 gfc_start_block (&block
);
4096 /* Initialize the scalarizer. */
4097 gfc_init_loopinfo (&loop
);
4099 gfc_init_se (&lse
, NULL
);
4100 gfc_init_se (&rse
, NULL
);
4103 rss
= gfc_walk_expr (expr
);
4104 if (rss
== gfc_ss_terminator
)
4106 /* The rhs is scalar. Add a ss for the expression. */
4107 rss
= gfc_get_ss ();
4108 rss
->next
= gfc_ss_terminator
;
4109 rss
->type
= GFC_SS_SCALAR
;
4113 /* Create a SS for the destination. */
4114 lss
= gfc_get_ss ();
4115 lss
->type
= GFC_SS_COMPONENT
;
4117 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
4118 lss
->next
= gfc_ss_terminator
;
4119 lss
->data
.info
.dimen
= cm
->as
->rank
;
4120 lss
->data
.info
.descriptor
= dest
;
4121 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
4122 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
4123 for (n
= 0; n
< cm
->as
->rank
; n
++)
4125 lss
->data
.info
.dim
[n
] = n
;
4126 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
4127 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
4129 mpz_init (lss
->shape
[n
]);
4130 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
4131 cm
->as
->lower
[n
]->value
.integer
);
4132 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
4135 /* Associate the SS with the loop. */
4136 gfc_add_ss_to_loop (&loop
, lss
);
4137 gfc_add_ss_to_loop (&loop
, rss
);
4139 /* Calculate the bounds of the scalarization. */
4140 gfc_conv_ss_startstride (&loop
);
4142 /* Setup the scalarizing loops. */
4143 gfc_conv_loop_setup (&loop
, &expr
->where
);
4145 /* Setup the gfc_se structures. */
4146 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4147 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4150 gfc_mark_ss_chain_used (rss
, 1);
4152 gfc_mark_ss_chain_used (lss
, 1);
4154 /* Start the scalarized loop body. */
4155 gfc_start_scalarized_body (&loop
, &body
);
4157 gfc_conv_tmp_array_ref (&lse
);
4158 if (cm
->ts
.type
== BT_CHARACTER
)
4159 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4161 gfc_conv_expr (&rse
, expr
);
4163 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
4164 gfc_add_expr_to_block (&body
, tmp
);
4166 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4168 /* Generate the copying loops. */
4169 gfc_trans_scalarizing_loops (&loop
, &body
);
4171 /* Wrap the whole thing up. */
4172 gfc_add_block_to_block (&block
, &loop
.pre
);
4173 gfc_add_block_to_block (&block
, &loop
.post
);
4175 for (n
= 0; n
< cm
->as
->rank
; n
++)
4176 mpz_clear (lss
->shape
[n
]);
4177 gfc_free (lss
->shape
);
4179 gfc_cleanup_loop (&loop
);
4181 return gfc_finish_block (&block
);
4186 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4197 gfc_expr
*arg
= NULL
;
4199 gfc_start_block (&block
);
4200 gfc_init_se (&se
, NULL
);
4202 /* Get the descriptor for the expressions. */
4203 rss
= gfc_walk_expr (expr
);
4204 se
.want_pointer
= 0;
4205 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4206 gfc_add_block_to_block (&block
, &se
.pre
);
4207 gfc_add_modify (&block
, dest
, se
.expr
);
4209 /* Deal with arrays of derived types with allocatable components. */
4210 if (cm
->ts
.type
== BT_DERIVED
4211 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4212 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4216 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4217 TREE_TYPE(cm
->backend_decl
),
4220 gfc_add_expr_to_block (&block
, tmp
);
4221 gfc_add_block_to_block (&block
, &se
.post
);
4223 if (expr
->expr_type
!= EXPR_VARIABLE
)
4224 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4227 /* We need to know if the argument of a conversion function is a
4228 variable, so that the correct lower bound can be used. */
4229 if (expr
->expr_type
== EXPR_FUNCTION
4230 && expr
->value
.function
.isym
4231 && expr
->value
.function
.isym
->conversion
4232 && expr
->value
.function
.actual
->expr
4233 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4234 arg
= expr
->value
.function
.actual
->expr
;
4236 /* Obtain the array spec of full array references. */
4238 as
= gfc_get_full_arrayspec_from_expr (arg
);
4240 as
= gfc_get_full_arrayspec_from_expr (expr
);
4242 /* Shift the lbound and ubound of temporaries to being unity,
4243 rather than zero, based. Always calculate the offset. */
4244 offset
= gfc_conv_descriptor_offset_get (dest
);
4245 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4246 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4248 for (n
= 0; n
< expr
->rank
; n
++)
4253 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4254 TODO It looks as if gfc_conv_expr_descriptor should return
4255 the correct bounds and that the following should not be
4256 necessary. This would simplify gfc_conv_intrinsic_bound
4258 if (as
&& as
->lower
[n
])
4261 gfc_init_se (&lbse
, NULL
);
4262 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4263 gfc_add_block_to_block (&block
, &lbse
.pre
);
4264 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4268 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4269 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4273 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4276 lbound
= gfc_index_one_node
;
4278 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4280 /* Shift the bounds and set the offset accordingly. */
4281 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4282 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4283 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4284 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4286 gfc_conv_descriptor_ubound_set (&block
, dest
,
4287 gfc_rank_cst
[n
], tmp
);
4288 gfc_conv_descriptor_lbound_set (&block
, dest
,
4289 gfc_rank_cst
[n
], lbound
);
4291 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4292 gfc_conv_descriptor_lbound_get (dest
,
4294 gfc_conv_descriptor_stride_get (dest
,
4296 gfc_add_modify (&block
, tmp2
, tmp
);
4297 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4299 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4304 /* If a conversion expression has a null data pointer
4305 argument, nullify the allocatable component. */
4309 if (arg
->symtree
->n
.sym
->attr
.allocatable
4310 || arg
->symtree
->n
.sym
->attr
.pointer
)
4312 non_null_expr
= gfc_finish_block (&block
);
4313 gfc_start_block (&block
);
4314 gfc_conv_descriptor_data_set (&block
, dest
,
4316 null_expr
= gfc_finish_block (&block
);
4317 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4318 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
4319 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
4320 return build3_v (COND_EXPR
, tmp
,
4321 null_expr
, non_null_expr
);
4325 return gfc_finish_block (&block
);
4329 /* Assign a single component of a derived type constructor. */
4332 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4340 gfc_start_block (&block
);
4342 if (cm
->attr
.pointer
)
4344 gfc_init_se (&se
, NULL
);
4345 /* Pointer component. */
4346 if (cm
->attr
.dimension
)
4348 /* Array pointer. */
4349 if (expr
->expr_type
== EXPR_NULL
)
4350 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4353 rss
= gfc_walk_expr (expr
);
4354 se
.direct_byref
= 1;
4356 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4357 gfc_add_block_to_block (&block
, &se
.pre
);
4358 gfc_add_block_to_block (&block
, &se
.post
);
4363 /* Scalar pointers. */
4364 se
.want_pointer
= 1;
4365 gfc_conv_expr (&se
, expr
);
4366 gfc_add_block_to_block (&block
, &se
.pre
);
4367 gfc_add_modify (&block
, dest
,
4368 fold_convert (TREE_TYPE (dest
), se
.expr
));
4369 gfc_add_block_to_block (&block
, &se
.post
);
4372 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4374 /* NULL initialization for CLASS components. */
4375 tmp
= gfc_trans_structure_assign (dest
,
4376 gfc_class_null_initializer (&cm
->ts
));
4377 gfc_add_expr_to_block (&block
, tmp
);
4379 else if (cm
->attr
.dimension
)
4381 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4382 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4383 else if (cm
->attr
.allocatable
)
4385 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4386 gfc_add_expr_to_block (&block
, tmp
);
4390 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4391 gfc_add_expr_to_block (&block
, tmp
);
4394 else if (expr
->ts
.type
== BT_DERIVED
)
4396 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4398 gfc_init_se (&se
, NULL
);
4399 gfc_conv_expr (&se
, expr
);
4400 gfc_add_block_to_block (&block
, &se
.pre
);
4401 gfc_add_modify (&block
, dest
,
4402 fold_convert (TREE_TYPE (dest
), se
.expr
));
4403 gfc_add_block_to_block (&block
, &se
.post
);
4407 /* Nested constructors. */
4408 tmp
= gfc_trans_structure_assign (dest
, expr
);
4409 gfc_add_expr_to_block (&block
, tmp
);
4414 /* Scalar component. */
4415 gfc_init_se (&se
, NULL
);
4416 gfc_init_se (&lse
, NULL
);
4418 gfc_conv_expr (&se
, expr
);
4419 if (cm
->ts
.type
== BT_CHARACTER
)
4420 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4422 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
4423 gfc_add_expr_to_block (&block
, tmp
);
4425 return gfc_finish_block (&block
);
4428 /* Assign a derived type constructor to a variable. */
4431 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4439 gfc_start_block (&block
);
4440 cm
= expr
->ts
.u
.derived
->components
;
4441 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4442 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4444 /* Skip absent members in default initializers. */
4448 /* Handle c_null_(fun)ptr. */
4449 if (c
&& c
->expr
&& c
->expr
->ts
.is_iso_c
)
4451 field
= cm
->backend_decl
;
4452 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
4454 dest
, field
, NULL_TREE
);
4455 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (tmp
),
4456 tmp
, fold_convert (TREE_TYPE (tmp
),
4457 null_pointer_node
));
4458 gfc_add_expr_to_block (&block
, tmp
);
4462 field
= cm
->backend_decl
;
4463 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
4464 dest
, field
, NULL_TREE
);
4465 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4466 gfc_add_expr_to_block (&block
, tmp
);
4468 return gfc_finish_block (&block
);
4471 /* Build an expression for a constructor. If init is nonzero then
4472 this is part of a static variable initializer. */
4475 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4482 VEC(constructor_elt
,gc
) *v
= NULL
;
4484 gcc_assert (se
->ss
== NULL
);
4485 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4486 type
= gfc_typenode_for_spec (&expr
->ts
);
4490 /* Create a temporary variable and fill it in. */
4491 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4492 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4493 gfc_add_expr_to_block (&se
->pre
, tmp
);
4497 cm
= expr
->ts
.u
.derived
->components
;
4499 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4500 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4502 /* Skip absent members in default initializers and allocatable
4503 components. Although the latter have a default initializer
4504 of EXPR_NULL,... by default, the static nullify is not needed
4505 since this is done every time we come into scope. */
4506 if (!c
->expr
|| cm
->attr
.allocatable
)
4509 if (strcmp (cm
->name
, "_size") == 0)
4511 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4512 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4514 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4515 && strcmp (cm
->name
, "_extends") == 0)
4519 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4520 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4521 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
4525 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4526 TREE_TYPE (cm
->backend_decl
),
4527 cm
->attr
.dimension
, cm
->attr
.pointer
,
4528 cm
->attr
.proc_pointer
);
4530 /* Append it to the constructor list. */
4531 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4534 se
->expr
= build_constructor (type
, v
);
4536 TREE_CONSTANT (se
->expr
) = 1;
4540 /* Translate a substring expression. */
4543 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4549 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4551 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4552 expr
->value
.character
.length
,
4553 expr
->value
.character
.string
);
4555 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4556 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4559 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4563 /* Entry point for expression translation. Evaluates a scalar quantity.
4564 EXPR is the expression to be translated, and SE is the state structure if
4565 called from within the scalarized. */
4568 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4570 if (se
->ss
&& se
->ss
->expr
== expr
4571 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4573 /* Substitute a scalar expression evaluated outside the scalarization
4575 se
->expr
= se
->ss
->data
.scalar
.expr
;
4576 if (se
->ss
->type
== GFC_SS_REFERENCE
)
4577 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
4578 se
->string_length
= se
->ss
->string_length
;
4579 gfc_advance_se_ss_chain (se
);
4583 /* We need to convert the expressions for the iso_c_binding derived types.
4584 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4585 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4586 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4587 updated to be an integer with a kind equal to the size of a (void *). */
4588 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4589 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4591 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4592 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
4594 /* Set expr_type to EXPR_NULL, which will result in
4595 null_pointer_node being used below. */
4596 expr
->expr_type
= EXPR_NULL
;
4600 /* Update the type/kind of the expression to be what the new
4601 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4602 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4603 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4604 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4608 switch (expr
->expr_type
)
4611 gfc_conv_expr_op (se
, expr
);
4615 gfc_conv_function_expr (se
, expr
);
4619 gfc_conv_constant (se
, expr
);
4623 gfc_conv_variable (se
, expr
);
4627 se
->expr
= null_pointer_node
;
4630 case EXPR_SUBSTRING
:
4631 gfc_conv_substring_expr (se
, expr
);
4634 case EXPR_STRUCTURE
:
4635 gfc_conv_structure (se
, expr
, 0);
4639 gfc_conv_array_constructor_expr (se
, expr
);
4648 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4649 of an assignment. */
4651 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4653 gfc_conv_expr (se
, expr
);
4654 /* All numeric lvalues should have empty post chains. If not we need to
4655 figure out a way of rewriting an lvalue so that it has no post chain. */
4656 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4659 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4660 numeric expressions. Used for scalar values where inserting cleanup code
4663 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4667 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4668 gfc_conv_expr (se
, expr
);
4671 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4672 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4674 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4678 /* Helper to translate an expression and convert it to a particular type. */
4680 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4682 gfc_conv_expr_val (se
, expr
);
4683 se
->expr
= convert (type
, se
->expr
);
4687 /* Converts an expression so that it can be passed by reference. Scalar
4691 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4695 if (se
->ss
&& se
->ss
->expr
== expr
4696 && se
->ss
->type
== GFC_SS_REFERENCE
)
4698 /* Returns a reference to the scalar evaluated outside the loop
4700 gfc_conv_expr (se
, expr
);
4704 if (expr
->ts
.type
== BT_CHARACTER
)
4706 gfc_conv_expr (se
, expr
);
4707 gfc_conv_string_parameter (se
);
4711 if (expr
->expr_type
== EXPR_VARIABLE
)
4713 se
->want_pointer
= 1;
4714 gfc_conv_expr (se
, expr
);
4717 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4718 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4719 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4725 if (expr
->expr_type
== EXPR_FUNCTION
4726 && ((expr
->value
.function
.esym
4727 && expr
->value
.function
.esym
->result
->attr
.pointer
4728 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4729 || (!expr
->value
.function
.esym
4730 && expr
->symtree
->n
.sym
->attr
.pointer
4731 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4733 se
->want_pointer
= 1;
4734 gfc_conv_expr (se
, expr
);
4735 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4736 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4742 gfc_conv_expr (se
, expr
);
4744 /* Create a temporary var to hold the value. */
4745 if (TREE_CONSTANT (se
->expr
))
4747 tree tmp
= se
->expr
;
4748 STRIP_TYPE_NOPS (tmp
);
4749 var
= build_decl (input_location
,
4750 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4751 DECL_INITIAL (var
) = tmp
;
4752 TREE_STATIC (var
) = 1;
4757 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4758 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4760 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4762 /* Take the address of that value. */
4763 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4768 gfc_trans_pointer_assign (gfc_code
* code
)
4770 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4774 /* Generate code for a pointer assignment. */
4777 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4788 gfc_start_block (&block
);
4790 gfc_init_se (&lse
, NULL
);
4792 lss
= gfc_walk_expr (expr1
);
4793 rss
= gfc_walk_expr (expr2
);
4794 if (lss
== gfc_ss_terminator
)
4796 /* Scalar pointers. */
4797 lse
.want_pointer
= 1;
4798 gfc_conv_expr (&lse
, expr1
);
4799 gcc_assert (rss
== gfc_ss_terminator
);
4800 gfc_init_se (&rse
, NULL
);
4801 rse
.want_pointer
= 1;
4802 gfc_conv_expr (&rse
, expr2
);
4804 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4805 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4806 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4809 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4810 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4811 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4814 gfc_add_block_to_block (&block
, &lse
.pre
);
4815 gfc_add_block_to_block (&block
, &rse
.pre
);
4817 /* Check character lengths if character expression. The test is only
4818 really added if -fbounds-check is enabled. */
4819 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4820 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4821 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4823 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4824 gcc_assert (lse
.string_length
&& rse
.string_length
);
4825 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4826 lse
.string_length
, rse
.string_length
,
4830 gfc_add_modify (&block
, lse
.expr
,
4831 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4833 gfc_add_block_to_block (&block
, &rse
.post
);
4834 gfc_add_block_to_block (&block
, &lse
.post
);
4841 tree strlen_rhs
= NULL_TREE
;
4843 /* Array pointer. Find the last reference on the LHS and if it is an
4844 array section ref, we're dealing with bounds remapping. In this case,
4845 set it to AR_FULL so that gfc_conv_expr_descriptor does
4846 not see it and process the bounds remapping afterwards explicitely. */
4847 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
4848 if (!remap
->next
&& remap
->type
== REF_ARRAY
4849 && remap
->u
.ar
.type
== AR_SECTION
)
4851 remap
->u
.ar
.type
= AR_FULL
;
4854 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
4856 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4857 strlen_lhs
= lse
.string_length
;
4860 if (expr2
->expr_type
== EXPR_NULL
)
4862 /* Just set the data pointer to null. */
4863 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4865 else if (rank_remap
)
4867 /* If we are rank-remapping, just get the RHS's descriptor and
4868 process this later on. */
4869 gfc_init_se (&rse
, NULL
);
4870 rse
.direct_byref
= 1;
4871 rse
.byref_noassign
= 1;
4872 gfc_conv_expr_descriptor (&rse
, expr2
, rss
);
4873 strlen_rhs
= rse
.string_length
;
4875 else if (expr2
->expr_type
== EXPR_VARIABLE
)
4877 /* Assign directly to the LHS's descriptor. */
4878 lse
.direct_byref
= 1;
4879 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4880 strlen_rhs
= lse
.string_length
;
4882 /* If this is a subreference array pointer assignment, use the rhs
4883 descriptor element size for the lhs span. */
4884 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4886 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4887 gfc_init_se (&rse
, NULL
);
4888 rse
.descriptor_only
= 1;
4889 gfc_conv_expr (&rse
, expr2
);
4890 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4891 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4892 if (!INTEGER_CST_P (tmp
))
4893 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4894 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4899 /* Assign to a temporary descriptor and then copy that
4900 temporary to the pointer. */
4901 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4904 lse
.direct_byref
= 1;
4905 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4906 strlen_rhs
= lse
.string_length
;
4907 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4910 gfc_add_block_to_block (&block
, &lse
.pre
);
4912 gfc_add_block_to_block (&block
, &rse
.pre
);
4914 /* If we do bounds remapping, update LHS descriptor accordingly. */
4918 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
4922 /* Do rank remapping. We already have the RHS's descriptor
4923 converted in rse and now have to build the correct LHS
4924 descriptor for it. */
4928 tree lbound
, ubound
;
4931 dtype
= gfc_conv_descriptor_dtype (desc
);
4932 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
4933 gfc_add_modify (&block
, dtype
, tmp
);
4935 /* Copy data pointer. */
4936 data
= gfc_conv_descriptor_data_get (rse
.expr
);
4937 gfc_conv_descriptor_data_set (&block
, desc
, data
);
4939 /* Copy offset but adjust it such that it would correspond
4940 to a lbound of zero. */
4941 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
4942 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
4944 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
4946 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
4948 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4949 gfc_array_index_type
, stride
, lbound
);
4950 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
4951 gfc_array_index_type
, offs
, tmp
);
4953 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
4955 /* Set the bounds as declared for the LHS and calculate strides as
4956 well as another offset update accordingly. */
4957 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
4959 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
4964 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
4966 /* Convert declared bounds. */
4967 gfc_init_se (&lower_se
, NULL
);
4968 gfc_init_se (&upper_se
, NULL
);
4969 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
4970 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
4972 gfc_add_block_to_block (&block
, &lower_se
.pre
);
4973 gfc_add_block_to_block (&block
, &upper_se
.pre
);
4975 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
4976 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
4978 lbound
= gfc_evaluate_now (lbound
, &block
);
4979 ubound
= gfc_evaluate_now (ubound
, &block
);
4981 gfc_add_block_to_block (&block
, &lower_se
.post
);
4982 gfc_add_block_to_block (&block
, &upper_se
.post
);
4984 /* Set bounds in descriptor. */
4985 gfc_conv_descriptor_lbound_set (&block
, desc
,
4986 gfc_rank_cst
[dim
], lbound
);
4987 gfc_conv_descriptor_ubound_set (&block
, desc
,
4988 gfc_rank_cst
[dim
], ubound
);
4991 stride
= gfc_evaluate_now (stride
, &block
);
4992 gfc_conv_descriptor_stride_set (&block
, desc
,
4993 gfc_rank_cst
[dim
], stride
);
4995 /* Update offset. */
4996 offs
= gfc_conv_descriptor_offset_get (desc
);
4997 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4998 gfc_array_index_type
, lbound
, stride
);
4999 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
5000 gfc_array_index_type
, offs
, tmp
);
5001 offs
= gfc_evaluate_now (offs
, &block
);
5002 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5004 /* Update stride. */
5005 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5006 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5007 gfc_array_index_type
, stride
, tmp
);
5012 /* Bounds remapping. Just shift the lower bounds. */
5014 gcc_assert (expr1
->rank
== expr2
->rank
);
5016 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
5020 gcc_assert (remap
->u
.ar
.start
[dim
]);
5021 gcc_assert (!remap
->u
.ar
.end
[dim
]);
5022 gfc_init_se (&lbound_se
, NULL
);
5023 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
5025 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
5026 gfc_conv_shift_descriptor_lbound (&block
, desc
,
5027 dim
, lbound_se
.expr
);
5028 gfc_add_block_to_block (&block
, &lbound_se
.post
);
5033 /* Check string lengths if applicable. The check is only really added
5034 to the output code if -fbounds-check is enabled. */
5035 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
5037 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5038 gcc_assert (strlen_lhs
&& strlen_rhs
);
5039 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5040 strlen_lhs
, strlen_rhs
, &block
);
5043 /* If rank remapping was done, check with -fcheck=bounds that
5044 the target is at least as large as the pointer. */
5045 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
5051 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
5052 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
5054 lsize
= gfc_evaluate_now (lsize
, &block
);
5055 rsize
= gfc_evaluate_now (rsize
, &block
);
5056 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
5059 msg
= _("Target of rank remapping is too small (%ld < %ld)");
5060 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
5064 gfc_add_block_to_block (&block
, &lse
.post
);
5066 gfc_add_block_to_block (&block
, &rse
.post
);
5069 return gfc_finish_block (&block
);
5073 /* Makes sure se is suitable for passing as a function string parameter. */
5074 /* TODO: Need to check all callers of this function. It may be abused. */
5077 gfc_conv_string_parameter (gfc_se
* se
)
5081 if (TREE_CODE (se
->expr
) == STRING_CST
)
5083 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
5084 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5088 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
5090 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
5092 type
= TREE_TYPE (se
->expr
);
5093 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5097 type
= gfc_get_character_type_len (gfc_default_character_kind
,
5099 type
= build_pointer_type (type
);
5100 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
5104 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
5105 gcc_assert (se
->string_length
5106 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
5110 /* Generate code for assignment of scalar variables. Includes character
5111 strings and derived types with allocatable components.
5112 If you know that the LHS has no allocations, set dealloc to false. */
5115 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
5116 bool l_is_temp
, bool r_is_var
, bool dealloc
)
5122 gfc_init_block (&block
);
5124 if (ts
.type
== BT_CHARACTER
)
5129 if (lse
->string_length
!= NULL_TREE
)
5131 gfc_conv_string_parameter (lse
);
5132 gfc_add_block_to_block (&block
, &lse
->pre
);
5133 llen
= lse
->string_length
;
5136 if (rse
->string_length
!= NULL_TREE
)
5138 gcc_assert (rse
->string_length
!= NULL_TREE
);
5139 gfc_conv_string_parameter (rse
);
5140 gfc_add_block_to_block (&block
, &rse
->pre
);
5141 rlen
= rse
->string_length
;
5144 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
5145 rse
->expr
, ts
.kind
);
5147 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
5151 /* Are the rhs and the lhs the same? */
5154 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5155 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
5156 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
5157 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
5160 /* Deallocate the lhs allocated components as long as it is not
5161 the same as the rhs. This must be done following the assignment
5162 to prevent deallocating data that could be used in the rhs
5164 if (!l_is_temp
&& dealloc
)
5166 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
5167 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
5169 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5171 gfc_add_expr_to_block (&lse
->post
, tmp
);
5174 gfc_add_block_to_block (&block
, &rse
->pre
);
5175 gfc_add_block_to_block (&block
, &lse
->pre
);
5177 gfc_add_modify (&block
, lse
->expr
,
5178 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5180 /* Do a deep copy if the rhs is a variable, if it is not the
5184 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
5185 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5187 gfc_add_expr_to_block (&block
, tmp
);
5190 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
5192 gfc_add_block_to_block (&block
, &lse
->pre
);
5193 gfc_add_block_to_block (&block
, &rse
->pre
);
5194 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
5195 TREE_TYPE (lse
->expr
), rse
->expr
);
5196 gfc_add_modify (&block
, lse
->expr
, tmp
);
5200 gfc_add_block_to_block (&block
, &lse
->pre
);
5201 gfc_add_block_to_block (&block
, &rse
->pre
);
5203 gfc_add_modify (&block
, lse
->expr
,
5204 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5207 gfc_add_block_to_block (&block
, &lse
->post
);
5208 gfc_add_block_to_block (&block
, &rse
->post
);
5210 return gfc_finish_block (&block
);
5214 /* There are quite a lot of restrictions on the optimisation in using an
5215 array function assign without a temporary. */
5218 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
5221 bool seen_array_ref
;
5223 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
5225 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5226 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
5229 /* Elemental functions are scalarized so that they don't need a
5230 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5231 they would need special treatment in gfc_trans_arrayfunc_assign. */
5232 if (expr2
->value
.function
.esym
!= NULL
5233 && expr2
->value
.function
.esym
->attr
.elemental
)
5236 /* Need a temporary if rhs is not FULL or a contiguous section. */
5237 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
5240 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5241 if (gfc_ref_needs_temporary_p (expr1
->ref
))
5244 /* Functions returning pointers need temporaries. */
5245 if (expr2
->symtree
->n
.sym
->attr
.pointer
5246 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
5249 /* Character array functions need temporaries unless the
5250 character lengths are the same. */
5251 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
5253 if (expr1
->ts
.u
.cl
->length
== NULL
5254 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5257 if (expr2
->ts
.u
.cl
->length
== NULL
5258 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5261 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
5262 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
5266 /* Check that no LHS component references appear during an array
5267 reference. This is needed because we do not have the means to
5268 span any arbitrary stride with an array descriptor. This check
5269 is not needed for the rhs because the function result has to be
5271 seen_array_ref
= false;
5272 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
5274 if (ref
->type
== REF_ARRAY
)
5275 seen_array_ref
= true;
5276 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
5280 /* Check for a dependency. */
5281 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
5282 expr2
->value
.function
.esym
,
5283 expr2
->value
.function
.actual
,
5287 /* If we have reached here with an intrinsic function, we do not
5288 need a temporary. */
5289 if (expr2
->value
.function
.isym
)
5292 /* If the LHS is a dummy, we need a temporary if it is not
5294 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
5297 /* A PURE function can unconditionally be called without a temporary. */
5298 if (expr2
->value
.function
.esym
!= NULL
5299 && expr2
->value
.function
.esym
->attr
.pure
)
5302 /* TODO a function that could correctly be declared PURE but is not
5303 could do with returning false as well. */
5305 if (!sym
->attr
.use_assoc
5306 && !sym
->attr
.in_common
5307 && !sym
->attr
.pointer
5308 && !sym
->attr
.target
5309 && expr2
->value
.function
.esym
)
5311 /* A temporary is not needed if the function is not contained and
5312 the variable is local or host associated and not a pointer or
5314 if (!expr2
->value
.function
.esym
->attr
.contained
)
5317 /* A temporary is not needed if the lhs has never been host
5318 associated and the procedure is contained. */
5319 else if (!sym
->attr
.host_assoc
)
5322 /* A temporary is not needed if the variable is local and not
5323 a pointer, a target or a result. */
5325 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
5329 /* Default to temporary use. */
5334 /* Try to translate array(:) = func (...), where func is a transformational
5335 array function, without using a temporary. Returns NULL if this isn't the
5339 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
5343 gfc_component
*comp
= NULL
;
5345 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
5348 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5350 gcc_assert (expr2
->value
.function
.isym
5351 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
5352 && comp
&& comp
->attr
.dimension
)
5353 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
5354 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
5356 ss
= gfc_walk_expr (expr1
);
5357 gcc_assert (ss
!= gfc_ss_terminator
);
5358 gfc_init_se (&se
, NULL
);
5359 gfc_start_block (&se
.pre
);
5360 se
.want_pointer
= 1;
5362 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
5364 if (expr1
->ts
.type
== BT_DERIVED
5365 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
5368 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
5370 gfc_add_expr_to_block (&se
.pre
, tmp
);
5373 se
.direct_byref
= 1;
5374 se
.ss
= gfc_walk_expr (expr2
);
5375 gcc_assert (se
.ss
!= gfc_ss_terminator
);
5376 gfc_conv_function_expr (&se
, expr2
);
5377 gfc_add_block_to_block (&se
.pre
, &se
.post
);
5379 return gfc_finish_block (&se
.pre
);
5383 /* Try to efficiently translate array(:) = 0. Return NULL if this
5387 gfc_trans_zero_assign (gfc_expr
* expr
)
5389 tree dest
, len
, type
;
5393 sym
= expr
->symtree
->n
.sym
;
5394 dest
= gfc_get_symbol_decl (sym
);
5396 type
= TREE_TYPE (dest
);
5397 if (POINTER_TYPE_P (type
))
5398 type
= TREE_TYPE (type
);
5399 if (!GFC_ARRAY_TYPE_P (type
))
5402 /* Determine the length of the array. */
5403 len
= GFC_TYPE_ARRAY_SIZE (type
);
5404 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5407 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5408 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5409 fold_convert (gfc_array_index_type
, tmp
));
5411 /* If we are zeroing a local array avoid taking its address by emitting
5413 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5414 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5415 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5417 /* Convert arguments to the correct types. */
5418 dest
= fold_convert (pvoid_type_node
, dest
);
5419 len
= fold_convert (size_type_node
, len
);
5421 /* Construct call to __builtin_memset. */
5422 tmp
= build_call_expr_loc (input_location
,
5423 built_in_decls
[BUILT_IN_MEMSET
],
5424 3, dest
, integer_zero_node
, len
);
5425 return fold_convert (void_type_node
, tmp
);
5429 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5430 that constructs the call to __builtin_memcpy. */
5433 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5437 /* Convert arguments to the correct types. */
5438 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5439 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5441 dst
= fold_convert (pvoid_type_node
, dst
);
5443 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5444 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5446 src
= fold_convert (pvoid_type_node
, src
);
5448 len
= fold_convert (size_type_node
, len
);
5450 /* Construct call to __builtin_memcpy. */
5451 tmp
= build_call_expr_loc (input_location
,
5452 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5453 return fold_convert (void_type_node
, tmp
);
5457 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5458 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5459 source/rhs, both are gfc_full_array_ref_p which have been checked for
5463 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5465 tree dst
, dlen
, dtype
;
5466 tree src
, slen
, stype
;
5469 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5470 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5472 dtype
= TREE_TYPE (dst
);
5473 if (POINTER_TYPE_P (dtype
))
5474 dtype
= TREE_TYPE (dtype
);
5475 stype
= TREE_TYPE (src
);
5476 if (POINTER_TYPE_P (stype
))
5477 stype
= TREE_TYPE (stype
);
5479 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5482 /* Determine the lengths of the arrays. */
5483 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5484 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5486 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5487 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5488 dlen
, fold_convert (gfc_array_index_type
, tmp
));
5490 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5491 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5493 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5494 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5495 slen
, fold_convert (gfc_array_index_type
, tmp
));
5497 /* Sanity check that they are the same. This should always be
5498 the case, as we should already have checked for conformance. */
5499 if (!tree_int_cst_equal (slen
, dlen
))
5502 return gfc_build_memcpy_call (dst
, src
, dlen
);
5506 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5507 this can't be done. EXPR1 is the destination/lhs for which
5508 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5511 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5513 unsigned HOST_WIDE_INT nelem
;
5519 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5523 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5524 dtype
= TREE_TYPE (dst
);
5525 if (POINTER_TYPE_P (dtype
))
5526 dtype
= TREE_TYPE (dtype
);
5527 if (!GFC_ARRAY_TYPE_P (dtype
))
5530 /* Determine the lengths of the array. */
5531 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5532 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5535 /* Confirm that the constructor is the same size. */
5536 if (compare_tree_int (len
, nelem
) != 0)
5539 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5540 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5541 fold_convert (gfc_array_index_type
, tmp
));
5543 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5544 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5546 stype
= TREE_TYPE (src
);
5547 if (POINTER_TYPE_P (stype
))
5548 stype
= TREE_TYPE (stype
);
5550 return gfc_build_memcpy_call (dst
, src
, len
);
5554 /* Tells whether the expression is to be treated as a variable reference. */
5557 expr_is_variable (gfc_expr
*expr
)
5561 if (expr
->expr_type
== EXPR_VARIABLE
)
5564 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
5567 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
5568 return expr_is_variable (arg
);
5575 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5576 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5577 init_flag indicates initialization expressions and dealloc that no
5578 deallocate prior assignment is needed (if in doubt, set true). */
5581 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5587 gfc_ss
*lss_section
;
5594 bool scalar_to_array
;
5598 /* Assignment of the form lhs = rhs. */
5599 gfc_start_block (&block
);
5601 gfc_init_se (&lse
, NULL
);
5602 gfc_init_se (&rse
, NULL
);
5605 lss
= gfc_walk_expr (expr1
);
5607 if (lss
!= gfc_ss_terminator
)
5609 /* Allow the scalarizer to workshare array assignments. */
5610 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5611 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5613 /* The assignment needs scalarization. */
5616 /* Find a non-scalar SS from the lhs. */
5617 while (lss_section
!= gfc_ss_terminator
5618 && lss_section
->type
!= GFC_SS_SECTION
)
5619 lss_section
= lss_section
->next
;
5621 gcc_assert (lss_section
!= gfc_ss_terminator
);
5623 /* Initialize the scalarizer. */
5624 gfc_init_loopinfo (&loop
);
5627 rss
= gfc_walk_expr (expr2
);
5628 if (rss
== gfc_ss_terminator
)
5630 /* The rhs is scalar. Add a ss for the expression. */
5631 rss
= gfc_get_ss ();
5632 rss
->next
= gfc_ss_terminator
;
5633 rss
->type
= GFC_SS_SCALAR
;
5636 /* Associate the SS with the loop. */
5637 gfc_add_ss_to_loop (&loop
, lss
);
5638 gfc_add_ss_to_loop (&loop
, rss
);
5640 /* Calculate the bounds of the scalarization. */
5641 gfc_conv_ss_startstride (&loop
);
5642 /* Enable loop reversal. */
5643 for (n
= 0; n
< loop
.dimen
; n
++)
5644 loop
.reverse
[n
] = GFC_REVERSE_NOT_SET
;
5645 /* Resolve any data dependencies in the statement. */
5646 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5647 /* Setup the scalarizing loops. */
5648 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5650 /* Setup the gfc_se structures. */
5651 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5652 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5655 gfc_mark_ss_chain_used (rss
, 1);
5656 if (loop
.temp_ss
== NULL
)
5659 gfc_mark_ss_chain_used (lss
, 1);
5663 lse
.ss
= loop
.temp_ss
;
5664 gfc_mark_ss_chain_used (lss
, 3);
5665 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5668 /* Start the scalarized loop body. */
5669 gfc_start_scalarized_body (&loop
, &body
);
5672 gfc_init_block (&body
);
5674 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5676 /* Translate the expression. */
5677 gfc_conv_expr (&rse
, expr2
);
5679 /* Stabilize a string length for temporaries. */
5680 if (expr2
->ts
.type
== BT_CHARACTER
)
5681 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5683 string_length
= NULL_TREE
;
5687 gfc_conv_tmp_array_ref (&lse
);
5688 if (expr2
->ts
.type
== BT_CHARACTER
)
5689 lse
.string_length
= string_length
;
5692 gfc_conv_expr (&lse
, expr1
);
5694 /* Assignments of scalar derived types with allocatable components
5695 to arrays must be done with a deep copy and the rhs temporary
5696 must have its components deallocated afterwards. */
5697 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5698 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5699 && !expr_is_variable (expr2
)
5700 && !gfc_is_constant_expr (expr2
)
5701 && expr1
->rank
&& !expr2
->rank
);
5702 if (scalar_to_array
&& dealloc
)
5704 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5705 gfc_add_expr_to_block (&loop
.post
, tmp
);
5708 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5709 l_is_temp
|| init_flag
,
5710 expr_is_variable (expr2
) || scalar_to_array
,
5712 gfc_add_expr_to_block (&body
, tmp
);
5714 if (lss
== gfc_ss_terminator
)
5716 /* Use the scalar assignment as is. */
5717 gfc_add_block_to_block (&block
, &body
);
5721 gcc_assert (lse
.ss
== gfc_ss_terminator
5722 && rse
.ss
== gfc_ss_terminator
);
5726 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5728 /* We need to copy the temporary to the actual lhs. */
5729 gfc_init_se (&lse
, NULL
);
5730 gfc_init_se (&rse
, NULL
);
5731 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5732 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5734 rse
.ss
= loop
.temp_ss
;
5737 gfc_conv_tmp_array_ref (&rse
);
5738 gfc_conv_expr (&lse
, expr1
);
5740 gcc_assert (lse
.ss
== gfc_ss_terminator
5741 && rse
.ss
== gfc_ss_terminator
);
5743 if (expr2
->ts
.type
== BT_CHARACTER
)
5744 rse
.string_length
= string_length
;
5746 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5747 false, false, dealloc
);
5748 gfc_add_expr_to_block (&body
, tmp
);
5751 /* Generate the copying loops. */
5752 gfc_trans_scalarizing_loops (&loop
, &body
);
5754 /* Wrap the whole thing up. */
5755 gfc_add_block_to_block (&block
, &loop
.pre
);
5756 gfc_add_block_to_block (&block
, &loop
.post
);
5758 gfc_cleanup_loop (&loop
);
5761 return gfc_finish_block (&block
);
5765 /* Check whether EXPR is a copyable array. */
5768 copyable_array_p (gfc_expr
* expr
)
5770 if (expr
->expr_type
!= EXPR_VARIABLE
)
5773 /* First check it's an array. */
5774 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5777 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5780 /* Next check that it's of a simple enough type. */
5781 switch (expr
->ts
.type
)
5793 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5802 /* Translate an assignment. */
5805 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5810 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
5812 gfc_error ("Assignment to deferred-length character variable at %L "
5813 "not implemented", &expr1
->where
);
5817 /* Special case a single function returning an array. */
5818 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5820 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5825 /* Special case assigning an array to zero. */
5826 if (copyable_array_p (expr1
)
5827 && is_zero_initializer_p (expr2
))
5829 tmp
= gfc_trans_zero_assign (expr1
);
5834 /* Special case copying one array to another. */
5835 if (copyable_array_p (expr1
)
5836 && copyable_array_p (expr2
)
5837 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
5838 && !gfc_check_dependency (expr1
, expr2
, 0))
5840 tmp
= gfc_trans_array_copy (expr1
, expr2
);
5845 /* Special case initializing an array from a constant array constructor. */
5846 if (copyable_array_p (expr1
)
5847 && expr2
->expr_type
== EXPR_ARRAY
5848 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
5850 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
5855 /* Fallback to the scalarizer to generate explicit loops. */
5856 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
5860 gfc_trans_init_assign (gfc_code
* code
)
5862 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
5866 gfc_trans_assign (gfc_code
* code
)
5868 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
5872 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
5873 A MEMCPY is needed to copy the full data from the default initializer
5874 of the dynamic type. */
5877 gfc_trans_class_init_assign (gfc_code
*code
)
5881 gfc_se dst
,src
,memsz
;
5882 gfc_expr
*lhs
,*rhs
,*sz
;
5884 gfc_start_block (&block
);
5886 lhs
= gfc_copy_expr (code
->expr1
);
5887 gfc_add_data_component (lhs
);
5889 rhs
= gfc_copy_expr (code
->expr1
);
5890 gfc_add_vptr_component (rhs
);
5891 gfc_add_def_init_component (rhs
);
5893 sz
= gfc_copy_expr (code
->expr1
);
5894 gfc_add_vptr_component (sz
);
5895 gfc_add_size_component (sz
);
5897 gfc_init_se (&dst
, NULL
);
5898 gfc_init_se (&src
, NULL
);
5899 gfc_init_se (&memsz
, NULL
);
5900 gfc_conv_expr (&dst
, lhs
);
5901 gfc_conv_expr (&src
, rhs
);
5902 gfc_conv_expr (&memsz
, sz
);
5903 gfc_add_block_to_block (&block
, &src
.pre
);
5904 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
5905 gfc_add_expr_to_block (&block
, tmp
);
5907 return gfc_finish_block (&block
);
5911 /* Translate an assignment to a CLASS object
5912 (pointer or ordinary assignment). */
5915 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
5922 gfc_start_block (&block
);
5924 if (expr2
->ts
.type
!= BT_CLASS
)
5926 /* Insert an additional assignment which sets the '_vptr' field. */
5927 lhs
= gfc_copy_expr (expr1
);
5928 gfc_add_vptr_component (lhs
);
5929 if (expr2
->ts
.type
== BT_DERIVED
)
5933 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
5935 rhs
= gfc_get_expr ();
5936 rhs
->expr_type
= EXPR_VARIABLE
;
5937 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
5941 else if (expr2
->expr_type
== EXPR_NULL
)
5942 rhs
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
5946 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
5947 gfc_add_expr_to_block (&block
, tmp
);
5949 gfc_free_expr (lhs
);
5950 gfc_free_expr (rhs
);
5953 /* Do the actual CLASS assignment. */
5954 if (expr2
->ts
.type
== BT_CLASS
)
5957 gfc_add_data_component (expr1
);
5959 if (op
== EXEC_ASSIGN
)
5960 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
5961 else if (op
== EXEC_POINTER_ASSIGN
)
5962 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
5966 gfc_add_expr_to_block (&block
, tmp
);
5968 return gfc_finish_block (&block
);