1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
54 dest
->loop
= src
->loop
;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
67 memset (se
, 0, sizeof (gfc_se
));
68 gfc_init_block (&se
->pre
);
69 gfc_init_block (&se
->post
);
74 gfc_copy_se_loopvars (se
, parent
);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se
* se
)
87 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se
* se
)
111 if (CONSTANT_CLASS_P (se
->expr
))
114 /* We need a temporary for this result. */
115 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
116 gfc_add_modify (&se
->pre
, var
, se
->expr
);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol
* sym
)
129 gcc_assert (sym
->attr
.dummy
);
131 decl
= gfc_get_symbol_decl (sym
);
132 if (TREE_CODE (decl
) != PARM_DECL
)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
138 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
144 /* Fortran 2008 allows to pass null pointers and non-associated pointers
145 as actual argument to denote absent dummies. For array descriptors,
146 we thus also need to check the array descriptor. */
147 if (!sym
->attr
.pointer
&& !sym
->attr
.allocatable
148 && sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
149 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
152 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
153 tmp
= gfc_conv_array_data (tmp
);
154 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
155 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
156 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
157 boolean_type_node
, cond
, tmp
);
164 /* Converts a missing, dummy argument into a null or zero. */
167 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
172 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
176 /* Create a temporary and convert it to the correct type. */
177 tmp
= gfc_get_int_type (kind
);
178 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
181 /* Test for a NULL value. */
182 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
183 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
184 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
185 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
189 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
191 build_zero_cst (TREE_TYPE (se
->expr
)));
192 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
196 if (ts
.type
== BT_CHARACTER
)
198 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
199 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
200 present
, se
->string_length
, tmp
);
201 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
202 se
->string_length
= tmp
;
208 /* Get the character length of an expression, looking through gfc_refs
212 gfc_get_expr_charlen (gfc_expr
*e
)
217 gcc_assert (e
->expr_type
== EXPR_VARIABLE
218 && e
->ts
.type
== BT_CHARACTER
);
220 length
= NULL
; /* To silence compiler warning. */
222 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
225 gfc_init_se (&tmpse
, NULL
);
226 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
227 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
231 /* First candidate: if the variable is of type CHARACTER, the
232 expression's length could be the length of the character
234 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
235 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
237 /* Look through the reference chain for component references. */
238 for (r
= e
->ref
; r
; r
= r
->next
)
243 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
244 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
252 /* We should never got substring references here. These will be
253 broken down by the scalarizer. */
259 gcc_assert (length
!= NULL
);
264 /* For each character array constructor subexpression without a ts.u.cl->length,
265 replace it by its first element (if there aren't any elements, the length
266 should already be set to zero). */
269 flatten_array_ctors_without_strlen (gfc_expr
* e
)
271 gfc_actual_arglist
* arg
;
277 switch (e
->expr_type
)
281 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
282 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
286 /* TODO: Implement as with EXPR_FUNCTION when needed. */
290 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
291 flatten_array_ctors_without_strlen (arg
->expr
);
296 /* We've found what we're looking for. */
297 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
302 gcc_assert (e
->value
.constructor
);
304 c
= gfc_constructor_first (e
->value
.constructor
);
308 flatten_array_ctors_without_strlen (new_expr
);
309 gfc_replace_expr (e
, new_expr
);
313 /* Otherwise, fall through to handle constructor elements. */
315 for (c
= gfc_constructor_first (e
->value
.constructor
);
316 c
; c
= gfc_constructor_next (c
))
317 flatten_array_ctors_without_strlen (c
->expr
);
327 /* Generate code to initialize a string length variable. Returns the
328 value. For array constructors, cl->length might be NULL and in this case,
329 the first element of the constructor is needed. expr is the original
330 expression so we can access it but can be NULL if this is not needed. */
333 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
337 gfc_init_se (&se
, NULL
);
341 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
344 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
345 "flatten" array constructors by taking their first element; all elements
346 should be the same length or a cl->length should be present. */
351 expr_flat
= gfc_copy_expr (expr
);
352 flatten_array_ctors_without_strlen (expr_flat
);
353 gfc_resolve_expr (expr_flat
);
355 gfc_conv_expr (&se
, expr_flat
);
356 gfc_add_block_to_block (pblock
, &se
.pre
);
357 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
359 gfc_free_expr (expr_flat
);
363 /* Convert cl->length. */
365 gcc_assert (cl
->length
);
367 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
368 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
369 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
370 gfc_add_block_to_block (pblock
, &se
.pre
);
372 if (cl
->backend_decl
)
373 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
375 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
380 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
381 const char *name
, locus
*where
)
390 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
391 type
= build_pointer_type (type
);
393 gfc_init_se (&start
, se
);
394 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
395 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
397 if (integer_onep (start
.expr
))
398 gfc_conv_string_parameter (se
);
403 /* Avoid multiple evaluation of substring start. */
404 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
405 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
407 /* Change the start of the string. */
408 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
411 tmp
= build_fold_indirect_ref_loc (input_location
,
413 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
414 se
->expr
= gfc_build_addr_expr (type
, tmp
);
417 /* Length = end + 1 - start. */
418 gfc_init_se (&end
, se
);
419 if (ref
->u
.ss
.end
== NULL
)
420 end
.expr
= se
->string_length
;
423 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
424 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
428 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
429 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
431 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
433 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
434 boolean_type_node
, start
.expr
,
437 /* Check lower bound. */
438 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
440 build_int_cst (gfc_charlen_type_node
, 1));
441 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
442 boolean_type_node
, nonempty
, fault
);
444 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
445 "is less than one", name
);
447 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
449 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
450 fold_convert (long_integer_type_node
,
454 /* Check upper bound. */
455 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
456 end
.expr
, se
->string_length
);
457 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
458 boolean_type_node
, nonempty
, fault
);
460 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
461 "exceeds string length (%%ld)", name
);
463 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
464 "exceeds string length (%%ld)");
465 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
466 fold_convert (long_integer_type_node
, end
.expr
),
467 fold_convert (long_integer_type_node
,
472 /* If the start and end expressions are equal, the length is one. */
474 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
475 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
478 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
479 end
.expr
, start
.expr
);
480 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
481 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
482 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
483 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
486 se
->string_length
= tmp
;
490 /* Convert a derived type component reference. */
493 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
500 c
= ref
->u
.c
.component
;
502 gcc_assert (c
->backend_decl
);
504 field
= c
->backend_decl
;
505 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
507 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
508 decl
, field
, NULL_TREE
);
512 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
514 tmp
= c
->ts
.u
.cl
->backend_decl
;
515 /* Components must always be constant length. */
516 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
517 se
->string_length
= tmp
;
520 if (((c
->attr
.pointer
|| c
->attr
.allocatable
) && c
->attr
.dimension
== 0
521 && c
->ts
.type
!= BT_CHARACTER
)
522 || c
->attr
.proc_pointer
)
523 se
->expr
= build_fold_indirect_ref_loc (input_location
,
528 /* This function deals with component references to components of the
529 parent type for derived type extensons. */
531 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
539 c
= ref
->u
.c
.component
;
541 /* Return if the component is not in the parent type. */
542 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
543 if (strcmp (c
->name
, cmp
->name
) == 0)
546 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
547 parent
.type
= REF_COMPONENT
;
550 parent
.u
.c
.component
= dt
->components
;
552 if (dt
->backend_decl
== NULL
)
553 gfc_get_derived_type (dt
);
555 /* Build the reference and call self. */
556 gfc_conv_component_ref (se
, &parent
);
557 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
558 parent
.u
.c
.component
= c
;
559 conv_parent_component_references (se
, &parent
);
562 /* Return the contents of a variable. Also handles reference/pointer
563 variables (all Fortran pointer references are implicit). */
566 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
570 tree parent_decl
= NULL_TREE
;
573 bool alternate_entry
;
576 sym
= expr
->symtree
->n
.sym
;
579 /* Check that something hasn't gone horribly wrong. */
580 gcc_assert (se
->ss
!= gfc_ss_terminator
);
581 gcc_assert (se
->ss
->expr
== expr
);
583 /* A scalarized term. We already know the descriptor. */
584 se
->expr
= se
->ss
->data
.info
.descriptor
;
585 se
->string_length
= se
->ss
->string_length
;
586 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
587 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
592 tree se_expr
= NULL_TREE
;
594 se
->expr
= gfc_get_symbol_decl (sym
);
596 /* Deal with references to a parent results or entries by storing
597 the current_function_decl and moving to the parent_decl. */
598 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
599 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
600 && sym
->result
== sym
;
601 entry_master
= sym
->attr
.result
602 && sym
->ns
->proc_name
->attr
.entry_master
603 && !gfc_return_by_reference (sym
->ns
->proc_name
);
604 if (current_function_decl
)
605 parent_decl
= DECL_CONTEXT (current_function_decl
);
607 if ((se
->expr
== parent_decl
&& return_value
)
608 || (sym
->ns
&& sym
->ns
->proc_name
610 && sym
->ns
->proc_name
->backend_decl
== parent_decl
611 && (alternate_entry
|| entry_master
)))
616 /* Special case for assigning the return value of a function.
617 Self recursive functions must have an explicit return value. */
618 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
619 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
621 /* Similarly for alternate entry points. */
622 else if (alternate_entry
623 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
626 gfc_entry_list
*el
= NULL
;
628 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
631 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
636 else if (entry_master
637 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
639 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
644 /* Procedure actual arguments. */
645 else if (sym
->attr
.flavor
== FL_PROCEDURE
646 && se
->expr
!= current_function_decl
)
648 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
650 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
651 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
657 /* Dereference the expression, where needed. Since characters
658 are entirely different from other types, they are treated
660 if (sym
->ts
.type
== BT_CHARACTER
)
662 /* Dereference character pointer dummy arguments
664 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
666 || sym
->attr
.function
667 || sym
->attr
.result
))
668 se
->expr
= build_fold_indirect_ref_loc (input_location
,
672 else if (!sym
->attr
.value
)
674 /* Dereference non-character scalar dummy arguments. */
675 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
676 se
->expr
= build_fold_indirect_ref_loc (input_location
,
679 /* Dereference scalar hidden result. */
680 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
681 && (sym
->attr
.function
|| sym
->attr
.result
)
682 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
683 && !sym
->attr
.always_explicit
)
684 se
->expr
= build_fold_indirect_ref_loc (input_location
,
687 /* Dereference non-character pointer variables.
688 These must be dummies, results, or scalars. */
689 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
690 || gfc_is_associate_pointer (sym
))
692 || sym
->attr
.function
694 || !sym
->attr
.dimension
))
695 se
->expr
= build_fold_indirect_ref_loc (input_location
,
702 /* For character variables, also get the length. */
703 if (sym
->ts
.type
== BT_CHARACTER
)
705 /* If the character length of an entry isn't set, get the length from
706 the master function instead. */
707 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
708 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
710 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
711 gcc_assert (se
->string_length
);
719 /* Return the descriptor if that's what we want and this is an array
720 section reference. */
721 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
723 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
724 /* Return the descriptor for array pointers and allocations. */
726 && ref
->next
== NULL
&& (se
->descriptor_only
))
729 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
730 /* Return a pointer to an element. */
734 if (ref
->u
.c
.sym
->attr
.extension
)
735 conv_parent_component_references (se
, ref
);
737 gfc_conv_component_ref (se
, ref
);
741 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
742 expr
->symtree
->name
, &expr
->where
);
751 /* Pointer assignment, allocation or pass by reference. Arrays are handled
753 if (se
->want_pointer
)
755 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
756 gfc_conv_string_parameter (se
);
758 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
763 /* Unary ops are easy... Or they would be if ! was a valid op. */
766 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
771 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
772 /* Initialize the operand. */
773 gfc_init_se (&operand
, se
);
774 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
775 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
777 type
= gfc_typenode_for_spec (&expr
->ts
);
779 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
780 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
781 All other unary operators have an equivalent GIMPLE unary operator. */
782 if (code
== TRUTH_NOT_EXPR
)
783 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
784 build_int_cst (type
, 0));
786 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
790 /* Expand power operator to optimal multiplications when a value is raised
791 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
792 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
793 Programming", 3rd Edition, 1998. */
795 /* This code is mostly duplicated from expand_powi in the backend.
796 We establish the "optimal power tree" lookup table with the defined size.
797 The items in the table are the exponents used to calculate the index
798 exponents. Any integer n less than the value can get an "addition chain",
799 with the first node being one. */
800 #define POWI_TABLE_SIZE 256
802 /* The table is from builtins.c. */
803 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
805 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
806 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
807 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
808 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
809 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
810 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
811 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
812 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
813 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
814 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
815 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
816 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
817 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
818 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
819 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
820 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
821 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
822 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
823 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
824 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
825 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
826 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
827 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
828 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
829 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
830 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
831 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
832 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
833 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
834 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
835 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
836 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
839 /* If n is larger than lookup table's max index, we use the "window
841 #define POWI_WINDOW_SIZE 3
843 /* Recursive function to expand the power operator. The temporary
844 values are put in tmpvar. The function returns tmpvar[1] ** n. */
846 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
853 if (n
< POWI_TABLE_SIZE
)
858 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
859 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
863 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
864 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
865 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
869 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
873 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
874 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
876 if (n
< POWI_TABLE_SIZE
)
883 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
884 return 1. Else return 0 and a call to runtime library functions
885 will have to be built. */
887 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
892 tree vartmp
[POWI_TABLE_SIZE
];
894 unsigned HOST_WIDE_INT n
;
897 /* If exponent is too large, we won't expand it anyway, so don't bother
898 with large integer values. */
899 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
902 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
903 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
904 of the asymmetric range of the integer type. */
905 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
907 type
= TREE_TYPE (lhs
);
908 sgn
= tree_int_cst_sgn (rhs
);
910 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
911 || optimize_size
) && (m
> 2 || m
< -1))
917 se
->expr
= gfc_build_const (type
, integer_one_node
);
921 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
922 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
924 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
925 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
926 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
927 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
930 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
933 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
934 boolean_type_node
, tmp
, cond
);
935 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
936 tmp
, build_int_cst (type
, 1),
937 build_int_cst (type
, 0));
941 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
942 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
943 build_int_cst (type
, -1),
944 build_int_cst (type
, 0));
945 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
946 cond
, build_int_cst (type
, 1), tmp
);
950 memset (vartmp
, 0, sizeof (vartmp
));
954 tmp
= gfc_build_const (type
, integer_one_node
);
955 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
959 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
965 /* Power op (**). Constant integer exponent has special handling. */
968 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
970 tree gfc_int4_type_node
;
973 int res_ikind_1
, res_ikind_2
;
978 gfc_init_se (&lse
, se
);
979 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
980 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
981 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
983 gfc_init_se (&rse
, se
);
984 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
985 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
987 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
988 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
989 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
992 gfc_int4_type_node
= gfc_get_int_type (4);
994 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
995 library routine. But in the end, we have to convert the result back
996 if this case applies -- with res_ikind_K, we keep track whether operand K
997 falls into this case. */
1001 kind
= expr
->value
.op
.op1
->ts
.kind
;
1002 switch (expr
->value
.op
.op2
->ts
.type
)
1005 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1010 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1011 res_ikind_2
= ikind
;
1033 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
1035 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1062 switch (expr
->value
.op
.op1
->ts
.type
)
1065 if (kind
== 3) /* Case 16 was not handled properly above. */
1067 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1071 /* Use builtins for real ** int4. */
1077 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1081 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1085 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1089 /* Use the __builtin_powil() only if real(kind=16) is
1090 actually the C long double type. */
1091 if (!gfc_real16_is_float128
)
1092 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1100 /* If we don't have a good builtin for this, go for the
1101 library function. */
1103 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1107 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1116 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
1120 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
1128 se
->expr
= build_call_expr_loc (input_location
,
1129 fndecl
, 2, lse
.expr
, rse
.expr
);
1131 /* Convert the result back if it is of wrong integer kind. */
1132 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
1134 /* We want the maximum of both operand kinds as result. */
1135 if (res_ikind_1
< res_ikind_2
)
1136 res_ikind_1
= res_ikind_2
;
1137 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
1142 /* Generate code to allocate a string temporary. */
1145 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1150 if (gfc_can_put_var_on_stack (len
))
1152 /* Create a temporary variable to hold the result. */
1153 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1154 gfc_charlen_type_node
, len
,
1155 build_int_cst (gfc_charlen_type_node
, 1));
1156 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1158 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1159 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1161 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1163 var
= gfc_create_var (tmp
, "str");
1164 var
= gfc_build_addr_expr (type
, var
);
1168 /* Allocate a temporary to hold the result. */
1169 var
= gfc_create_var (type
, "pstr");
1170 tmp
= gfc_call_malloc (&se
->pre
, type
,
1171 fold_build2_loc (input_location
, MULT_EXPR
,
1172 TREE_TYPE (len
), len
,
1173 fold_convert (TREE_TYPE (len
),
1174 TYPE_SIZE (type
))));
1175 gfc_add_modify (&se
->pre
, var
, tmp
);
1177 /* Free the temporary afterwards. */
1178 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1179 gfc_add_expr_to_block (&se
->post
, tmp
);
1186 /* Handle a string concatenation operation. A temporary will be allocated to
1190 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1193 tree len
, type
, var
, tmp
, fndecl
;
1195 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1196 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1197 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1199 gfc_init_se (&lse
, se
);
1200 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1201 gfc_conv_string_parameter (&lse
);
1202 gfc_init_se (&rse
, se
);
1203 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1204 gfc_conv_string_parameter (&rse
);
1206 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1207 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1209 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1210 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1211 if (len
== NULL_TREE
)
1213 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
1214 TREE_TYPE (lse
.string_length
),
1215 lse
.string_length
, rse
.string_length
);
1218 type
= build_pointer_type (type
);
1220 var
= gfc_conv_string_tmp (se
, type
, len
);
1222 /* Do the actual concatenation. */
1223 if (expr
->ts
.kind
== 1)
1224 fndecl
= gfor_fndecl_concat_string
;
1225 else if (expr
->ts
.kind
== 4)
1226 fndecl
= gfor_fndecl_concat_string_char4
;
1230 tmp
= build_call_expr_loc (input_location
,
1231 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1232 rse
.string_length
, rse
.expr
);
1233 gfc_add_expr_to_block (&se
->pre
, tmp
);
1235 /* Add the cleanup for the operands. */
1236 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1237 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1240 se
->string_length
= len
;
1243 /* Translates an op expression. Common (binary) cases are handled by this
1244 function, others are passed on. Recursion is used in either case.
1245 We use the fact that (op1.ts == op2.ts) (except for the power
1247 Operators need no special handling for scalarized expressions as long as
1248 they call gfc_conv_simple_val to get their operands.
1249 Character strings get special handling. */
1252 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1254 enum tree_code code
;
1263 switch (expr
->value
.op
.op
)
1265 case INTRINSIC_PARENTHESES
:
1266 if ((expr
->ts
.type
== BT_REAL
1267 || expr
->ts
.type
== BT_COMPLEX
)
1268 && gfc_option
.flag_protect_parens
)
1270 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1271 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1276 case INTRINSIC_UPLUS
:
1277 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1280 case INTRINSIC_UMINUS
:
1281 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1285 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1288 case INTRINSIC_PLUS
:
1292 case INTRINSIC_MINUS
:
1296 case INTRINSIC_TIMES
:
1300 case INTRINSIC_DIVIDE
:
1301 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1302 an integer, we must round towards zero, so we use a
1304 if (expr
->ts
.type
== BT_INTEGER
)
1305 code
= TRUNC_DIV_EXPR
;
1310 case INTRINSIC_POWER
:
1311 gfc_conv_power_op (se
, expr
);
1314 case INTRINSIC_CONCAT
:
1315 gfc_conv_concat_op (se
, expr
);
1319 code
= TRUTH_ANDIF_EXPR
;
1324 code
= TRUTH_ORIF_EXPR
;
1328 /* EQV and NEQV only work on logicals, but since we represent them
1329 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1331 case INTRINSIC_EQ_OS
:
1339 case INTRINSIC_NE_OS
:
1340 case INTRINSIC_NEQV
:
1347 case INTRINSIC_GT_OS
:
1354 case INTRINSIC_GE_OS
:
1361 case INTRINSIC_LT_OS
:
1368 case INTRINSIC_LE_OS
:
1374 case INTRINSIC_USER
:
1375 case INTRINSIC_ASSIGN
:
1376 /* These should be converted into function calls by the frontend. */
1380 fatal_error ("Unknown intrinsic op");
1384 /* The only exception to this is **, which is handled separately anyway. */
1385 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1387 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1391 gfc_init_se (&lse
, se
);
1392 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1393 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1396 gfc_init_se (&rse
, se
);
1397 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1398 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1402 gfc_conv_string_parameter (&lse
);
1403 gfc_conv_string_parameter (&rse
);
1405 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1406 rse
.string_length
, rse
.expr
,
1407 expr
->value
.op
.op1
->ts
.kind
,
1409 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1410 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1413 type
= gfc_typenode_for_spec (&expr
->ts
);
1417 /* The result of logical ops is always boolean_type_node. */
1418 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
1419 lse
.expr
, rse
.expr
);
1420 se
->expr
= convert (type
, tmp
);
1423 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
1425 /* Add the post blocks. */
1426 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1427 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1430 /* If a string's length is one, we convert it to a single character. */
1433 gfc_string_to_single_character (tree len
, tree str
, int kind
)
1436 if (!INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
1437 || !POINTER_TYPE_P (TREE_TYPE (str
)))
1440 if (TREE_INT_CST_LOW (len
) == 1)
1442 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1443 return build_fold_indirect_ref_loc (input_location
, str
);
1447 && TREE_CODE (str
) == ADDR_EXPR
1448 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1449 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1450 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1451 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1452 && TREE_INT_CST_LOW (len
) > 1
1453 && TREE_INT_CST_LOW (len
)
1454 == (unsigned HOST_WIDE_INT
)
1455 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1457 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
1458 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
1459 if (TREE_CODE (ret
) == INTEGER_CST
)
1461 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1462 int i
, length
= TREE_STRING_LENGTH (string_cst
);
1463 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1465 for (i
= 1; i
< length
; i
++)
1478 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1481 if (sym
->backend_decl
)
1483 /* This becomes the nominal_type in
1484 function.c:assign_parm_find_data_types. */
1485 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1486 /* This becomes the passed_type in
1487 function.c:assign_parm_find_data_types. C promotes char to
1488 integer for argument passing. */
1489 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1491 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1496 /* If we have a constant character expression, make it into an
1498 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1503 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1504 (int)(*expr
)->value
.character
.string
[0]);
1505 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1507 /* The expr needs to be compatible with a C int. If the
1508 conversion fails, then the 2 causes an ICE. */
1509 ts
.type
= BT_INTEGER
;
1510 ts
.kind
= gfc_c_int_kind
;
1511 gfc_convert_type (*expr
, &ts
, 2);
1514 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1516 if ((*expr
)->ref
== NULL
)
1518 se
->expr
= gfc_string_to_single_character
1519 (build_int_cst (integer_type_node
, 1),
1520 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1522 ((*expr
)->symtree
->n
.sym
)),
1527 gfc_conv_variable (se
, *expr
);
1528 se
->expr
= gfc_string_to_single_character
1529 (build_int_cst (integer_type_node
, 1),
1530 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1538 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1539 if STR is a string literal, otherwise return -1. */
1542 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
1545 && TREE_CODE (str
) == ADDR_EXPR
1546 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1547 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1548 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1549 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1550 && TREE_INT_CST_LOW (len
) >= 1
1551 && TREE_INT_CST_LOW (len
)
1552 == (unsigned HOST_WIDE_INT
)
1553 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1555 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
1556 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
1557 if (TREE_CODE (folded
) == INTEGER_CST
)
1559 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1560 int length
= TREE_STRING_LENGTH (string_cst
);
1561 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1563 for (; length
> 0; length
--)
1564 if (ptr
[length
- 1] != ' ')
1573 /* Compare two strings. If they are all single characters, the result is the
1574 subtraction of them. Otherwise, we build a library call. */
1577 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
1578 enum tree_code code
)
1584 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1585 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1587 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
1588 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
1590 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1592 /* Deal with single character specially. */
1593 sc1
= fold_convert (integer_type_node
, sc1
);
1594 sc2
= fold_convert (integer_type_node
, sc2
);
1595 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
1599 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
1601 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
1603 /* If one string is a string literal with LEN_TRIM longer
1604 than the length of the second string, the strings
1606 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
1607 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
1608 return integer_one_node
;
1609 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
1610 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
1611 return integer_one_node
;
1614 /* Build a call for the comparison. */
1616 fndecl
= gfor_fndecl_compare_string
;
1618 fndecl
= gfor_fndecl_compare_string_char4
;
1622 return build_call_expr_loc (input_location
, fndecl
, 4,
1623 len1
, str1
, len2
, str2
);
1627 /* Return the backend_decl for a procedure pointer component. */
1630 get_proc_ptr_comp (gfc_expr
*e
)
1636 gfc_init_se (&comp_se
, NULL
);
1637 e2
= gfc_copy_expr (e
);
1638 /* We have to restore the expr type later so that gfc_free_expr frees
1639 the exact same thing that was allocated.
1640 TODO: This is ugly. */
1641 old_type
= e2
->expr_type
;
1642 e2
->expr_type
= EXPR_VARIABLE
;
1643 gfc_conv_expr (&comp_se
, e2
);
1644 e2
->expr_type
= old_type
;
1646 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1651 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1655 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1656 tmp
= get_proc_ptr_comp (expr
);
1657 else if (sym
->attr
.dummy
)
1659 tmp
= gfc_get_symbol_decl (sym
);
1660 if (sym
->attr
.proc_pointer
)
1661 tmp
= build_fold_indirect_ref_loc (input_location
,
1663 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1664 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1668 if (!sym
->backend_decl
)
1669 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1671 tmp
= sym
->backend_decl
;
1673 if (sym
->attr
.cray_pointee
)
1675 /* TODO - make the cray pointee a pointer to a procedure,
1676 assign the pointer to it and use it for the call. This
1678 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1679 gfc_get_symbol_decl (sym
->cp_pointer
));
1680 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1683 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1685 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1686 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1693 /* Initialize MAPPING. */
1696 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1698 mapping
->syms
= NULL
;
1699 mapping
->charlens
= NULL
;
1703 /* Free all memory held by MAPPING (but not MAPPING itself). */
1706 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1708 gfc_interface_sym_mapping
*sym
;
1709 gfc_interface_sym_mapping
*nextsym
;
1711 gfc_charlen
*nextcl
;
1713 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1715 nextsym
= sym
->next
;
1716 sym
->new_sym
->n
.sym
->formal
= NULL
;
1717 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1718 gfc_free_expr (sym
->expr
);
1719 gfc_free (sym
->new_sym
);
1722 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1725 gfc_free_expr (cl
->length
);
1731 /* Return a copy of gfc_charlen CL. Add the returned structure to
1732 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1734 static gfc_charlen
*
1735 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1738 gfc_charlen
*new_charlen
;
1740 new_charlen
= gfc_get_charlen ();
1741 new_charlen
->next
= mapping
->charlens
;
1742 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1744 mapping
->charlens
= new_charlen
;
1749 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1750 array variable that can be used as the actual argument for dummy
1751 argument SYM. Add any initialization code to BLOCK. PACKED is as
1752 for gfc_get_nodesc_array_type and DATA points to the first element
1753 in the passed array. */
1756 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1757 gfc_packed packed
, tree data
)
1762 type
= gfc_typenode_for_spec (&sym
->ts
);
1763 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
1764 !sym
->attr
.target
&& !sym
->attr
.pointer
1765 && !sym
->attr
.proc_pointer
);
1767 var
= gfc_create_var (type
, "ifm");
1768 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1774 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1775 and offset of descriptorless array type TYPE given that it has the same
1776 size as DESC. Add any set-up code to BLOCK. */
1779 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1786 offset
= gfc_index_zero_node
;
1787 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1789 dim
= gfc_rank_cst
[n
];
1790 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1791 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1793 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1794 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1795 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1796 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1798 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1800 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1801 gfc_array_index_type
,
1802 gfc_conv_descriptor_ubound_get (desc
, dim
),
1803 gfc_conv_descriptor_lbound_get (desc
, dim
));
1804 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1805 gfc_array_index_type
,
1806 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
1807 tmp
= gfc_evaluate_now (tmp
, block
);
1808 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1810 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1811 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1812 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1813 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1814 gfc_array_index_type
, offset
, tmp
);
1816 offset
= gfc_evaluate_now (offset
, block
);
1817 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1821 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1822 in SE. The caller may still use se->expr and se->string_length after
1823 calling this function. */
1826 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1827 gfc_symbol
* sym
, gfc_se
* se
,
1830 gfc_interface_sym_mapping
*sm
;
1834 gfc_symbol
*new_sym
;
1836 gfc_symtree
*new_symtree
;
1838 /* Create a new symbol to represent the actual argument. */
1839 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1840 new_sym
->ts
= sym
->ts
;
1841 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1842 new_sym
->attr
.referenced
= 1;
1843 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1844 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
1845 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
1846 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1847 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1848 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1849 new_sym
->attr
.function
= sym
->attr
.function
;
1851 /* Ensure that the interface is available and that
1852 descriptors are passed for array actual arguments. */
1853 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1855 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1856 new_sym
->attr
.always_explicit
1857 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1860 /* Create a fake symtree for it. */
1862 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1863 new_symtree
->n
.sym
= new_sym
;
1864 gcc_assert (new_symtree
== root
);
1866 /* Create a dummy->actual mapping. */
1867 sm
= XCNEW (gfc_interface_sym_mapping
);
1868 sm
->next
= mapping
->syms
;
1870 sm
->new_sym
= new_symtree
;
1871 sm
->expr
= gfc_copy_expr (expr
);
1874 /* Stabilize the argument's value. */
1875 if (!sym
->attr
.function
&& se
)
1876 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1878 if (sym
->ts
.type
== BT_CHARACTER
)
1880 /* Create a copy of the dummy argument's length. */
1881 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1882 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1884 /* If the length is specified as "*", record the length that
1885 the caller is passing. We should use the callee's length
1886 in all other cases. */
1887 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1889 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1890 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1897 /* Use the passed value as-is if the argument is a function. */
1898 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1901 /* If the argument is either a string or a pointer to a string,
1902 convert it to a boundless character type. */
1903 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1905 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1906 tmp
= build_pointer_type (tmp
);
1907 if (sym
->attr
.pointer
)
1908 value
= build_fold_indirect_ref_loc (input_location
,
1912 value
= fold_convert (tmp
, value
);
1915 /* If the argument is a scalar, a pointer to an array or an allocatable,
1917 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1918 value
= build_fold_indirect_ref_loc (input_location
,
1921 /* For character(*), use the actual argument's descriptor. */
1922 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1923 value
= build_fold_indirect_ref_loc (input_location
,
1926 /* If the argument is an array descriptor, use it to determine
1927 information about the actual argument's shape. */
1928 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1929 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1931 /* Get the actual argument's descriptor. */
1932 desc
= build_fold_indirect_ref_loc (input_location
,
1935 /* Create the replacement variable. */
1936 tmp
= gfc_conv_descriptor_data_get (desc
);
1937 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1940 /* Use DESC to work out the upper bounds, strides and offset. */
1941 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1944 /* Otherwise we have a packed array. */
1945 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1946 PACKED_FULL
, se
->expr
);
1948 new_sym
->backend_decl
= value
;
1952 /* Called once all dummy argument mappings have been added to MAPPING,
1953 but before the mapping is used to evaluate expressions. Pre-evaluate
1954 the length of each argument, adding any initialization code to PRE and
1955 any finalization code to POST. */
1958 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1959 stmtblock_t
* pre
, stmtblock_t
* post
)
1961 gfc_interface_sym_mapping
*sym
;
1965 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1966 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1967 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1969 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1970 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1971 gfc_init_se (&se
, NULL
);
1972 gfc_conv_expr (&se
, expr
);
1973 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1974 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1975 gfc_add_block_to_block (pre
, &se
.pre
);
1976 gfc_add_block_to_block (post
, &se
.post
);
1978 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1983 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1987 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1988 gfc_constructor_base base
)
1991 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1993 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1996 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1997 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1998 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2004 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2008 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2013 for (; ref
; ref
= ref
->next
)
2017 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2019 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2020 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2021 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2023 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2030 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2031 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2037 /* Convert intrinsic function calls into result expressions. */
2040 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2048 arg1
= expr
->value
.function
.actual
->expr
;
2049 if (expr
->value
.function
.actual
->next
)
2050 arg2
= expr
->value
.function
.actual
->next
->expr
;
2054 sym
= arg1
->symtree
->n
.sym
;
2056 if (sym
->attr
.dummy
)
2061 switch (expr
->value
.function
.isym
->id
)
2064 /* TODO figure out why this condition is necessary. */
2065 if (sym
->attr
.function
2066 && (arg1
->ts
.u
.cl
->length
== NULL
2067 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2068 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2071 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2075 if (!sym
->as
|| sym
->as
->rank
== 0)
2078 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2080 dup
= mpz_get_si (arg2
->value
.integer
);
2085 dup
= sym
->as
->rank
;
2089 for (; d
< dup
; d
++)
2093 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2095 gfc_free_expr (new_expr
);
2099 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
2100 gfc_get_int_expr (gfc_default_integer_kind
,
2102 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2104 new_expr
= gfc_multiply (new_expr
, tmp
);
2110 case GFC_ISYM_LBOUND
:
2111 case GFC_ISYM_UBOUND
:
2112 /* TODO These implementations of lbound and ubound do not limit if
2113 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2115 if (!sym
->as
|| sym
->as
->rank
== 0)
2118 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2119 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2121 /* TODO: If the need arises, this could produce an array of
2125 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2127 if (sym
->as
->lower
[d
])
2128 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2132 if (sym
->as
->upper
[d
])
2133 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2141 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2145 gfc_replace_expr (expr
, new_expr
);
2151 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2152 gfc_interface_mapping
* mapping
)
2154 gfc_formal_arglist
*f
;
2155 gfc_actual_arglist
*actual
;
2157 actual
= expr
->value
.function
.actual
;
2158 f
= map_expr
->symtree
->n
.sym
->formal
;
2160 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2165 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2168 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2173 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2175 for (d
= 0; d
< as
->rank
; d
++)
2177 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2178 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2181 expr
->value
.function
.esym
->as
= as
;
2184 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2186 expr
->value
.function
.esym
->ts
.u
.cl
->length
2187 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2189 gfc_apply_interface_mapping_to_expr (mapping
,
2190 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2195 /* EXPR is a copy of an expression that appeared in the interface
2196 associated with MAPPING. Walk it recursively looking for references to
2197 dummy arguments that MAPPING maps to actual arguments. Replace each such
2198 reference with a reference to the associated actual argument. */
2201 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2204 gfc_interface_sym_mapping
*sym
;
2205 gfc_actual_arglist
*actual
;
2210 /* Copying an expression does not copy its length, so do that here. */
2211 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2213 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2214 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2217 /* Apply the mapping to any references. */
2218 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2220 /* ...and to the expression's symbol, if it has one. */
2221 /* TODO Find out why the condition on expr->symtree had to be moved into
2222 the loop rather than being outside it, as originally. */
2223 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2224 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2226 if (sym
->new_sym
->n
.sym
->backend_decl
)
2227 expr
->symtree
= sym
->new_sym
;
2229 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2232 /* ...and to subexpressions in expr->value. */
2233 switch (expr
->expr_type
)
2238 case EXPR_SUBSTRING
:
2242 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2243 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2247 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2248 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2250 if (expr
->value
.function
.esym
== NULL
2251 && expr
->value
.function
.isym
!= NULL
2252 && expr
->value
.function
.actual
->expr
->symtree
2253 && gfc_map_intrinsic_function (expr
, mapping
))
2256 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2257 if (sym
->old
== expr
->value
.function
.esym
)
2259 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2260 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2261 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2266 case EXPR_STRUCTURE
:
2267 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2280 /* Evaluate interface expression EXPR using MAPPING. Store the result
2284 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2285 gfc_se
* se
, gfc_expr
* expr
)
2287 expr
= gfc_copy_expr (expr
);
2288 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2289 gfc_conv_expr (se
, expr
);
2290 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2291 gfc_free_expr (expr
);
2295 /* Returns a reference to a temporary array into which a component of
2296 an actual argument derived type array is copied and then returned
2297 after the function call. */
2299 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2300 sym_intent intent
, bool formal_ptr
)
2318 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2320 gfc_init_se (&lse
, NULL
);
2321 gfc_init_se (&rse
, NULL
);
2323 /* Walk the argument expression. */
2324 rss
= gfc_walk_expr (expr
);
2326 gcc_assert (rss
!= gfc_ss_terminator
);
2328 /* Initialize the scalarizer. */
2329 gfc_init_loopinfo (&loop
);
2330 gfc_add_ss_to_loop (&loop
, rss
);
2332 /* Calculate the bounds of the scalarization. */
2333 gfc_conv_ss_startstride (&loop
);
2335 /* Build an ss for the temporary. */
2336 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2337 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2339 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2340 if (GFC_ARRAY_TYPE_P (base_type
)
2341 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2342 base_type
= gfc_get_element_type (base_type
);
2344 loop
.temp_ss
= gfc_get_ss ();;
2345 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2346 loop
.temp_ss
->data
.temp
.type
= base_type
;
2348 if (expr
->ts
.type
== BT_CHARACTER
)
2349 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2351 loop
.temp_ss
->string_length
= NULL
;
2353 parmse
->string_length
= loop
.temp_ss
->string_length
;
2354 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2355 loop
.temp_ss
->next
= gfc_ss_terminator
;
2357 /* Associate the SS with the loop. */
2358 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2360 /* Setup the scalarizing loops. */
2361 gfc_conv_loop_setup (&loop
, &expr
->where
);
2363 /* Pass the temporary descriptor back to the caller. */
2364 info
= &loop
.temp_ss
->data
.info
;
2365 parmse
->expr
= info
->descriptor
;
2367 /* Setup the gfc_se structures. */
2368 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2369 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2372 lse
.ss
= loop
.temp_ss
;
2373 gfc_mark_ss_chain_used (rss
, 1);
2374 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2376 /* Start the scalarized loop body. */
2377 gfc_start_scalarized_body (&loop
, &body
);
2379 /* Translate the expression. */
2380 gfc_conv_expr (&rse
, expr
);
2382 gfc_conv_tmp_array_ref (&lse
);
2384 if (intent
!= INTENT_OUT
)
2386 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
2387 gfc_add_expr_to_block (&body
, tmp
);
2388 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2389 gfc_trans_scalarizing_loops (&loop
, &body
);
2393 /* Make sure that the temporary declaration survives by merging
2394 all the loop declarations into the current context. */
2395 for (n
= 0; n
< loop
.dimen
; n
++)
2397 gfc_merge_block_scope (&body
);
2398 body
= loop
.code
[loop
.order
[n
]];
2400 gfc_merge_block_scope (&body
);
2403 /* Add the post block after the second loop, so that any
2404 freeing of allocated memory is done at the right time. */
2405 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2407 /**********Copy the temporary back again.*********/
2409 gfc_init_se (&lse
, NULL
);
2410 gfc_init_se (&rse
, NULL
);
2412 /* Walk the argument expression. */
2413 lss
= gfc_walk_expr (expr
);
2414 rse
.ss
= loop
.temp_ss
;
2417 /* Initialize the scalarizer. */
2418 gfc_init_loopinfo (&loop2
);
2419 gfc_add_ss_to_loop (&loop2
, lss
);
2421 /* Calculate the bounds of the scalarization. */
2422 gfc_conv_ss_startstride (&loop2
);
2424 /* Setup the scalarizing loops. */
2425 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2427 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2428 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2430 gfc_mark_ss_chain_used (lss
, 1);
2431 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2433 /* Declare the variable to hold the temporary offset and start the
2434 scalarized loop body. */
2435 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2436 gfc_start_scalarized_body (&loop2
, &body
);
2438 /* Build the offsets for the temporary from the loop variables. The
2439 temporary array has lbounds of zero and strides of one in all
2440 dimensions, so this is very simple. The offset is only computed
2441 outside the innermost loop, so the overall transfer could be
2442 optimized further. */
2443 info
= &rse
.ss
->data
.info
;
2444 dimen
= info
->dimen
;
2446 tmp_index
= gfc_index_zero_node
;
2447 for (n
= dimen
- 1; n
> 0; n
--)
2450 tmp
= rse
.loop
->loopvar
[n
];
2451 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2452 tmp
, rse
.loop
->from
[n
]);
2453 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2456 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
2457 gfc_array_index_type
,
2458 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2459 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
2460 gfc_array_index_type
,
2461 tmp_str
, gfc_index_one_node
);
2463 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
2464 gfc_array_index_type
, tmp
, tmp_str
);
2467 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2468 gfc_array_index_type
,
2469 tmp_index
, rse
.loop
->from
[0]);
2470 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2472 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2473 gfc_array_index_type
,
2474 rse
.loop
->loopvar
[0], offset
);
2476 /* Now use the offset for the reference. */
2477 tmp
= build_fold_indirect_ref_loc (input_location
,
2479 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2481 if (expr
->ts
.type
== BT_CHARACTER
)
2482 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2484 gfc_conv_expr (&lse
, expr
);
2486 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2488 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
2489 gfc_add_expr_to_block (&body
, tmp
);
2491 /* Generate the copying loops. */
2492 gfc_trans_scalarizing_loops (&loop2
, &body
);
2494 /* Wrap the whole thing up by adding the second loop to the post-block
2495 and following it by the post-block of the first loop. In this way,
2496 if the temporary needs freeing, it is done after use! */
2497 if (intent
!= INTENT_IN
)
2499 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2500 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2503 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2505 gfc_cleanup_loop (&loop
);
2506 gfc_cleanup_loop (&loop2
);
2508 /* Pass the string length to the argument expression. */
2509 if (expr
->ts
.type
== BT_CHARACTER
)
2510 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2512 /* Determine the offset for pointer formal arguments and set the
2516 size
= gfc_index_one_node
;
2517 offset
= gfc_index_zero_node
;
2518 for (n
= 0; n
< dimen
; n
++)
2520 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2522 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2523 gfc_array_index_type
, tmp
,
2524 gfc_index_one_node
);
2525 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2529 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2532 gfc_index_one_node
);
2533 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2534 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2535 gfc_array_index_type
,
2537 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2538 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2539 gfc_array_index_type
,
2540 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2541 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2542 gfc_array_index_type
,
2543 tmp
, gfc_index_one_node
);
2544 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2545 gfc_array_index_type
, size
, tmp
);
2548 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2552 /* We want either the address for the data or the address of the descriptor,
2553 depending on the mode of passing array arguments. */
2555 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2557 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2563 /* Generate the code for argument list functions. */
2566 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2568 /* Pass by value for g77 %VAL(arg), pass the address
2569 indirectly for %LOC, else by reference. Thus %REF
2570 is a "do-nothing" and %LOC is the same as an F95
2572 if (strncmp (name
, "%VAL", 4) == 0)
2573 gfc_conv_expr (se
, expr
);
2574 else if (strncmp (name
, "%LOC", 4) == 0)
2576 gfc_conv_expr_reference (se
, expr
);
2577 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2579 else if (strncmp (name
, "%REF", 4) == 0)
2580 gfc_conv_expr_reference (se
, expr
);
2582 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2586 /* Takes a derived type expression and returns the address of a temporary
2587 class object of the 'declared' type. */
2589 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
2590 gfc_typespec class_ts
)
2594 gfc_symbol
*declared
= class_ts
.u
.derived
;
2600 /* The derived type needs to be converted to a temporary
2602 tmp
= gfc_typenode_for_spec (&class_ts
);
2603 var
= gfc_create_var (tmp
, "class");
2606 cmp
= gfc_find_component (declared
, "_vptr", true, true);
2607 ctree
= fold_build3_loc (input_location
, COMPONENT_REF
,
2608 TREE_TYPE (cmp
->backend_decl
),
2609 var
, cmp
->backend_decl
, NULL_TREE
);
2611 /* Remember the vtab corresponds to the derived type
2612 not to the class declared type. */
2613 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
2615 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
2616 gfc_add_modify (&parmse
->pre
, ctree
,
2617 fold_convert (TREE_TYPE (ctree
), tmp
));
2619 /* Now set the data field. */
2620 cmp
= gfc_find_component (declared
, "_data", true, true);
2621 ctree
= fold_build3_loc (input_location
, COMPONENT_REF
,
2622 TREE_TYPE (cmp
->backend_decl
),
2623 var
, cmp
->backend_decl
, NULL_TREE
);
2624 ss
= gfc_walk_expr (e
);
2625 if (ss
== gfc_ss_terminator
)
2628 gfc_conv_expr_reference (parmse
, e
);
2629 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
2630 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
2635 gfc_conv_expr (parmse
, e
);
2636 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
2639 /* Pass the address of the class object. */
2640 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2644 /* The following routine generates code for the intrinsic
2645 procedures from the ISO_C_BINDING module:
2647 * C_FUNLOC (function)
2648 * C_F_POINTER (subroutine)
2649 * C_F_PROCPOINTER (subroutine)
2650 * C_ASSOCIATED (function)
2651 One exception which is not handled here is C_F_POINTER with non-scalar
2652 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2655 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2656 gfc_actual_arglist
* arg
)
2661 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2663 if (arg
->expr
->rank
== 0)
2664 gfc_conv_expr_reference (se
, arg
->expr
);
2668 /* This is really the actual arg because no formal arglist is
2669 created for C_LOC. */
2670 fsym
= arg
->expr
->symtree
->n
.sym
;
2672 /* We should want it to do g77 calling convention. */
2674 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2675 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2676 f
= f
|| !sym
->attr
.always_explicit
;
2678 argss
= gfc_walk_expr (arg
->expr
);
2679 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2683 /* TODO -- the following two lines shouldn't be necessary, but if
2684 they're removed, a bug is exposed later in the code path.
2685 This workaround was thus introduced, but will have to be
2686 removed; please see PR 35150 for details about the issue. */
2687 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2688 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2692 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2694 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2695 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2696 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2697 gfc_conv_expr_reference (se
, arg
->expr
);
2701 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2702 && arg
->next
->expr
->rank
== 0)
2703 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2705 /* Convert c_f_pointer if fptr is a scalar
2706 and convert c_f_procpointer. */
2710 gfc_init_se (&cptrse
, NULL
);
2711 gfc_conv_expr (&cptrse
, arg
->expr
);
2712 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2713 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2715 gfc_init_se (&fptrse
, NULL
);
2716 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2717 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2718 fptrse
.want_pointer
= 1;
2720 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2721 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2722 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2724 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2725 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2726 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2729 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2730 TREE_TYPE (fptrse
.expr
),
2732 fold_convert (TREE_TYPE (fptrse
.expr
),
2737 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2742 /* Build the addr_expr for the first argument. The argument is
2743 already an *address* so we don't need to set want_pointer in
2745 gfc_init_se (&arg1se
, NULL
);
2746 gfc_conv_expr (&arg1se
, arg
->expr
);
2747 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2748 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2750 /* See if we were given two arguments. */
2751 if (arg
->next
== NULL
)
2752 /* Only given one arg so generate a null and do a
2753 not-equal comparison against the first arg. */
2754 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2756 fold_convert (TREE_TYPE (arg1se
.expr
),
2757 null_pointer_node
));
2763 /* Given two arguments so build the arg2se from second arg. */
2764 gfc_init_se (&arg2se
, NULL
);
2765 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2766 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2767 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2769 /* Generate test to compare that the two args are equal. */
2770 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2771 arg1se
.expr
, arg2se
.expr
);
2772 /* Generate test to ensure that the first arg is not null. */
2773 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
2775 arg1se
.expr
, null_pointer_node
);
2777 /* Finally, the generated test must check that both arg1 is not
2778 NULL and that it is equal to the second arg. */
2779 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2781 not_null_expr
, eq_expr
);
2787 /* Nothing was done. */
2791 /* Generate code for a procedure call. Note can return se->post != NULL.
2792 If se->direct_byref is set then se->expr contains the return parameter.
2793 Return nonzero, if the call has alternate specifiers.
2794 'expr' is only needed for procedure pointer components. */
2797 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2798 gfc_actual_arglist
* args
, gfc_expr
* expr
,
2799 VEC(tree
,gc
) *append_args
)
2801 gfc_interface_mapping mapping
;
2802 VEC(tree
,gc
) *arglist
;
2803 VEC(tree
,gc
) *retargs
;
2814 VEC(tree
,gc
) *stringargs
;
2816 gfc_formal_arglist
*formal
;
2817 gfc_actual_arglist
*arg
;
2818 int has_alternate_specifier
= 0;
2819 bool need_interface_mapping
;
2826 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2827 gfc_component
*comp
= NULL
;
2837 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2838 && conv_isocbinding_procedure (se
, sym
, args
))
2841 gfc_is_proc_ptr_comp (expr
, &comp
);
2845 if (!sym
->attr
.elemental
)
2847 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2848 if (se
->ss
->useflags
)
2850 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2851 && sym
->result
->attr
.dimension
)
2852 || (comp
&& comp
->attr
.dimension
));
2853 gcc_assert (se
->loop
!= NULL
);
2855 /* Access the previously obtained result. */
2856 gfc_conv_tmp_array_ref (se
);
2860 info
= &se
->ss
->data
.info
;
2865 gfc_init_block (&post
);
2866 gfc_init_interface_mapping (&mapping
);
2869 formal
= sym
->formal
;
2870 need_interface_mapping
= sym
->attr
.dimension
||
2871 (sym
->ts
.type
== BT_CHARACTER
2872 && sym
->ts
.u
.cl
->length
2873 && sym
->ts
.u
.cl
->length
->expr_type
2878 formal
= comp
->formal
;
2879 need_interface_mapping
= comp
->attr
.dimension
||
2880 (comp
->ts
.type
== BT_CHARACTER
2881 && comp
->ts
.u
.cl
->length
2882 && comp
->ts
.u
.cl
->length
->expr_type
2886 /* Evaluate the arguments. */
2887 for (arg
= args
; arg
!= NULL
;
2888 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2891 fsym
= formal
? formal
->sym
: NULL
;
2892 parm_kind
= MISSING
;
2896 if (se
->ignore_optional
)
2898 /* Some intrinsics have already been resolved to the correct
2902 else if (arg
->label
)
2904 has_alternate_specifier
= 1;
2909 /* Pass a NULL pointer for an absent arg. */
2910 gfc_init_se (&parmse
, NULL
);
2911 parmse
.expr
= null_pointer_node
;
2912 if (arg
->missing_arg_type
== BT_CHARACTER
)
2913 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2916 else if (arg
->expr
->expr_type
== EXPR_NULL
&& fsym
&& !fsym
->attr
.pointer
)
2918 /* Pass a NULL pointer to denote an absent arg. */
2919 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
);
2920 gfc_init_se (&parmse
, NULL
);
2921 parmse
.expr
= null_pointer_node
;
2922 if (arg
->missing_arg_type
== BT_CHARACTER
)
2923 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2925 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2926 && e
->ts
.type
== BT_DERIVED
)
2928 /* The derived type needs to be converted to a temporary
2930 gfc_init_se (&parmse
, se
);
2931 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
2933 else if (se
->ss
&& se
->ss
->useflags
)
2935 /* An elemental function inside a scalarized loop. */
2936 gfc_init_se (&parmse
, se
);
2937 gfc_conv_expr_reference (&parmse
, e
);
2938 parm_kind
= ELEMENTAL
;
2942 /* A scalar or transformational function. */
2943 gfc_init_se (&parmse
, NULL
);
2944 argss
= gfc_walk_expr (e
);
2946 if (argss
== gfc_ss_terminator
)
2948 if (e
->expr_type
== EXPR_VARIABLE
2949 && e
->symtree
->n
.sym
->attr
.cray_pointee
2950 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2952 /* The Cray pointer needs to be converted to a pointer to
2953 a type given by the expression. */
2954 gfc_conv_expr (&parmse
, e
);
2955 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2956 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2957 parmse
.expr
= convert (type
, tmp
);
2959 else if (fsym
&& fsym
->attr
.value
)
2961 if (fsym
->ts
.type
== BT_CHARACTER
2962 && fsym
->ts
.is_c_interop
2963 && fsym
->ns
->proc_name
!= NULL
2964 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2967 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2968 if (parmse
.expr
== NULL
)
2969 gfc_conv_expr (&parmse
, e
);
2972 gfc_conv_expr (&parmse
, e
);
2974 else if (arg
->name
&& arg
->name
[0] == '%')
2975 /* Argument list functions %VAL, %LOC and %REF are signalled
2976 through arg->name. */
2977 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2978 else if ((e
->expr_type
== EXPR_FUNCTION
)
2979 && ((e
->value
.function
.esym
2980 && e
->value
.function
.esym
->result
->attr
.pointer
)
2981 || (!e
->value
.function
.esym
2982 && e
->symtree
->n
.sym
->attr
.pointer
))
2983 && fsym
&& fsym
->attr
.target
)
2985 gfc_conv_expr (&parmse
, e
);
2986 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2988 else if (e
->expr_type
== EXPR_FUNCTION
2989 && e
->symtree
->n
.sym
->result
2990 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2991 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2993 /* Functions returning procedure pointers. */
2994 gfc_conv_expr (&parmse
, e
);
2995 if (fsym
&& fsym
->attr
.proc_pointer
)
2996 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3000 gfc_conv_expr_reference (&parmse
, e
);
3002 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3003 allocated on entry, it must be deallocated. */
3004 if (fsym
&& fsym
->attr
.allocatable
3005 && fsym
->attr
.intent
== INTENT_OUT
)
3009 gfc_init_block (&block
);
3010 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
3012 gfc_add_expr_to_block (&block
, tmp
);
3013 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3014 void_type_node
, parmse
.expr
,
3016 gfc_add_expr_to_block (&block
, tmp
);
3018 if (fsym
->attr
.optional
3019 && e
->expr_type
== EXPR_VARIABLE
3020 && e
->symtree
->n
.sym
->attr
.optional
)
3022 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3024 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3025 gfc_finish_block (&block
),
3026 build_empty_stmt (input_location
));
3029 tmp
= gfc_finish_block (&block
);
3031 gfc_add_expr_to_block (&se
->pre
, tmp
);
3034 if (fsym
&& e
->expr_type
!= EXPR_NULL
3035 && ((fsym
->attr
.pointer
3036 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3037 || (fsym
->attr
.proc_pointer
3038 && !(e
->expr_type
== EXPR_VARIABLE
3039 && e
->symtree
->n
.sym
->attr
.dummy
))
3040 || (fsym
->attr
.proc_pointer
3041 && e
->expr_type
== EXPR_VARIABLE
3042 && gfc_is_proc_ptr_comp (e
, NULL
))
3043 || fsym
->attr
.allocatable
))
3045 /* Scalar pointer dummy args require an extra level of
3046 indirection. The null pointer already contains
3047 this level of indirection. */
3048 parm_kind
= SCALAR_POINTER
;
3049 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3055 /* If the procedure requires an explicit interface, the actual
3056 argument is passed according to the corresponding formal
3057 argument. If the corresponding formal argument is a POINTER,
3058 ALLOCATABLE or assumed shape, we do not use g77's calling
3059 convention, and pass the address of the array descriptor
3060 instead. Otherwise we use g77's calling convention. */
3063 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3064 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3066 f
= f
|| !comp
->attr
.always_explicit
;
3068 f
= f
|| !sym
->attr
.always_explicit
;
3070 /* If the argument is a function call that may not create
3071 a temporary for the result, we have to check that we
3072 can do it, i.e. that there is no alias between this
3073 argument and another one. */
3074 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
3080 intent
= fsym
->attr
.intent
;
3082 intent
= INTENT_UNKNOWN
;
3084 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
3086 parmse
.force_tmp
= 1;
3088 iarg
= e
->value
.function
.actual
->expr
;
3090 /* Temporary needed if aliasing due to host association. */
3091 if (sym
->attr
.contained
3093 && !sym
->attr
.implicit_pure
3094 && !sym
->attr
.use_assoc
3095 && iarg
->expr_type
== EXPR_VARIABLE
3096 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
3097 parmse
.force_tmp
= 1;
3099 /* Ditto within module. */
3100 if (sym
->attr
.use_assoc
3102 && !sym
->attr
.implicit_pure
3103 && iarg
->expr_type
== EXPR_VARIABLE
3104 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
3105 parmse
.force_tmp
= 1;
3108 if (e
->expr_type
== EXPR_VARIABLE
3109 && is_subref_array (e
))
3110 /* The actual argument is a component reference to an
3111 array of derived types. In this case, the argument
3112 is converted to a temporary, which is passed and then
3113 written back after the procedure call. */
3114 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3115 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3116 fsym
&& fsym
->attr
.pointer
);
3118 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
3121 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3122 allocated on entry, it must be deallocated. */
3123 if (fsym
&& fsym
->attr
.allocatable
3124 && fsym
->attr
.intent
== INTENT_OUT
)
3126 tmp
= build_fold_indirect_ref_loc (input_location
,
3128 tmp
= gfc_trans_dealloc_allocated (tmp
);
3129 if (fsym
->attr
.optional
3130 && e
->expr_type
== EXPR_VARIABLE
3131 && e
->symtree
->n
.sym
->attr
.optional
)
3132 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3134 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3135 tmp
, build_empty_stmt (input_location
));
3136 gfc_add_expr_to_block (&se
->pre
, tmp
);
3141 /* The case with fsym->attr.optional is that of a user subroutine
3142 with an interface indicating an optional argument. When we call
3143 an intrinsic subroutine, however, fsym is NULL, but we might still
3144 have an optional argument, so we proceed to the substitution
3146 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3148 /* If an optional argument is itself an optional dummy argument,
3149 check its presence and substitute a null if absent. This is
3150 only needed when passing an array to an elemental procedure
3151 as then array elements are accessed - or no NULL pointer is
3152 allowed and a "1" or "0" should be passed if not present.
3153 When passing a non-array-descriptor full array to a
3154 non-array-descriptor dummy, no check is needed. For
3155 array-descriptor actual to array-descriptor dummy, see
3156 PR 41911 for why a check has to be inserted.
3157 fsym == NULL is checked as intrinsics required the descriptor
3158 but do not always set fsym. */
3159 if (e
->expr_type
== EXPR_VARIABLE
3160 && e
->symtree
->n
.sym
->attr
.optional
3161 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3162 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3166 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
3167 || fsym
->as
->type
== AS_DEFERRED
))))))
3168 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3169 e
->representation
.length
);
3174 /* Obtain the character length of an assumed character length
3175 length procedure from the typespec. */
3176 if (fsym
->ts
.type
== BT_CHARACTER
3177 && parmse
.string_length
== NULL_TREE
3178 && e
->ts
.type
== BT_PROCEDURE
3179 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3180 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3181 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3183 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3184 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3188 if (fsym
&& need_interface_mapping
&& e
)
3189 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3191 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3192 gfc_add_block_to_block (&post
, &parmse
.post
);
3194 /* Allocated allocatable components of derived types must be
3195 deallocated for non-variable scalars. Non-variable arrays are
3196 dealt with in trans-array.c(gfc_conv_array_parameter). */
3197 if (e
&& e
->ts
.type
== BT_DERIVED
3198 && e
->ts
.u
.derived
->attr
.alloc_comp
3199 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3200 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3203 tmp
= build_fold_indirect_ref_loc (input_location
,
3205 parm_rank
= e
->rank
;
3213 case (SCALAR_POINTER
):
3214 tmp
= build_fold_indirect_ref_loc (input_location
,
3219 if (e
->expr_type
== EXPR_OP
3220 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3221 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3224 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3225 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3226 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3229 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3231 gfc_add_expr_to_block (&se
->post
, tmp
);
3234 /* Add argument checking of passing an unallocated/NULL actual to
3235 a nonallocatable/nonpointer dummy. */
3237 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3239 symbol_attribute attr
;
3243 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
3244 attr
= gfc_expr_attr (e
);
3246 goto end_pointer_check
;
3250 /* If the actual argument is an optional pointer/allocatable and
3251 the formal argument takes an nonpointer optional value,
3252 it is invalid to pass a non-present argument on, even
3253 though there is no technical reason for this in gfortran.
3254 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3255 tree present
, null_ptr
, type
;
3257 if (attr
.allocatable
3258 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3259 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3260 "allocated or not present", e
->symtree
->n
.sym
->name
);
3261 else if (attr
.pointer
3262 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3263 asprintf (&msg
, "Pointer actual argument '%s' is not "
3264 "associated or not present",
3265 e
->symtree
->n
.sym
->name
);
3266 else if (attr
.proc_pointer
3267 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3268 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3269 "associated or not present",
3270 e
->symtree
->n
.sym
->name
);
3272 goto end_pointer_check
;
3274 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3275 type
= TREE_TYPE (present
);
3276 present
= fold_build2_loc (input_location
, EQ_EXPR
,
3277 boolean_type_node
, present
,
3279 null_pointer_node
));
3280 type
= TREE_TYPE (parmse
.expr
);
3281 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
3282 boolean_type_node
, parmse
.expr
,
3284 null_pointer_node
));
3285 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3286 boolean_type_node
, present
, null_ptr
);
3290 if (attr
.allocatable
3291 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3292 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3293 "allocated", e
->symtree
->n
.sym
->name
);
3294 else if (attr
.pointer
3295 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3296 asprintf (&msg
, "Pointer actual argument '%s' is not "
3297 "associated", e
->symtree
->n
.sym
->name
);
3298 else if (attr
.proc_pointer
3299 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3300 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3301 "associated", e
->symtree
->n
.sym
->name
);
3303 goto end_pointer_check
;
3306 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3307 boolean_type_node
, parmse
.expr
,
3308 fold_convert (TREE_TYPE (parmse
.expr
),
3309 null_pointer_node
));
3312 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3318 /* Deferred length dummies pass the character length by reference
3319 so that the value can be returned. */
3320 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
3322 tmp
= parmse
.string_length
;
3323 if (TREE_CODE (tmp
) != VAR_DECL
)
3324 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
3325 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3328 /* Character strings are passed as two parameters, a length and a
3329 pointer - except for Bind(c) which only passes the pointer. */
3330 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3331 VEC_safe_push (tree
, gc
, stringargs
, parmse
.string_length
);
3333 VEC_safe_push (tree
, gc
, arglist
, parmse
.expr
);
3335 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3342 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3343 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3344 else if (ts
.type
== BT_CHARACTER
)
3346 if (ts
.u
.cl
->length
== NULL
)
3348 /* Assumed character length results are not allowed by 5.1.1.5 of the
3349 standard and are trapped in resolve.c; except in the case of SPREAD
3350 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3351 we take the character length of the first argument for the result.
3352 For dummies, we have to look through the formal argument list for
3353 this function and use the character length found there.*/
3354 if (ts
.deferred
&& (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
3355 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
3356 else if (!sym
->attr
.dummy
)
3357 cl
.backend_decl
= VEC_index (tree
, stringargs
, 0);
3360 formal
= sym
->ns
->proc_name
->formal
;
3361 for (; formal
; formal
= formal
->next
)
3362 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3363 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3370 /* Calculate the length of the returned string. */
3371 gfc_init_se (&parmse
, NULL
);
3372 if (need_interface_mapping
)
3373 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3375 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3376 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3377 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3379 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3380 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3381 gfc_charlen_type_node
, tmp
,
3382 build_int_cst (gfc_charlen_type_node
, 0));
3383 cl
.backend_decl
= tmp
;
3386 /* Set up a charlen structure for it. */
3391 len
= cl
.backend_decl
;
3394 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3395 || (!comp
&& gfc_return_by_reference (sym
));
3398 if (se
->direct_byref
)
3400 /* Sometimes, too much indirection can be applied; e.g. for
3401 function_result = array_valued_recursive_function. */
3402 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3403 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3404 && GFC_DESCRIPTOR_TYPE_P
3405 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3406 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3409 /* If the lhs of an assignment x = f(..) is allocatable and
3410 f2003 is allowed, we must do the automatic reallocation.
3411 TODO - deal with intrinsics, without using a temporary. */
3412 if (gfc_option
.flag_realloc_lhs
3413 && se
->ss
&& se
->ss
->loop_chain
3414 && se
->ss
->loop_chain
->is_alloc_lhs
3415 && !expr
->value
.function
.isym
3416 && sym
->result
->as
!= NULL
)
3418 /* Evaluate the bounds of the result, if known. */
3419 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
3422 /* Perform the automatic reallocation. */
3423 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
3425 gfc_add_expr_to_block (&se
->pre
, tmp
);
3427 /* Pass the temporary as the first argument. */
3428 result
= info
->descriptor
;
3431 result
= build_fold_indirect_ref_loc (input_location
,
3433 VEC_safe_push (tree
, gc
, retargs
, se
->expr
);
3435 else if (comp
&& comp
->attr
.dimension
)
3437 gcc_assert (se
->loop
&& info
);
3439 /* Set the type of the array. */
3440 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3441 info
->dimen
= se
->loop
->dimen
;
3443 /* Evaluate the bounds of the result, if known. */
3444 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3446 /* If the lhs of an assignment x = f(..) is allocatable and
3447 f2003 is allowed, we must not generate the function call
3448 here but should just send back the results of the mapping.
3449 This is signalled by the function ss being flagged. */
3450 if (gfc_option
.flag_realloc_lhs
3451 && se
->ss
&& se
->ss
->is_alloc_lhs
)
3453 gfc_free_interface_mapping (&mapping
);
3454 return has_alternate_specifier
;
3457 /* Create a temporary to store the result. In case the function
3458 returns a pointer, the temporary will be a shallow copy and
3459 mustn't be deallocated. */
3460 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3461 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3462 NULL_TREE
, false, !comp
->attr
.pointer
,
3463 callee_alloc
, &se
->ss
->expr
->where
);
3465 /* Pass the temporary as the first argument. */
3466 result
= info
->descriptor
;
3467 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3468 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3470 else if (!comp
&& sym
->result
->attr
.dimension
)
3472 gcc_assert (se
->loop
&& info
);
3474 /* Set the type of the array. */
3475 tmp
= gfc_typenode_for_spec (&ts
);
3476 info
->dimen
= se
->loop
->dimen
;
3478 /* Evaluate the bounds of the result, if known. */
3479 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3481 /* If the lhs of an assignment x = f(..) is allocatable and
3482 f2003 is allowed, we must not generate the function call
3483 here but should just send back the results of the mapping.
3484 This is signalled by the function ss being flagged. */
3485 if (gfc_option
.flag_realloc_lhs
3486 && se
->ss
&& se
->ss
->is_alloc_lhs
)
3488 gfc_free_interface_mapping (&mapping
);
3489 return has_alternate_specifier
;
3492 /* Create a temporary to store the result. In case the function
3493 returns a pointer, the temporary will be a shallow copy and
3494 mustn't be deallocated. */
3495 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3496 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3497 NULL_TREE
, false, !sym
->attr
.pointer
,
3498 callee_alloc
, &se
->ss
->expr
->where
);
3500 /* Pass the temporary as the first argument. */
3501 result
= info
->descriptor
;
3502 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3503 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3505 else if (ts
.type
== BT_CHARACTER
)
3507 /* Pass the string length. */
3508 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3509 type
= build_pointer_type (type
);
3511 /* Return an address to a char[0:len-1]* temporary for
3512 character pointers. */
3513 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3514 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3516 var
= gfc_create_var (type
, "pstr");
3518 if ((!comp
&& sym
->attr
.allocatable
)
3519 || (comp
&& comp
->attr
.allocatable
))
3520 gfc_add_modify (&se
->pre
, var
,
3521 fold_convert (TREE_TYPE (var
),
3522 null_pointer_node
));
3524 /* Provide an address expression for the function arguments. */
3525 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3528 var
= gfc_conv_string_tmp (se
, type
, len
);
3530 VEC_safe_push (tree
, gc
, retargs
, var
);
3534 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3536 type
= gfc_get_complex_type (ts
.kind
);
3537 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3538 VEC_safe_push (tree
, gc
, retargs
, var
);
3541 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
3542 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
3545 if (TREE_CODE (tmp
) != VAR_DECL
)
3546 tmp
= gfc_evaluate_now (len
, &se
->pre
);
3547 len
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3550 /* Add the string length to the argument list. */
3551 if (ts
.type
== BT_CHARACTER
)
3552 VEC_safe_push (tree
, gc
, retargs
, len
);
3554 gfc_free_interface_mapping (&mapping
);
3556 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3557 arglen
= (VEC_length (tree
, arglist
)
3558 + VEC_length (tree
, stringargs
) + VEC_length (tree
, append_args
));
3559 VEC_reserve_exact (tree
, gc
, retargs
, arglen
);
3561 /* Add the return arguments. */
3562 VEC_splice (tree
, retargs
, arglist
);
3564 /* Add the hidden string length parameters to the arguments. */
3565 VEC_splice (tree
, retargs
, stringargs
);
3567 /* We may want to append extra arguments here. This is used e.g. for
3568 calls to libgfortran_matmul_??, which need extra information. */
3569 if (!VEC_empty (tree
, append_args
))
3570 VEC_splice (tree
, retargs
, append_args
);
3573 /* Generate the actual call. */
3574 conv_function_val (se
, sym
, expr
);
3576 /* If there are alternate return labels, function type should be
3577 integer. Can't modify the type in place though, since it can be shared
3578 with other functions. For dummy arguments, the typing is done to
3579 to this result, even if it has to be repeated for each call. */
3580 if (has_alternate_specifier
3581 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3583 if (!sym
->attr
.dummy
)
3585 TREE_TYPE (sym
->backend_decl
)
3586 = build_function_type (integer_type_node
,
3587 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3588 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3591 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3594 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3595 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
3597 /* If we have a pointer function, but we don't want a pointer, e.g.
3600 where f is pointer valued, we have to dereference the result. */
3601 if (!se
->want_pointer
&& !byref
3602 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3603 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
3604 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3606 /* f2c calling conventions require a scalar default real function to
3607 return a double precision result. Convert this back to default
3608 real. We only care about the cases that can happen in Fortran 77.
3610 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3611 && sym
->ts
.kind
== gfc_default_real_kind
3612 && !sym
->attr
.always_explicit
)
3613 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3615 /* A pure function may still have side-effects - it may modify its
3617 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3619 if (!sym
->attr
.pure
)
3620 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3625 /* Add the function call to the pre chain. There is no expression. */
3626 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3627 se
->expr
= NULL_TREE
;
3629 if (!se
->direct_byref
)
3631 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
3633 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3635 /* Check the data pointer hasn't been modified. This would
3636 happen in a function returning a pointer. */
3637 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3638 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
3641 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3644 se
->expr
= info
->descriptor
;
3645 /* Bundle in the string length. */
3646 se
->string_length
= len
;
3648 else if (ts
.type
== BT_CHARACTER
)
3650 /* Dereference for character pointer results. */
3651 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3652 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3653 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3658 se
->string_length
= len
;
3659 else if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
3660 se
->string_length
= cl
.backend_decl
;
3664 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3665 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3670 /* Follow the function call with the argument post block. */
3673 gfc_add_block_to_block (&se
->pre
, &post
);
3675 /* Transformational functions of derived types with allocatable
3676 components must have the result allocatable components copied. */
3677 arg
= expr
->value
.function
.actual
;
3678 if (result
&& arg
&& expr
->rank
3679 && expr
->value
.function
.isym
3680 && expr
->value
.function
.isym
->transformational
3681 && arg
->expr
->ts
.type
== BT_DERIVED
3682 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
3685 /* Copy the allocatable components. We have to use a
3686 temporary here to prevent source allocatable components
3687 from being corrupted. */
3688 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
3689 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
3690 result
, tmp2
, expr
->rank
);
3691 gfc_add_expr_to_block (&se
->pre
, tmp
);
3692 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
3694 gfc_add_expr_to_block (&se
->pre
, tmp
);
3696 /* Finally free the temporary's data field. */
3697 tmp
= gfc_conv_descriptor_data_get (tmp2
);
3698 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
3699 gfc_add_expr_to_block (&se
->pre
, tmp
);
3703 gfc_add_block_to_block (&se
->post
, &post
);
3705 return has_alternate_specifier
;
3709 /* Fill a character string with spaces. */
3712 fill_with_spaces (tree start
, tree type
, tree size
)
3714 stmtblock_t block
, loop
;
3715 tree i
, el
, exit_label
, cond
, tmp
;
3717 /* For a simple char type, we can call memset(). */
3718 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3719 return build_call_expr_loc (input_location
,
3720 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3721 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3722 lang_hooks
.to_target_charset (' ')),
3725 /* Otherwise, we use a loop:
3726 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3730 /* Initialize variables. */
3731 gfc_init_block (&block
);
3732 i
= gfc_create_var (sizetype
, "i");
3733 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3734 el
= gfc_create_var (build_pointer_type (type
), "el");
3735 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3736 exit_label
= gfc_build_label_decl (NULL_TREE
);
3737 TREE_USED (exit_label
) = 1;
3741 gfc_init_block (&loop
);
3743 /* Exit condition. */
3744 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
3745 build_zero_cst (sizetype
));
3746 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3747 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
3748 build_empty_stmt (input_location
));
3749 gfc_add_expr_to_block (&loop
, tmp
);
3752 gfc_add_modify (&loop
,
3753 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
3754 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
3756 /* Increment loop variables. */
3757 gfc_add_modify (&loop
, i
,
3758 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
3759 TYPE_SIZE_UNIT (type
)));
3760 gfc_add_modify (&loop
, el
,
3761 fold_build2_loc (input_location
, POINTER_PLUS_EXPR
,
3762 TREE_TYPE (el
), el
, TYPE_SIZE_UNIT (type
)));
3764 /* Making the loop... actually loop! */
3765 tmp
= gfc_finish_block (&loop
);
3766 tmp
= build1_v (LOOP_EXPR
, tmp
);
3767 gfc_add_expr_to_block (&block
, tmp
);
3769 /* The exit label. */
3770 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3771 gfc_add_expr_to_block (&block
, tmp
);
3774 return gfc_finish_block (&block
);
3778 /* Generate code to copy a string. */
3781 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3782 int dkind
, tree slength
, tree src
, int skind
)
3784 tree tmp
, dlen
, slen
;
3793 stmtblock_t tempblock
;
3795 gcc_assert (dkind
== skind
);
3797 if (slength
!= NULL_TREE
)
3799 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3800 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
3804 slen
= build_int_cst (size_type_node
, 1);
3808 if (dlength
!= NULL_TREE
)
3810 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3811 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
3815 dlen
= build_int_cst (size_type_node
, 1);
3819 /* Assign directly if the types are compatible. */
3820 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3821 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3823 gfc_add_modify (block
, dsc
, ssc
);
3827 /* Do nothing if the destination length is zero. */
3828 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
3829 build_int_cst (size_type_node
, 0));
3831 /* The following code was previously in _gfortran_copy_string:
3833 // The two strings may overlap so we use memmove.
3835 copy_string (GFC_INTEGER_4 destlen, char * dest,
3836 GFC_INTEGER_4 srclen, const char * src)
3838 if (srclen >= destlen)
3840 // This will truncate if too long.
3841 memmove (dest, src, destlen);
3845 memmove (dest, src, srclen);
3847 memset (&dest[srclen], ' ', destlen - srclen);
3851 We're now doing it here for better optimization, but the logic
3854 /* For non-default character kinds, we have to multiply the string
3855 length by the base type size. */
3856 chartype
= gfc_get_char_type (dkind
);
3857 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3858 fold_convert (size_type_node
, slen
),
3859 fold_convert (size_type_node
,
3860 TYPE_SIZE_UNIT (chartype
)));
3861 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3862 fold_convert (size_type_node
, dlen
),
3863 fold_convert (size_type_node
,
3864 TYPE_SIZE_UNIT (chartype
)));
3866 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3867 dest
= fold_convert (pvoid_type_node
, dest
);
3869 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3871 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3872 src
= fold_convert (pvoid_type_node
, src
);
3874 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3876 /* Truncate string if source is too long. */
3877 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
3879 tmp2
= build_call_expr_loc (input_location
,
3880 built_in_decls
[BUILT_IN_MEMMOVE
],
3881 3, dest
, src
, dlen
);
3883 /* Else copy and pad with spaces. */
3884 tmp3
= build_call_expr_loc (input_location
,
3885 built_in_decls
[BUILT_IN_MEMMOVE
],
3886 3, dest
, src
, slen
);
3888 tmp4
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
, TREE_TYPE (dest
),
3889 dest
, fold_convert (sizetype
, slen
));
3890 tmp4
= fill_with_spaces (tmp4
, chartype
,
3891 fold_build2_loc (input_location
, MINUS_EXPR
,
3892 TREE_TYPE(dlen
), dlen
, slen
));
3894 gfc_init_block (&tempblock
);
3895 gfc_add_expr_to_block (&tempblock
, tmp3
);
3896 gfc_add_expr_to_block (&tempblock
, tmp4
);
3897 tmp3
= gfc_finish_block (&tempblock
);
3899 /* The whole copy_string function is there. */
3900 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
3902 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
3903 build_empty_stmt (input_location
));
3904 gfc_add_expr_to_block (block
, tmp
);
3908 /* Translate a statement function.
3909 The value of a statement function reference is obtained by evaluating the
3910 expression using the values of the actual arguments for the values of the
3911 corresponding dummy arguments. */
3914 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3918 gfc_formal_arglist
*fargs
;
3919 gfc_actual_arglist
*args
;
3922 gfc_saved_var
*saved_vars
;
3928 sym
= expr
->symtree
->n
.sym
;
3929 args
= expr
->value
.function
.actual
;
3930 gfc_init_se (&lse
, NULL
);
3931 gfc_init_se (&rse
, NULL
);
3934 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3936 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3937 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3939 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3941 /* Each dummy shall be specified, explicitly or implicitly, to be
3943 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3946 if (fsym
->ts
.type
== BT_CHARACTER
)
3948 /* Copy string arguments. */
3951 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3952 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3954 /* Create a temporary to hold the value. */
3955 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
3956 fsym
->ts
.u
.cl
->backend_decl
3957 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
3959 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
3960 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3962 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3964 gfc_conv_expr (&rse
, args
->expr
);
3965 gfc_conv_string_parameter (&rse
);
3966 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3967 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3969 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
3970 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3971 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3972 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3976 /* For everything else, just evaluate the expression. */
3978 /* Create a temporary to hold the value. */
3979 type
= gfc_typenode_for_spec (&fsym
->ts
);
3980 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3982 gfc_conv_expr (&lse
, args
->expr
);
3984 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3985 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3986 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3992 /* Use the temporary variables in place of the real ones. */
3993 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3994 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3996 gfc_conv_expr (se
, sym
->value
);
3998 if (sym
->ts
.type
== BT_CHARACTER
)
4000 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4002 /* Force the expression to the correct length. */
4003 if (!INTEGER_CST_P (se
->string_length
)
4004 || tree_int_cst_lt (se
->string_length
,
4005 sym
->ts
.u
.cl
->backend_decl
))
4007 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
4008 tmp
= gfc_create_var (type
, sym
->name
);
4009 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
4010 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
4011 sym
->ts
.kind
, se
->string_length
, se
->expr
,
4015 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
4018 /* Restore the original variables. */
4019 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4020 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
4021 gfc_free (saved_vars
);
4025 /* Translate a function expression. */
4028 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
4032 if (expr
->value
.function
.isym
)
4034 gfc_conv_intrinsic_function (se
, expr
);
4038 /* We distinguish statement functions from general functions to improve
4039 runtime performance. */
4040 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
4042 gfc_conv_statement_function (se
, expr
);
4046 /* expr.value.function.esym is the resolved (specific) function symbol for
4047 most functions. However this isn't set for dummy procedures. */
4048 sym
= expr
->value
.function
.esym
;
4050 sym
= expr
->symtree
->n
.sym
;
4052 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
, NULL
);
4056 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4059 is_zero_initializer_p (gfc_expr
* expr
)
4061 if (expr
->expr_type
!= EXPR_CONSTANT
)
4064 /* We ignore constants with prescribed memory representations for now. */
4065 if (expr
->representation
.string
)
4068 switch (expr
->ts
.type
)
4071 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4074 return mpfr_zero_p (expr
->value
.real
)
4075 && MPFR_SIGN (expr
->value
.real
) >= 0;
4078 return expr
->value
.logical
== 0;
4081 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
4082 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
4083 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
4084 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
4094 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
4096 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
4097 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
4099 gfc_conv_tmp_array_ref (se
);
4103 /* Build a static initializer. EXPR is the expression for the initial value.
4104 The other parameters describe the variable of the component being
4105 initialized. EXPR may be null. */
4108 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
4109 bool array
, bool pointer
, bool procptr
)
4113 if (!(expr
|| pointer
|| procptr
))
4116 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4117 (these are the only two iso_c_binding derived types that can be
4118 used as initialization expressions). If so, we need to modify
4119 the 'expr' to be that for a (void *). */
4120 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
4121 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
4123 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
4125 /* The derived symbol has already been converted to a (void *). Use
4127 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
4128 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
4130 gfc_init_se (&se
, NULL
);
4131 gfc_conv_constant (&se
, expr
);
4132 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4136 if (array
&& !procptr
)
4139 /* Arrays need special handling. */
4141 ctor
= gfc_build_null_descriptor (type
);
4142 /* Special case assigning an array to zero. */
4143 else if (is_zero_initializer_p (expr
))
4144 ctor
= build_constructor (type
, NULL
);
4146 ctor
= gfc_conv_array_initializer (type
, expr
);
4147 TREE_STATIC (ctor
) = 1;
4150 else if (pointer
|| procptr
)
4152 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
4153 return fold_convert (type
, null_pointer_node
);
4156 gfc_init_se (&se
, NULL
);
4157 se
.want_pointer
= 1;
4158 gfc_conv_expr (&se
, expr
);
4159 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4169 gfc_init_se (&se
, NULL
);
4170 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4171 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
4173 gfc_conv_structure (&se
, expr
, 1);
4174 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
4175 TREE_STATIC (se
.expr
) = 1;
4180 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
4181 TREE_STATIC (ctor
) = 1;
4186 gfc_init_se (&se
, NULL
);
4187 gfc_conv_constant (&se
, expr
);
4188 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4195 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4207 gfc_start_block (&block
);
4209 /* Initialize the scalarizer. */
4210 gfc_init_loopinfo (&loop
);
4212 gfc_init_se (&lse
, NULL
);
4213 gfc_init_se (&rse
, NULL
);
4216 rss
= gfc_walk_expr (expr
);
4217 if (rss
== gfc_ss_terminator
)
4219 /* The rhs is scalar. Add a ss for the expression. */
4220 rss
= gfc_get_ss ();
4221 rss
->next
= gfc_ss_terminator
;
4222 rss
->type
= GFC_SS_SCALAR
;
4226 /* Create a SS for the destination. */
4227 lss
= gfc_get_ss ();
4228 lss
->type
= GFC_SS_COMPONENT
;
4230 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
4231 lss
->next
= gfc_ss_terminator
;
4232 lss
->data
.info
.dimen
= cm
->as
->rank
;
4233 lss
->data
.info
.descriptor
= dest
;
4234 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
4235 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
4236 for (n
= 0; n
< cm
->as
->rank
; n
++)
4238 lss
->data
.info
.dim
[n
] = n
;
4239 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
4240 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
4242 mpz_init (lss
->shape
[n
]);
4243 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
4244 cm
->as
->lower
[n
]->value
.integer
);
4245 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
4248 /* Associate the SS with the loop. */
4249 gfc_add_ss_to_loop (&loop
, lss
);
4250 gfc_add_ss_to_loop (&loop
, rss
);
4252 /* Calculate the bounds of the scalarization. */
4253 gfc_conv_ss_startstride (&loop
);
4255 /* Setup the scalarizing loops. */
4256 gfc_conv_loop_setup (&loop
, &expr
->where
);
4258 /* Setup the gfc_se structures. */
4259 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4260 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4263 gfc_mark_ss_chain_used (rss
, 1);
4265 gfc_mark_ss_chain_used (lss
, 1);
4267 /* Start the scalarized loop body. */
4268 gfc_start_scalarized_body (&loop
, &body
);
4270 gfc_conv_tmp_array_ref (&lse
);
4271 if (cm
->ts
.type
== BT_CHARACTER
)
4272 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4274 gfc_conv_expr (&rse
, expr
);
4276 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
4277 gfc_add_expr_to_block (&body
, tmp
);
4279 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4281 /* Generate the copying loops. */
4282 gfc_trans_scalarizing_loops (&loop
, &body
);
4284 /* Wrap the whole thing up. */
4285 gfc_add_block_to_block (&block
, &loop
.pre
);
4286 gfc_add_block_to_block (&block
, &loop
.post
);
4288 for (n
= 0; n
< cm
->as
->rank
; n
++)
4289 mpz_clear (lss
->shape
[n
]);
4290 gfc_free (lss
->shape
);
4292 gfc_cleanup_loop (&loop
);
4294 return gfc_finish_block (&block
);
4299 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4310 gfc_expr
*arg
= NULL
;
4312 gfc_start_block (&block
);
4313 gfc_init_se (&se
, NULL
);
4315 /* Get the descriptor for the expressions. */
4316 rss
= gfc_walk_expr (expr
);
4317 se
.want_pointer
= 0;
4318 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4319 gfc_add_block_to_block (&block
, &se
.pre
);
4320 gfc_add_modify (&block
, dest
, se
.expr
);
4322 /* Deal with arrays of derived types with allocatable components. */
4323 if (cm
->ts
.type
== BT_DERIVED
4324 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4325 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4329 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4330 TREE_TYPE(cm
->backend_decl
),
4333 gfc_add_expr_to_block (&block
, tmp
);
4334 gfc_add_block_to_block (&block
, &se
.post
);
4336 if (expr
->expr_type
!= EXPR_VARIABLE
)
4337 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4340 /* We need to know if the argument of a conversion function is a
4341 variable, so that the correct lower bound can be used. */
4342 if (expr
->expr_type
== EXPR_FUNCTION
4343 && expr
->value
.function
.isym
4344 && expr
->value
.function
.isym
->conversion
4345 && expr
->value
.function
.actual
->expr
4346 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4347 arg
= expr
->value
.function
.actual
->expr
;
4349 /* Obtain the array spec of full array references. */
4351 as
= gfc_get_full_arrayspec_from_expr (arg
);
4353 as
= gfc_get_full_arrayspec_from_expr (expr
);
4355 /* Shift the lbound and ubound of temporaries to being unity,
4356 rather than zero, based. Always calculate the offset. */
4357 offset
= gfc_conv_descriptor_offset_get (dest
);
4358 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4359 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4361 for (n
= 0; n
< expr
->rank
; n
++)
4366 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4367 TODO It looks as if gfc_conv_expr_descriptor should return
4368 the correct bounds and that the following should not be
4369 necessary. This would simplify gfc_conv_intrinsic_bound
4371 if (as
&& as
->lower
[n
])
4374 gfc_init_se (&lbse
, NULL
);
4375 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4376 gfc_add_block_to_block (&block
, &lbse
.pre
);
4377 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4381 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4382 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4386 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4389 lbound
= gfc_index_one_node
;
4391 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4393 /* Shift the bounds and set the offset accordingly. */
4394 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4395 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4396 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4397 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4399 gfc_conv_descriptor_ubound_set (&block
, dest
,
4400 gfc_rank_cst
[n
], tmp
);
4401 gfc_conv_descriptor_lbound_set (&block
, dest
,
4402 gfc_rank_cst
[n
], lbound
);
4404 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4405 gfc_conv_descriptor_lbound_get (dest
,
4407 gfc_conv_descriptor_stride_get (dest
,
4409 gfc_add_modify (&block
, tmp2
, tmp
);
4410 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4412 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4417 /* If a conversion expression has a null data pointer
4418 argument, nullify the allocatable component. */
4422 if (arg
->symtree
->n
.sym
->attr
.allocatable
4423 || arg
->symtree
->n
.sym
->attr
.pointer
)
4425 non_null_expr
= gfc_finish_block (&block
);
4426 gfc_start_block (&block
);
4427 gfc_conv_descriptor_data_set (&block
, dest
,
4429 null_expr
= gfc_finish_block (&block
);
4430 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4431 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
4432 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
4433 return build3_v (COND_EXPR
, tmp
,
4434 null_expr
, non_null_expr
);
4438 return gfc_finish_block (&block
);
4442 /* Assign a single component of a derived type constructor. */
4445 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4453 gfc_start_block (&block
);
4455 if (cm
->attr
.pointer
)
4457 gfc_init_se (&se
, NULL
);
4458 /* Pointer component. */
4459 if (cm
->attr
.dimension
)
4461 /* Array pointer. */
4462 if (expr
->expr_type
== EXPR_NULL
)
4463 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4466 rss
= gfc_walk_expr (expr
);
4467 se
.direct_byref
= 1;
4469 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4470 gfc_add_block_to_block (&block
, &se
.pre
);
4471 gfc_add_block_to_block (&block
, &se
.post
);
4476 /* Scalar pointers. */
4477 se
.want_pointer
= 1;
4478 gfc_conv_expr (&se
, expr
);
4479 gfc_add_block_to_block (&block
, &se
.pre
);
4480 gfc_add_modify (&block
, dest
,
4481 fold_convert (TREE_TYPE (dest
), se
.expr
));
4482 gfc_add_block_to_block (&block
, &se
.post
);
4485 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4487 /* NULL initialization for CLASS components. */
4488 tmp
= gfc_trans_structure_assign (dest
,
4489 gfc_class_null_initializer (&cm
->ts
));
4490 gfc_add_expr_to_block (&block
, tmp
);
4492 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
4494 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4495 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4496 else if (cm
->attr
.allocatable
)
4498 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4499 gfc_add_expr_to_block (&block
, tmp
);
4503 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4504 gfc_add_expr_to_block (&block
, tmp
);
4507 else if (expr
->ts
.type
== BT_DERIVED
)
4509 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4511 gfc_init_se (&se
, NULL
);
4512 gfc_conv_expr (&se
, expr
);
4513 gfc_add_block_to_block (&block
, &se
.pre
);
4514 gfc_add_modify (&block
, dest
,
4515 fold_convert (TREE_TYPE (dest
), se
.expr
));
4516 gfc_add_block_to_block (&block
, &se
.post
);
4520 /* Nested constructors. */
4521 tmp
= gfc_trans_structure_assign (dest
, expr
);
4522 gfc_add_expr_to_block (&block
, tmp
);
4527 /* Scalar component. */
4528 gfc_init_se (&se
, NULL
);
4529 gfc_init_se (&lse
, NULL
);
4531 gfc_conv_expr (&se
, expr
);
4532 if (cm
->ts
.type
== BT_CHARACTER
)
4533 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4535 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
4536 gfc_add_expr_to_block (&block
, tmp
);
4538 return gfc_finish_block (&block
);
4541 /* Assign a derived type constructor to a variable. */
4544 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4552 gfc_start_block (&block
);
4553 cm
= expr
->ts
.u
.derived
->components
;
4555 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
4556 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
4557 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
4561 gcc_assert (cm
->backend_decl
== NULL
);
4562 gfc_init_se (&se
, NULL
);
4563 gfc_init_se (&lse
, NULL
);
4564 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
4566 gfc_add_modify (&block
, lse
.expr
,
4567 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
4569 return gfc_finish_block (&block
);
4572 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4573 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4575 /* Skip absent members in default initializers. */
4579 field
= cm
->backend_decl
;
4580 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
4581 dest
, field
, NULL_TREE
);
4582 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4583 gfc_add_expr_to_block (&block
, tmp
);
4585 return gfc_finish_block (&block
);
4588 /* Build an expression for a constructor. If init is nonzero then
4589 this is part of a static variable initializer. */
4592 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4599 VEC(constructor_elt
,gc
) *v
= NULL
;
4601 gcc_assert (se
->ss
== NULL
);
4602 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4603 type
= gfc_typenode_for_spec (&expr
->ts
);
4607 /* Create a temporary variable and fill it in. */
4608 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4609 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4610 gfc_add_expr_to_block (&se
->pre
, tmp
);
4614 cm
= expr
->ts
.u
.derived
->components
;
4616 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4617 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4619 /* Skip absent members in default initializers and allocatable
4620 components. Although the latter have a default initializer
4621 of EXPR_NULL,... by default, the static nullify is not needed
4622 since this is done every time we come into scope. */
4623 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
4626 if (strcmp (cm
->name
, "_size") == 0)
4628 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4629 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4631 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4632 && strcmp (cm
->name
, "_extends") == 0)
4636 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4637 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4638 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
4642 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4643 TREE_TYPE (cm
->backend_decl
),
4644 cm
->attr
.dimension
, cm
->attr
.pointer
,
4645 cm
->attr
.proc_pointer
);
4647 /* Append it to the constructor list. */
4648 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4651 se
->expr
= build_constructor (type
, v
);
4653 TREE_CONSTANT (se
->expr
) = 1;
4657 /* Translate a substring expression. */
4660 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4666 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4668 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4669 expr
->value
.character
.length
,
4670 expr
->value
.character
.string
);
4672 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4673 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4676 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4680 /* Entry point for expression translation. Evaluates a scalar quantity.
4681 EXPR is the expression to be translated, and SE is the state structure if
4682 called from within the scalarized. */
4685 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4687 if (se
->ss
&& se
->ss
->expr
== expr
4688 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4690 /* Substitute a scalar expression evaluated outside the scalarization
4692 se
->expr
= se
->ss
->data
.scalar
.expr
;
4693 if (se
->ss
->type
== GFC_SS_REFERENCE
)
4694 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
4695 se
->string_length
= se
->ss
->string_length
;
4696 gfc_advance_se_ss_chain (se
);
4700 /* We need to convert the expressions for the iso_c_binding derived types.
4701 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4702 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4703 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4704 updated to be an integer with a kind equal to the size of a (void *). */
4705 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4706 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4708 if (expr
->expr_type
== EXPR_VARIABLE
4709 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4710 || expr
->symtree
->n
.sym
->intmod_sym_id
4711 == ISOCBINDING_NULL_FUNPTR
))
4713 /* Set expr_type to EXPR_NULL, which will result in
4714 null_pointer_node being used below. */
4715 expr
->expr_type
= EXPR_NULL
;
4719 /* Update the type/kind of the expression to be what the new
4720 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4721 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4722 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4723 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4727 switch (expr
->expr_type
)
4730 gfc_conv_expr_op (se
, expr
);
4734 gfc_conv_function_expr (se
, expr
);
4738 gfc_conv_constant (se
, expr
);
4742 gfc_conv_variable (se
, expr
);
4746 se
->expr
= null_pointer_node
;
4749 case EXPR_SUBSTRING
:
4750 gfc_conv_substring_expr (se
, expr
);
4753 case EXPR_STRUCTURE
:
4754 gfc_conv_structure (se
, expr
, 0);
4758 gfc_conv_array_constructor_expr (se
, expr
);
4767 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4768 of an assignment. */
4770 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4772 gfc_conv_expr (se
, expr
);
4773 /* All numeric lvalues should have empty post chains. If not we need to
4774 figure out a way of rewriting an lvalue so that it has no post chain. */
4775 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4778 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4779 numeric expressions. Used for scalar values where inserting cleanup code
4782 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4786 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4787 gfc_conv_expr (se
, expr
);
4790 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4791 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4793 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4797 /* Helper to translate an expression and convert it to a particular type. */
4799 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4801 gfc_conv_expr_val (se
, expr
);
4802 se
->expr
= convert (type
, se
->expr
);
4806 /* Converts an expression so that it can be passed by reference. Scalar
4810 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4814 if (se
->ss
&& se
->ss
->expr
== expr
4815 && se
->ss
->type
== GFC_SS_REFERENCE
)
4817 /* Returns a reference to the scalar evaluated outside the loop
4819 gfc_conv_expr (se
, expr
);
4823 if (expr
->ts
.type
== BT_CHARACTER
)
4825 gfc_conv_expr (se
, expr
);
4826 gfc_conv_string_parameter (se
);
4830 if (expr
->expr_type
== EXPR_VARIABLE
)
4832 se
->want_pointer
= 1;
4833 gfc_conv_expr (se
, expr
);
4836 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4837 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4838 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4844 if (expr
->expr_type
== EXPR_FUNCTION
4845 && ((expr
->value
.function
.esym
4846 && expr
->value
.function
.esym
->result
->attr
.pointer
4847 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4848 || (!expr
->value
.function
.esym
4849 && expr
->symtree
->n
.sym
->attr
.pointer
4850 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4852 se
->want_pointer
= 1;
4853 gfc_conv_expr (se
, expr
);
4854 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4855 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4861 gfc_conv_expr (se
, expr
);
4863 /* Create a temporary var to hold the value. */
4864 if (TREE_CONSTANT (se
->expr
))
4866 tree tmp
= se
->expr
;
4867 STRIP_TYPE_NOPS (tmp
);
4868 var
= build_decl (input_location
,
4869 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4870 DECL_INITIAL (var
) = tmp
;
4871 TREE_STATIC (var
) = 1;
4876 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4877 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4879 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4881 /* Take the address of that value. */
4882 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4887 gfc_trans_pointer_assign (gfc_code
* code
)
4889 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4893 /* Generate code for a pointer assignment. */
4896 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4907 gfc_start_block (&block
);
4909 gfc_init_se (&lse
, NULL
);
4911 lss
= gfc_walk_expr (expr1
);
4912 rss
= gfc_walk_expr (expr2
);
4913 if (lss
== gfc_ss_terminator
)
4915 /* Scalar pointers. */
4916 lse
.want_pointer
= 1;
4917 gfc_conv_expr (&lse
, expr1
);
4918 gcc_assert (rss
== gfc_ss_terminator
);
4919 gfc_init_se (&rse
, NULL
);
4920 rse
.want_pointer
= 1;
4921 gfc_conv_expr (&rse
, expr2
);
4923 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4924 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4925 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4928 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4929 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4930 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4933 gfc_add_block_to_block (&block
, &lse
.pre
);
4934 gfc_add_block_to_block (&block
, &rse
.pre
);
4936 /* Check character lengths if character expression. The test is only
4937 really added if -fbounds-check is enabled. Exclude deferred
4938 character length lefthand sides. */
4939 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4940 && !(expr1
->ts
.deferred
4941 && (TREE_CODE (lse
.string_length
) == VAR_DECL
))
4942 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4943 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4945 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4946 gcc_assert (lse
.string_length
&& rse
.string_length
);
4947 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4948 lse
.string_length
, rse
.string_length
,
4952 /* The assignment to an deferred character length sets the string
4953 length to that of the rhs. */
4954 if (expr1
->ts
.deferred
&& (TREE_CODE (lse
.string_length
) == VAR_DECL
))
4956 if (expr2
->expr_type
!= EXPR_NULL
)
4957 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
4959 gfc_add_modify (&block
, lse
.string_length
,
4960 build_int_cst (gfc_charlen_type_node
, 0));
4963 gfc_add_modify (&block
, lse
.expr
,
4964 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4966 gfc_add_block_to_block (&block
, &rse
.post
);
4967 gfc_add_block_to_block (&block
, &lse
.post
);
4974 tree strlen_rhs
= NULL_TREE
;
4976 /* Array pointer. Find the last reference on the LHS and if it is an
4977 array section ref, we're dealing with bounds remapping. In this case,
4978 set it to AR_FULL so that gfc_conv_expr_descriptor does
4979 not see it and process the bounds remapping afterwards explicitely. */
4980 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
4981 if (!remap
->next
&& remap
->type
== REF_ARRAY
4982 && remap
->u
.ar
.type
== AR_SECTION
)
4984 remap
->u
.ar
.type
= AR_FULL
;
4987 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
4989 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4990 strlen_lhs
= lse
.string_length
;
4993 if (expr2
->expr_type
== EXPR_NULL
)
4995 /* Just set the data pointer to null. */
4996 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4998 else if (rank_remap
)
5000 /* If we are rank-remapping, just get the RHS's descriptor and
5001 process this later on. */
5002 gfc_init_se (&rse
, NULL
);
5003 rse
.direct_byref
= 1;
5004 rse
.byref_noassign
= 1;
5005 gfc_conv_expr_descriptor (&rse
, expr2
, rss
);
5006 strlen_rhs
= rse
.string_length
;
5008 else if (expr2
->expr_type
== EXPR_VARIABLE
)
5010 /* Assign directly to the LHS's descriptor. */
5011 lse
.direct_byref
= 1;
5012 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
5013 strlen_rhs
= lse
.string_length
;
5015 /* If this is a subreference array pointer assignment, use the rhs
5016 descriptor element size for the lhs span. */
5017 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
5019 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
5020 gfc_init_se (&rse
, NULL
);
5021 rse
.descriptor_only
= 1;
5022 gfc_conv_expr (&rse
, expr2
);
5023 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
5024 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
5025 if (!INTEGER_CST_P (tmp
))
5026 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
5027 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
5032 /* Assign to a temporary descriptor and then copy that
5033 temporary to the pointer. */
5034 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
5037 lse
.direct_byref
= 1;
5038 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
5039 strlen_rhs
= lse
.string_length
;
5040 gfc_add_modify (&lse
.pre
, desc
, tmp
);
5043 gfc_add_block_to_block (&block
, &lse
.pre
);
5045 gfc_add_block_to_block (&block
, &rse
.pre
);
5047 /* If we do bounds remapping, update LHS descriptor accordingly. */
5051 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
5055 /* Do rank remapping. We already have the RHS's descriptor
5056 converted in rse and now have to build the correct LHS
5057 descriptor for it. */
5061 tree lbound
, ubound
;
5064 dtype
= gfc_conv_descriptor_dtype (desc
);
5065 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
5066 gfc_add_modify (&block
, dtype
, tmp
);
5068 /* Copy data pointer. */
5069 data
= gfc_conv_descriptor_data_get (rse
.expr
);
5070 gfc_conv_descriptor_data_set (&block
, desc
, data
);
5072 /* Copy offset but adjust it such that it would correspond
5073 to a lbound of zero. */
5074 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
5075 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
5077 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5079 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
5081 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5082 gfc_array_index_type
, stride
, lbound
);
5083 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
5084 gfc_array_index_type
, offs
, tmp
);
5086 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5088 /* Set the bounds as declared for the LHS and calculate strides as
5089 well as another offset update accordingly. */
5090 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5092 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
5097 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
5099 /* Convert declared bounds. */
5100 gfc_init_se (&lower_se
, NULL
);
5101 gfc_init_se (&upper_se
, NULL
);
5102 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
5103 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
5105 gfc_add_block_to_block (&block
, &lower_se
.pre
);
5106 gfc_add_block_to_block (&block
, &upper_se
.pre
);
5108 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
5109 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
5111 lbound
= gfc_evaluate_now (lbound
, &block
);
5112 ubound
= gfc_evaluate_now (ubound
, &block
);
5114 gfc_add_block_to_block (&block
, &lower_se
.post
);
5115 gfc_add_block_to_block (&block
, &upper_se
.post
);
5117 /* Set bounds in descriptor. */
5118 gfc_conv_descriptor_lbound_set (&block
, desc
,
5119 gfc_rank_cst
[dim
], lbound
);
5120 gfc_conv_descriptor_ubound_set (&block
, desc
,
5121 gfc_rank_cst
[dim
], ubound
);
5124 stride
= gfc_evaluate_now (stride
, &block
);
5125 gfc_conv_descriptor_stride_set (&block
, desc
,
5126 gfc_rank_cst
[dim
], stride
);
5128 /* Update offset. */
5129 offs
= gfc_conv_descriptor_offset_get (desc
);
5130 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5131 gfc_array_index_type
, lbound
, stride
);
5132 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
5133 gfc_array_index_type
, offs
, tmp
);
5134 offs
= gfc_evaluate_now (offs
, &block
);
5135 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5137 /* Update stride. */
5138 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5139 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5140 gfc_array_index_type
, stride
, tmp
);
5145 /* Bounds remapping. Just shift the lower bounds. */
5147 gcc_assert (expr1
->rank
== expr2
->rank
);
5149 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
5153 gcc_assert (remap
->u
.ar
.start
[dim
]);
5154 gcc_assert (!remap
->u
.ar
.end
[dim
]);
5155 gfc_init_se (&lbound_se
, NULL
);
5156 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
5158 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
5159 gfc_conv_shift_descriptor_lbound (&block
, desc
,
5160 dim
, lbound_se
.expr
);
5161 gfc_add_block_to_block (&block
, &lbound_se
.post
);
5166 /* Check string lengths if applicable. The check is only really added
5167 to the output code if -fbounds-check is enabled. */
5168 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
5170 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5171 gcc_assert (strlen_lhs
&& strlen_rhs
);
5172 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5173 strlen_lhs
, strlen_rhs
, &block
);
5176 /* If rank remapping was done, check with -fcheck=bounds that
5177 the target is at least as large as the pointer. */
5178 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
5184 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
5185 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
5187 lsize
= gfc_evaluate_now (lsize
, &block
);
5188 rsize
= gfc_evaluate_now (rsize
, &block
);
5189 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
5192 msg
= _("Target of rank remapping is too small (%ld < %ld)");
5193 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
5197 gfc_add_block_to_block (&block
, &lse
.post
);
5199 gfc_add_block_to_block (&block
, &rse
.post
);
5202 return gfc_finish_block (&block
);
5206 /* Makes sure se is suitable for passing as a function string parameter. */
5207 /* TODO: Need to check all callers of this function. It may be abused. */
5210 gfc_conv_string_parameter (gfc_se
* se
)
5214 if (TREE_CODE (se
->expr
) == STRING_CST
)
5216 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
5217 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5221 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
5223 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
5225 type
= TREE_TYPE (se
->expr
);
5226 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5230 type
= gfc_get_character_type_len (gfc_default_character_kind
,
5232 type
= build_pointer_type (type
);
5233 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
5237 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
5241 /* Generate code for assignment of scalar variables. Includes character
5242 strings and derived types with allocatable components.
5243 If you know that the LHS has no allocations, set dealloc to false. */
5246 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
5247 bool l_is_temp
, bool r_is_var
, bool dealloc
)
5253 gfc_init_block (&block
);
5255 if (ts
.type
== BT_CHARACTER
)
5260 if (lse
->string_length
!= NULL_TREE
)
5262 gfc_conv_string_parameter (lse
);
5263 gfc_add_block_to_block (&block
, &lse
->pre
);
5264 llen
= lse
->string_length
;
5267 if (rse
->string_length
!= NULL_TREE
)
5269 gcc_assert (rse
->string_length
!= NULL_TREE
);
5270 gfc_conv_string_parameter (rse
);
5271 gfc_add_block_to_block (&block
, &rse
->pre
);
5272 rlen
= rse
->string_length
;
5275 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
5276 rse
->expr
, ts
.kind
);
5278 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
5282 /* Are the rhs and the lhs the same? */
5285 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5286 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
5287 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
5288 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
5291 /* Deallocate the lhs allocated components as long as it is not
5292 the same as the rhs. This must be done following the assignment
5293 to prevent deallocating data that could be used in the rhs
5295 if (!l_is_temp
&& dealloc
)
5297 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
5298 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
5300 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5302 gfc_add_expr_to_block (&lse
->post
, tmp
);
5305 gfc_add_block_to_block (&block
, &rse
->pre
);
5306 gfc_add_block_to_block (&block
, &lse
->pre
);
5308 gfc_add_modify (&block
, lse
->expr
,
5309 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5311 /* Do a deep copy if the rhs is a variable, if it is not the
5315 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
5316 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5318 gfc_add_expr_to_block (&block
, tmp
);
5321 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
5323 gfc_add_block_to_block (&block
, &lse
->pre
);
5324 gfc_add_block_to_block (&block
, &rse
->pre
);
5325 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
5326 TREE_TYPE (lse
->expr
), rse
->expr
);
5327 gfc_add_modify (&block
, lse
->expr
, tmp
);
5331 gfc_add_block_to_block (&block
, &lse
->pre
);
5332 gfc_add_block_to_block (&block
, &rse
->pre
);
5334 gfc_add_modify (&block
, lse
->expr
,
5335 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5338 gfc_add_block_to_block (&block
, &lse
->post
);
5339 gfc_add_block_to_block (&block
, &rse
->post
);
5341 return gfc_finish_block (&block
);
5345 /* There are quite a lot of restrictions on the optimisation in using an
5346 array function assign without a temporary. */
5349 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
5352 bool seen_array_ref
;
5354 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
5356 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5357 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
5360 /* Elemental functions are scalarized so that they don't need a
5361 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5362 they would need special treatment in gfc_trans_arrayfunc_assign. */
5363 if (expr2
->value
.function
.esym
!= NULL
5364 && expr2
->value
.function
.esym
->attr
.elemental
)
5367 /* Need a temporary if rhs is not FULL or a contiguous section. */
5368 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
5371 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5372 if (gfc_ref_needs_temporary_p (expr1
->ref
))
5375 /* Functions returning pointers need temporaries. */
5376 if (expr2
->symtree
->n
.sym
->attr
.pointer
5377 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
5380 /* Character array functions need temporaries unless the
5381 character lengths are the same. */
5382 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
5384 if (expr1
->ts
.u
.cl
->length
== NULL
5385 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5388 if (expr2
->ts
.u
.cl
->length
== NULL
5389 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5392 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
5393 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
5397 /* Check that no LHS component references appear during an array
5398 reference. This is needed because we do not have the means to
5399 span any arbitrary stride with an array descriptor. This check
5400 is not needed for the rhs because the function result has to be
5402 seen_array_ref
= false;
5403 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
5405 if (ref
->type
== REF_ARRAY
)
5406 seen_array_ref
= true;
5407 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
5411 /* Check for a dependency. */
5412 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
5413 expr2
->value
.function
.esym
,
5414 expr2
->value
.function
.actual
,
5418 /* If we have reached here with an intrinsic function, we do not
5419 need a temporary. */
5420 if (expr2
->value
.function
.isym
)
5423 /* If the LHS is a dummy, we need a temporary if it is not
5425 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
5428 /* If the lhs has been host_associated, is in common, a pointer or is
5429 a target and the function is not using a RESULT variable, aliasing
5430 can occur and a temporary is needed. */
5431 if ((sym
->attr
.host_assoc
5432 || sym
->attr
.in_common
5433 || sym
->attr
.pointer
5434 || sym
->attr
.cray_pointee
5435 || sym
->attr
.target
)
5436 && expr2
->symtree
!= NULL
5437 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
5440 /* A PURE function can unconditionally be called without a temporary. */
5441 if (expr2
->value
.function
.esym
!= NULL
5442 && expr2
->value
.function
.esym
->attr
.pure
)
5445 /* Implicit_pure functions are those which could legally be declared
5447 if (expr2
->value
.function
.esym
!= NULL
5448 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
5451 if (!sym
->attr
.use_assoc
5452 && !sym
->attr
.in_common
5453 && !sym
->attr
.pointer
5454 && !sym
->attr
.target
5455 && !sym
->attr
.cray_pointee
5456 && expr2
->value
.function
.esym
)
5458 /* A temporary is not needed if the function is not contained and
5459 the variable is local or host associated and not a pointer or
5461 if (!expr2
->value
.function
.esym
->attr
.contained
)
5464 /* A temporary is not needed if the lhs has never been host
5465 associated and the procedure is contained. */
5466 else if (!sym
->attr
.host_assoc
)
5469 /* A temporary is not needed if the variable is local and not
5470 a pointer, a target or a result. */
5472 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
5476 /* Default to temporary use. */
5481 /* Provide the loop info so that the lhs descriptor can be built for
5482 reallocatable assignments from extrinsic function calls. */
5485 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
)
5488 /* Signal that the function call should not be made by
5489 gfc_conv_loop_setup. */
5490 se
->ss
->is_alloc_lhs
= 1;
5491 gfc_init_loopinfo (&loop
);
5492 gfc_add_ss_to_loop (&loop
, *ss
);
5493 gfc_add_ss_to_loop (&loop
, se
->ss
);
5494 gfc_conv_ss_startstride (&loop
);
5495 gfc_conv_loop_setup (&loop
, where
);
5496 gfc_copy_loopinfo_to_se (se
, &loop
);
5497 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5498 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5499 se
->ss
->is_alloc_lhs
= 0;
5504 realloc_lhs_bounds_for_intrinsic_call (gfc_se
*se
, int rank
)
5511 /* Use the allocation done by the library. */
5512 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5513 tmp
= gfc_conv_descriptor_data_get (desc
);
5514 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
5515 gfc_add_expr_to_block (&se
->pre
, tmp
);
5516 gfc_conv_descriptor_data_set (&se
->pre
, desc
, null_pointer_node
);
5517 /* Unallocated, the descriptor does not have a dtype. */
5518 tmp
= gfc_conv_descriptor_dtype (desc
);
5519 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
5521 offset
= gfc_index_zero_node
;
5522 tmp
= gfc_index_one_node
;
5523 /* Now reset the bounds from zero based to unity based. */
5524 for (n
= 0 ; n
< rank
; n
++)
5526 /* Accumulate the offset. */
5527 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5528 gfc_array_index_type
,
5530 /* Now do the bounds. */
5531 gfc_conv_descriptor_offset_set (&se
->post
, desc
, tmp
);
5532 tmp
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
5533 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5534 gfc_array_index_type
,
5535 tmp
, gfc_index_one_node
);
5536 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
5538 gfc_index_one_node
);
5539 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
5540 gfc_rank_cst
[n
], tmp
);
5542 /* The extent for the next contribution to offset. */
5543 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5544 gfc_array_index_type
,
5545 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
5546 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
5547 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5548 gfc_array_index_type
,
5549 tmp
, gfc_index_one_node
);
5551 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
5556 /* Try to translate array(:) = func (...), where func is a transformational
5557 array function, without using a temporary. Returns NULL if this isn't the
5561 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
5565 gfc_component
*comp
= NULL
;
5567 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
5570 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5572 gcc_assert (expr2
->value
.function
.isym
5573 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
5574 && comp
&& comp
->attr
.dimension
)
5575 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
5576 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
5578 ss
= gfc_walk_expr (expr1
);
5579 gcc_assert (ss
!= gfc_ss_terminator
);
5580 gfc_init_se (&se
, NULL
);
5581 gfc_start_block (&se
.pre
);
5582 se
.want_pointer
= 1;
5584 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
5586 if (expr1
->ts
.type
== BT_DERIVED
5587 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
5590 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
5592 gfc_add_expr_to_block (&se
.pre
, tmp
);
5595 se
.direct_byref
= 1;
5596 se
.ss
= gfc_walk_expr (expr2
);
5597 gcc_assert (se
.ss
!= gfc_ss_terminator
);
5599 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5600 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5601 Clearly, this cannot be done for an allocatable function result, since
5602 the shape of the result is unknown and, in any case, the function must
5603 correctly take care of the reallocation internally. For intrinsic
5604 calls, the array data is freed and the library takes care of allocation.
5605 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5607 if (gfc_option
.flag_realloc_lhs
5608 && gfc_is_reallocatable_lhs (expr1
)
5609 && !gfc_expr_attr (expr1
).codimension
5610 && !gfc_is_coindexed (expr1
)
5611 && !(expr2
->value
.function
.esym
5612 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
5614 if (!expr2
->value
.function
.isym
)
5616 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
);
5617 ss
->is_alloc_lhs
= 1;
5620 realloc_lhs_bounds_for_intrinsic_call (&se
, expr1
->rank
);
5623 gfc_conv_function_expr (&se
, expr2
);
5624 gfc_add_block_to_block (&se
.pre
, &se
.post
);
5626 return gfc_finish_block (&se
.pre
);
5630 /* Try to efficiently translate array(:) = 0. Return NULL if this
5634 gfc_trans_zero_assign (gfc_expr
* expr
)
5636 tree dest
, len
, type
;
5640 sym
= expr
->symtree
->n
.sym
;
5641 dest
= gfc_get_symbol_decl (sym
);
5643 type
= TREE_TYPE (dest
);
5644 if (POINTER_TYPE_P (type
))
5645 type
= TREE_TYPE (type
);
5646 if (!GFC_ARRAY_TYPE_P (type
))
5649 /* Determine the length of the array. */
5650 len
= GFC_TYPE_ARRAY_SIZE (type
);
5651 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5654 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5655 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5656 fold_convert (gfc_array_index_type
, tmp
));
5658 /* If we are zeroing a local array avoid taking its address by emitting
5660 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5661 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5662 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5664 /* Convert arguments to the correct types. */
5665 dest
= fold_convert (pvoid_type_node
, dest
);
5666 len
= fold_convert (size_type_node
, len
);
5668 /* Construct call to __builtin_memset. */
5669 tmp
= build_call_expr_loc (input_location
,
5670 built_in_decls
[BUILT_IN_MEMSET
],
5671 3, dest
, integer_zero_node
, len
);
5672 return fold_convert (void_type_node
, tmp
);
5676 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5677 that constructs the call to __builtin_memcpy. */
5680 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5684 /* Convert arguments to the correct types. */
5685 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5686 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5688 dst
= fold_convert (pvoid_type_node
, dst
);
5690 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5691 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5693 src
= fold_convert (pvoid_type_node
, src
);
5695 len
= fold_convert (size_type_node
, len
);
5697 /* Construct call to __builtin_memcpy. */
5698 tmp
= build_call_expr_loc (input_location
,
5699 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5700 return fold_convert (void_type_node
, tmp
);
5704 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5705 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5706 source/rhs, both are gfc_full_array_ref_p which have been checked for
5710 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5712 tree dst
, dlen
, dtype
;
5713 tree src
, slen
, stype
;
5716 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5717 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5719 dtype
= TREE_TYPE (dst
);
5720 if (POINTER_TYPE_P (dtype
))
5721 dtype
= TREE_TYPE (dtype
);
5722 stype
= TREE_TYPE (src
);
5723 if (POINTER_TYPE_P (stype
))
5724 stype
= TREE_TYPE (stype
);
5726 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5729 /* Determine the lengths of the arrays. */
5730 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5731 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5733 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5734 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5735 dlen
, fold_convert (gfc_array_index_type
, tmp
));
5737 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5738 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5740 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5741 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5742 slen
, fold_convert (gfc_array_index_type
, tmp
));
5744 /* Sanity check that they are the same. This should always be
5745 the case, as we should already have checked for conformance. */
5746 if (!tree_int_cst_equal (slen
, dlen
))
5749 return gfc_build_memcpy_call (dst
, src
, dlen
);
5753 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5754 this can't be done. EXPR1 is the destination/lhs for which
5755 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5758 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5760 unsigned HOST_WIDE_INT nelem
;
5766 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5770 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5771 dtype
= TREE_TYPE (dst
);
5772 if (POINTER_TYPE_P (dtype
))
5773 dtype
= TREE_TYPE (dtype
);
5774 if (!GFC_ARRAY_TYPE_P (dtype
))
5777 /* Determine the lengths of the array. */
5778 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5779 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5782 /* Confirm that the constructor is the same size. */
5783 if (compare_tree_int (len
, nelem
) != 0)
5786 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5787 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5788 fold_convert (gfc_array_index_type
, tmp
));
5790 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5791 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5793 stype
= TREE_TYPE (src
);
5794 if (POINTER_TYPE_P (stype
))
5795 stype
= TREE_TYPE (stype
);
5797 return gfc_build_memcpy_call (dst
, src
, len
);
5801 /* Tells whether the expression is to be treated as a variable reference. */
5804 expr_is_variable (gfc_expr
*expr
)
5808 if (expr
->expr_type
== EXPR_VARIABLE
)
5811 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
5814 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
5815 return expr_is_variable (arg
);
5822 /* Is the lhs OK for automatic reallocation? */
5825 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
5829 /* An allocatable variable with no reference. */
5830 if (expr
->symtree
->n
.sym
->attr
.allocatable
5834 /* All that can be left are allocatable components. */
5835 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
5836 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
5837 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
5840 /* Find an allocatable component ref last. */
5841 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5842 if (ref
->type
== REF_COMPONENT
5844 && ref
->u
.c
.component
->attr
.allocatable
)
5851 /* Allocate or reallocate scalar lhs, as necessary. */
5854 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
5868 if (!expr1
|| expr1
->rank
)
5871 if (!expr2
|| expr2
->rank
)
5874 /* Since this is a scalar lhs, we can afford to do this. That is,
5875 there is no risk of side effects being repeated. */
5876 gfc_init_se (&lse
, NULL
);
5877 lse
.want_pointer
= 1;
5878 gfc_conv_expr (&lse
, expr1
);
5880 jump_label1
= gfc_build_label_decl (NULL_TREE
);
5881 jump_label2
= gfc_build_label_decl (NULL_TREE
);
5883 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
5884 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
5885 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5887 tmp
= build3_v (COND_EXPR
, cond
,
5888 build1_v (GOTO_EXPR
, jump_label1
),
5889 build_empty_stmt (input_location
));
5890 gfc_add_expr_to_block (block
, tmp
);
5892 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
5894 /* Use the rhs string length and the lhs element size. */
5895 size
= string_length
;
5896 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
5897 tmp
= TYPE_SIZE_UNIT (tmp
);
5898 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
5899 TREE_TYPE (tmp
), tmp
,
5900 fold_convert (TREE_TYPE (tmp
), size
));
5904 /* Otherwise use the length in bytes of the rhs. */
5905 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
5906 size_in_bytes
= size
;
5909 tmp
= build_call_expr_loc (input_location
,
5910 built_in_decls
[BUILT_IN_MALLOC
], 1,
5912 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
5913 gfc_add_modify (block
, lse
.expr
, tmp
);
5914 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
5916 /* Deferred characters need checking for lhs and rhs string
5917 length. Other deferred parameter variables will have to
5919 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
5920 gfc_add_expr_to_block (block
, tmp
);
5922 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
5923 gfc_add_expr_to_block (block
, tmp
);
5925 /* For a deferred length character, reallocate if lengths of lhs and
5926 rhs are different. */
5927 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
5929 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5930 expr1
->ts
.u
.cl
->backend_decl
, size
);
5931 /* Jump past the realloc if the lengths are the same. */
5932 tmp
= build3_v (COND_EXPR
, cond
,
5933 build1_v (GOTO_EXPR
, jump_label2
),
5934 build_empty_stmt (input_location
));
5935 gfc_add_expr_to_block (block
, tmp
);
5936 tmp
= build_call_expr_loc (input_location
,
5937 built_in_decls
[BUILT_IN_REALLOC
], 2,
5938 fold_convert (pvoid_type_node
, lse
.expr
),
5940 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
5941 gfc_add_modify (block
, lse
.expr
, tmp
);
5942 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
5943 gfc_add_expr_to_block (block
, tmp
);
5945 /* Update the lhs character length. */
5946 size
= string_length
;
5947 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
5952 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5953 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5954 init_flag indicates initialization expressions and dealloc that no
5955 deallocate prior assignment is needed (if in doubt, set true). */
5958 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5964 gfc_ss
*lss_section
;
5971 bool scalar_to_array
;
5976 /* Assignment of the form lhs = rhs. */
5977 gfc_start_block (&block
);
5979 gfc_init_se (&lse
, NULL
);
5980 gfc_init_se (&rse
, NULL
);
5983 lss
= gfc_walk_expr (expr1
);
5984 if (gfc_is_reallocatable_lhs (expr1
)
5985 && !(expr2
->expr_type
== EXPR_FUNCTION
5986 && expr2
->value
.function
.isym
!= NULL
))
5987 lss
->is_alloc_lhs
= 1;
5989 if (lss
!= gfc_ss_terminator
)
5991 /* Allow the scalarizer to workshare array assignments. */
5992 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5993 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5995 /* The assignment needs scalarization. */
5998 /* Find a non-scalar SS from the lhs. */
5999 while (lss_section
!= gfc_ss_terminator
6000 && lss_section
->type
!= GFC_SS_SECTION
)
6001 lss_section
= lss_section
->next
;
6003 gcc_assert (lss_section
!= gfc_ss_terminator
);
6005 /* Initialize the scalarizer. */
6006 gfc_init_loopinfo (&loop
);
6009 rss
= gfc_walk_expr (expr2
);
6010 if (rss
== gfc_ss_terminator
)
6012 /* The rhs is scalar. Add a ss for the expression. */
6013 rss
= gfc_get_ss ();
6014 rss
->next
= gfc_ss_terminator
;
6015 rss
->type
= GFC_SS_SCALAR
;
6018 /* Associate the SS with the loop. */
6019 gfc_add_ss_to_loop (&loop
, lss
);
6020 gfc_add_ss_to_loop (&loop
, rss
);
6022 /* Calculate the bounds of the scalarization. */
6023 gfc_conv_ss_startstride (&loop
);
6024 /* Enable loop reversal. */
6025 for (n
= 0; n
< loop
.dimen
; n
++)
6026 loop
.reverse
[n
] = GFC_REVERSE_NOT_SET
;
6027 /* Resolve any data dependencies in the statement. */
6028 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
6029 /* Setup the scalarizing loops. */
6030 gfc_conv_loop_setup (&loop
, &expr2
->where
);
6032 /* Setup the gfc_se structures. */
6033 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6034 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6037 gfc_mark_ss_chain_used (rss
, 1);
6038 if (loop
.temp_ss
== NULL
)
6041 gfc_mark_ss_chain_used (lss
, 1);
6045 lse
.ss
= loop
.temp_ss
;
6046 gfc_mark_ss_chain_used (lss
, 3);
6047 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
6050 /* Start the scalarized loop body. */
6051 gfc_start_scalarized_body (&loop
, &body
);
6054 gfc_init_block (&body
);
6056 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
6058 /* Translate the expression. */
6059 gfc_conv_expr (&rse
, expr2
);
6061 /* Stabilize a string length for temporaries. */
6062 if (expr2
->ts
.type
== BT_CHARACTER
)
6063 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
6065 string_length
= NULL_TREE
;
6069 gfc_conv_tmp_array_ref (&lse
);
6070 if (expr2
->ts
.type
== BT_CHARACTER
)
6071 lse
.string_length
= string_length
;
6074 gfc_conv_expr (&lse
, expr1
);
6076 /* Assignments of scalar derived types with allocatable components
6077 to arrays must be done with a deep copy and the rhs temporary
6078 must have its components deallocated afterwards. */
6079 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
6080 && expr2
->ts
.u
.derived
->attr
.alloc_comp
6081 && !expr_is_variable (expr2
)
6082 && !gfc_is_constant_expr (expr2
)
6083 && expr1
->rank
&& !expr2
->rank
);
6084 if (scalar_to_array
&& dealloc
)
6086 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
6087 gfc_add_expr_to_block (&loop
.post
, tmp
);
6090 /* For a deferred character length function, the function call must
6091 happen before the (re)allocation of the lhs, otherwise the character
6092 length of the result is not known. */
6093 def_clen_func
= (((expr2
->expr_type
== EXPR_FUNCTION
)
6094 || (expr2
->expr_type
== EXPR_COMPCALL
)
6095 || (expr2
->expr_type
== EXPR_PPC
))
6096 && expr2
->ts
.deferred
);
6097 if (gfc_option
.flag_realloc_lhs
6098 && expr2
->ts
.type
== BT_CHARACTER
6099 && (def_clen_func
|| expr2
->expr_type
== EXPR_OP
)
6100 && expr1
->ts
.deferred
)
6101 gfc_add_block_to_block (&block
, &rse
.pre
);
6103 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
6104 l_is_temp
|| init_flag
,
6105 expr_is_variable (expr2
) || scalar_to_array
,
6107 gfc_add_expr_to_block (&body
, tmp
);
6109 if (lss
== gfc_ss_terminator
)
6111 /* F2003: Add the code for reallocation on assignment. */
6112 if (gfc_option
.flag_realloc_lhs
6113 && is_scalar_reallocatable_lhs (expr1
))
6114 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
6117 /* Use the scalar assignment as is. */
6118 gfc_add_block_to_block (&block
, &body
);
6122 gcc_assert (lse
.ss
== gfc_ss_terminator
6123 && rse
.ss
== gfc_ss_terminator
);
6127 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6129 /* We need to copy the temporary to the actual lhs. */
6130 gfc_init_se (&lse
, NULL
);
6131 gfc_init_se (&rse
, NULL
);
6132 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6133 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6135 rse
.ss
= loop
.temp_ss
;
6138 gfc_conv_tmp_array_ref (&rse
);
6139 gfc_conv_expr (&lse
, expr1
);
6141 gcc_assert (lse
.ss
== gfc_ss_terminator
6142 && rse
.ss
== gfc_ss_terminator
);
6144 if (expr2
->ts
.type
== BT_CHARACTER
)
6145 rse
.string_length
= string_length
;
6147 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
6148 false, false, dealloc
);
6149 gfc_add_expr_to_block (&body
, tmp
);
6152 /* F2003: Allocate or reallocate lhs of allocatable array. */
6153 if (gfc_option
.flag_realloc_lhs
6154 && gfc_is_reallocatable_lhs (expr1
)
6155 && !gfc_expr_attr (expr1
).codimension
6156 && !gfc_is_coindexed (expr1
))
6158 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
6159 if (tmp
!= NULL_TREE
)
6160 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
6163 /* Generate the copying loops. */
6164 gfc_trans_scalarizing_loops (&loop
, &body
);
6166 /* Wrap the whole thing up. */
6167 gfc_add_block_to_block (&block
, &loop
.pre
);
6168 gfc_add_block_to_block (&block
, &loop
.post
);
6170 gfc_cleanup_loop (&loop
);
6173 return gfc_finish_block (&block
);
6177 /* Check whether EXPR is a copyable array. */
6180 copyable_array_p (gfc_expr
* expr
)
6182 if (expr
->expr_type
!= EXPR_VARIABLE
)
6185 /* First check it's an array. */
6186 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
6189 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
6192 /* Next check that it's of a simple enough type. */
6193 switch (expr
->ts
.type
)
6205 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
6214 /* Translate an assignment. */
6217 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
6222 /* Special case a single function returning an array. */
6223 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
6225 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
6230 /* Special case assigning an array to zero. */
6231 if (copyable_array_p (expr1
)
6232 && is_zero_initializer_p (expr2
))
6234 tmp
= gfc_trans_zero_assign (expr1
);
6239 /* Special case copying one array to another. */
6240 if (copyable_array_p (expr1
)
6241 && copyable_array_p (expr2
)
6242 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
6243 && !gfc_check_dependency (expr1
, expr2
, 0))
6245 tmp
= gfc_trans_array_copy (expr1
, expr2
);
6250 /* Special case initializing an array from a constant array constructor. */
6251 if (copyable_array_p (expr1
)
6252 && expr2
->expr_type
== EXPR_ARRAY
6253 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
6255 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
6260 /* Fallback to the scalarizer to generate explicit loops. */
6261 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
6265 gfc_trans_init_assign (gfc_code
* code
)
6267 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
6271 gfc_trans_assign (gfc_code
* code
)
6273 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
6277 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6278 A MEMCPY is needed to copy the full data from the default initializer
6279 of the dynamic type. */
6282 gfc_trans_class_init_assign (gfc_code
*code
)
6286 gfc_se dst
,src
,memsz
;
6287 gfc_expr
*lhs
,*rhs
,*sz
;
6289 gfc_start_block (&block
);
6291 lhs
= gfc_copy_expr (code
->expr1
);
6292 gfc_add_data_component (lhs
);
6294 rhs
= gfc_copy_expr (code
->expr1
);
6295 gfc_add_vptr_component (rhs
);
6297 /* Make sure that the component backend_decls have been built, which
6298 will not have happened if the derived types concerned have not
6300 gfc_get_derived_type (rhs
->ts
.u
.derived
);
6301 gfc_add_def_init_component (rhs
);
6303 sz
= gfc_copy_expr (code
->expr1
);
6304 gfc_add_vptr_component (sz
);
6305 gfc_add_size_component (sz
);
6307 gfc_init_se (&dst
, NULL
);
6308 gfc_init_se (&src
, NULL
);
6309 gfc_init_se (&memsz
, NULL
);
6310 gfc_conv_expr (&dst
, lhs
);
6311 gfc_conv_expr (&src
, rhs
);
6312 gfc_conv_expr (&memsz
, sz
);
6313 gfc_add_block_to_block (&block
, &src
.pre
);
6314 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
6315 gfc_add_expr_to_block (&block
, tmp
);
6317 return gfc_finish_block (&block
);
6321 /* Translate an assignment to a CLASS object
6322 (pointer or ordinary assignment). */
6325 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
6332 gfc_start_block (&block
);
6334 if (expr2
->ts
.type
!= BT_CLASS
)
6336 /* Insert an additional assignment which sets the '_vptr' field. */
6337 gfc_symbol
*vtab
= NULL
;
6340 lhs
= gfc_copy_expr (expr1
);
6341 gfc_add_vptr_component (lhs
);
6343 if (expr2
->ts
.type
== BT_DERIVED
)
6344 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
6345 else if (expr2
->expr_type
== EXPR_NULL
)
6346 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
6349 rhs
= gfc_get_expr ();
6350 rhs
->expr_type
= EXPR_VARIABLE
;
6351 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
6355 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
6356 gfc_add_expr_to_block (&block
, tmp
);
6358 gfc_free_expr (lhs
);
6359 gfc_free_expr (rhs
);
6362 /* Do the actual CLASS assignment. */
6363 if (expr2
->ts
.type
== BT_CLASS
)
6366 gfc_add_data_component (expr1
);
6368 if (op
== EXEC_ASSIGN
)
6369 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
6370 else if (op
== EXEC_POINTER_ASSIGN
)
6371 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
6375 gfc_add_expr_to_block (&block
, tmp
);
6377 return gfc_finish_block (&block
);