1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
53 dest
->loop
= src
->loop
;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
66 memset (se
, 0, sizeof (gfc_se
));
67 gfc_init_block (&se
->pre
);
68 gfc_init_block (&se
->post
);
73 gfc_copy_se_loopvars (se
, parent
);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se
* se
)
86 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se
* se
)
110 if (CONSTANT_CLASS_P (se
->expr
))
113 /* We need a temporary for this result. */
114 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
115 gfc_add_modify (&se
->pre
, var
, se
->expr
);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol
* sym
)
128 gcc_assert (sym
->attr
.dummy
);
130 decl
= gfc_get_symbol_decl (sym
);
131 if (TREE_CODE (decl
) != PARM_DECL
)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
137 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
140 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
141 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
143 /* Fortran 2008 allows to pass null pointers and non-associated pointers
144 as actual argument to denote absent dummies. For array descriptors,
145 we thus also need to check the array descriptor. */
146 if (!sym
->attr
.pointer
&& !sym
->attr
.allocatable
147 && sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
148 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
151 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
152 tmp
= gfc_conv_array_data (tmp
);
153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
154 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
155 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
156 boolean_type_node
, cond
, tmp
);
163 /* Converts a missing, dummy argument into a null or zero. */
166 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
171 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
175 /* Create a temporary and convert it to the correct type. */
176 tmp
= gfc_get_int_type (kind
);
177 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
180 /* Test for a NULL value. */
181 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
182 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
183 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
184 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
188 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
190 build_zero_cst (TREE_TYPE (se
->expr
)));
191 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
195 if (ts
.type
== BT_CHARACTER
)
197 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
198 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
199 present
, se
->string_length
, tmp
);
200 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
201 se
->string_length
= tmp
;
207 /* Get the character length of an expression, looking through gfc_refs
211 gfc_get_expr_charlen (gfc_expr
*e
)
216 gcc_assert (e
->expr_type
== EXPR_VARIABLE
217 && e
->ts
.type
== BT_CHARACTER
);
219 length
= NULL
; /* To silence compiler warning. */
221 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
224 gfc_init_se (&tmpse
, NULL
);
225 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
226 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
230 /* First candidate: if the variable is of type CHARACTER, the
231 expression's length could be the length of the character
233 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
234 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
236 /* Look through the reference chain for component references. */
237 for (r
= e
->ref
; r
; r
= r
->next
)
242 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
243 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
251 /* We should never got substring references here. These will be
252 broken down by the scalarizer. */
258 gcc_assert (length
!= NULL
);
263 /* For each character array constructor subexpression without a ts.u.cl->length,
264 replace it by its first element (if there aren't any elements, the length
265 should already be set to zero). */
268 flatten_array_ctors_without_strlen (gfc_expr
* e
)
270 gfc_actual_arglist
* arg
;
276 switch (e
->expr_type
)
280 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
281 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
285 /* TODO: Implement as with EXPR_FUNCTION when needed. */
289 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
290 flatten_array_ctors_without_strlen (arg
->expr
);
295 /* We've found what we're looking for. */
296 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
301 gcc_assert (e
->value
.constructor
);
303 c
= gfc_constructor_first (e
->value
.constructor
);
307 flatten_array_ctors_without_strlen (new_expr
);
308 gfc_replace_expr (e
, new_expr
);
312 /* Otherwise, fall through to handle constructor elements. */
314 for (c
= gfc_constructor_first (e
->value
.constructor
);
315 c
; c
= gfc_constructor_next (c
))
316 flatten_array_ctors_without_strlen (c
->expr
);
326 /* Generate code to initialize a string length variable. Returns the
327 value. For array constructors, cl->length might be NULL and in this case,
328 the first element of the constructor is needed. expr is the original
329 expression so we can access it but can be NULL if this is not needed. */
332 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
336 gfc_init_se (&se
, NULL
);
340 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
343 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
344 "flatten" array constructors by taking their first element; all elements
345 should be the same length or a cl->length should be present. */
350 expr_flat
= gfc_copy_expr (expr
);
351 flatten_array_ctors_without_strlen (expr_flat
);
352 gfc_resolve_expr (expr_flat
);
354 gfc_conv_expr (&se
, expr_flat
);
355 gfc_add_block_to_block (pblock
, &se
.pre
);
356 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
358 gfc_free_expr (expr_flat
);
362 /* Convert cl->length. */
364 gcc_assert (cl
->length
);
366 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
367 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
368 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
369 gfc_add_block_to_block (pblock
, &se
.pre
);
371 if (cl
->backend_decl
)
372 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
374 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
379 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
380 const char *name
, locus
*where
)
389 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
390 type
= build_pointer_type (type
);
392 gfc_init_se (&start
, se
);
393 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
394 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
396 if (integer_onep (start
.expr
))
397 gfc_conv_string_parameter (se
);
402 /* Avoid multiple evaluation of substring start. */
403 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
404 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
406 /* Change the start of the string. */
407 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
410 tmp
= build_fold_indirect_ref_loc (input_location
,
412 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
413 se
->expr
= gfc_build_addr_expr (type
, tmp
);
416 /* Length = end + 1 - start. */
417 gfc_init_se (&end
, se
);
418 if (ref
->u
.ss
.end
== NULL
)
419 end
.expr
= se
->string_length
;
422 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
423 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
427 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
428 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
430 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
432 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
433 boolean_type_node
, start
.expr
,
436 /* Check lower bound. */
437 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
439 build_int_cst (gfc_charlen_type_node
, 1));
440 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
441 boolean_type_node
, nonempty
, fault
);
443 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
444 "is less than one", name
);
446 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
448 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
449 fold_convert (long_integer_type_node
,
453 /* Check upper bound. */
454 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
455 end
.expr
, se
->string_length
);
456 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
457 boolean_type_node
, nonempty
, fault
);
459 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
460 "exceeds string length (%%ld)", name
);
462 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
463 "exceeds string length (%%ld)");
464 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
465 fold_convert (long_integer_type_node
, end
.expr
),
466 fold_convert (long_integer_type_node
,
471 /* If the start and end expressions are equal, the length is one. */
473 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
474 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
477 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
478 end
.expr
, start
.expr
);
479 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
480 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
481 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
482 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
485 se
->string_length
= tmp
;
489 /* Convert a derived type component reference. */
492 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
499 c
= ref
->u
.c
.component
;
501 gcc_assert (c
->backend_decl
);
503 field
= c
->backend_decl
;
504 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
506 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
507 decl
, field
, NULL_TREE
);
511 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
513 tmp
= c
->ts
.u
.cl
->backend_decl
;
514 /* Components must always be constant length. */
515 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
516 se
->string_length
= tmp
;
519 if (((c
->attr
.pointer
|| c
->attr
.allocatable
) && c
->attr
.dimension
== 0
520 && c
->ts
.type
!= BT_CHARACTER
)
521 || c
->attr
.proc_pointer
)
522 se
->expr
= build_fold_indirect_ref_loc (input_location
,
527 /* This function deals with component references to components of the
528 parent type for derived type extensons. */
530 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
538 c
= ref
->u
.c
.component
;
540 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
541 parent
.type
= REF_COMPONENT
;
544 parent
.u
.c
.component
= dt
->components
;
546 if (dt
->backend_decl
== NULL
)
547 gfc_get_derived_type (dt
);
549 if (dt
->attr
.extension
&& dt
->components
)
551 if (dt
->attr
.is_class
)
552 cmp
= dt
->components
;
554 cmp
= dt
->components
->next
;
555 /* Return if the component is not in the parent type. */
556 for (; cmp
; cmp
= cmp
->next
)
557 if (strcmp (c
->name
, cmp
->name
) == 0)
560 /* Otherwise build the reference and call self. */
561 gfc_conv_component_ref (se
, &parent
);
562 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
563 parent
.u
.c
.component
= c
;
564 conv_parent_component_references (se
, &parent
);
568 /* Return the contents of a variable. Also handles reference/pointer
569 variables (all Fortran pointer references are implicit). */
572 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
576 tree parent_decl
= NULL_TREE
;
579 bool alternate_entry
;
582 sym
= expr
->symtree
->n
.sym
;
585 /* Check that something hasn't gone horribly wrong. */
586 gcc_assert (se
->ss
!= gfc_ss_terminator
);
587 gcc_assert (se
->ss
->expr
== expr
);
589 /* A scalarized term. We already know the descriptor. */
590 se
->expr
= se
->ss
->data
.info
.descriptor
;
591 se
->string_length
= se
->ss
->string_length
;
592 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
593 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
598 tree se_expr
= NULL_TREE
;
600 se
->expr
= gfc_get_symbol_decl (sym
);
602 /* Deal with references to a parent results or entries by storing
603 the current_function_decl and moving to the parent_decl. */
604 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
605 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
606 && sym
->result
== sym
;
607 entry_master
= sym
->attr
.result
608 && sym
->ns
->proc_name
->attr
.entry_master
609 && !gfc_return_by_reference (sym
->ns
->proc_name
);
610 if (current_function_decl
)
611 parent_decl
= DECL_CONTEXT (current_function_decl
);
613 if ((se
->expr
== parent_decl
&& return_value
)
614 || (sym
->ns
&& sym
->ns
->proc_name
616 && sym
->ns
->proc_name
->backend_decl
== parent_decl
617 && (alternate_entry
|| entry_master
)))
622 /* Special case for assigning the return value of a function.
623 Self recursive functions must have an explicit return value. */
624 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
625 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
627 /* Similarly for alternate entry points. */
628 else if (alternate_entry
629 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
632 gfc_entry_list
*el
= NULL
;
634 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
637 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
642 else if (entry_master
643 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
645 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
650 /* Procedure actual arguments. */
651 else if (sym
->attr
.flavor
== FL_PROCEDURE
652 && se
->expr
!= current_function_decl
)
654 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
656 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
657 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
663 /* Dereference the expression, where needed. Since characters
664 are entirely different from other types, they are treated
666 if (sym
->ts
.type
== BT_CHARACTER
)
668 /* Dereference character pointer dummy arguments
670 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
672 || sym
->attr
.function
673 || sym
->attr
.result
))
674 se
->expr
= build_fold_indirect_ref_loc (input_location
,
678 else if (!sym
->attr
.value
)
680 /* Dereference non-character scalar dummy arguments. */
681 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
682 se
->expr
= build_fold_indirect_ref_loc (input_location
,
685 /* Dereference scalar hidden result. */
686 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
687 && (sym
->attr
.function
|| sym
->attr
.result
)
688 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
689 && !sym
->attr
.always_explicit
)
690 se
->expr
= build_fold_indirect_ref_loc (input_location
,
693 /* Dereference non-character pointer variables.
694 These must be dummies, results, or scalars. */
695 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
696 || gfc_is_associate_pointer (sym
))
698 || sym
->attr
.function
700 || !sym
->attr
.dimension
))
701 se
->expr
= build_fold_indirect_ref_loc (input_location
,
708 /* For character variables, also get the length. */
709 if (sym
->ts
.type
== BT_CHARACTER
)
711 /* If the character length of an entry isn't set, get the length from
712 the master function instead. */
713 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
714 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
716 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
717 gcc_assert (se
->string_length
);
725 /* Return the descriptor if that's what we want and this is an array
726 section reference. */
727 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
729 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
730 /* Return the descriptor for array pointers and allocations. */
732 && ref
->next
== NULL
&& (se
->descriptor_only
))
735 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
736 /* Return a pointer to an element. */
740 if (ref
->u
.c
.sym
->attr
.extension
)
741 conv_parent_component_references (se
, ref
);
743 gfc_conv_component_ref (se
, ref
);
747 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
748 expr
->symtree
->name
, &expr
->where
);
757 /* Pointer assignment, allocation or pass by reference. Arrays are handled
759 if (se
->want_pointer
)
761 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
762 gfc_conv_string_parameter (se
);
764 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
769 /* Unary ops are easy... Or they would be if ! was a valid op. */
772 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
777 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
778 /* Initialize the operand. */
779 gfc_init_se (&operand
, se
);
780 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
781 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
783 type
= gfc_typenode_for_spec (&expr
->ts
);
785 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
786 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
787 All other unary operators have an equivalent GIMPLE unary operator. */
788 if (code
== TRUTH_NOT_EXPR
)
789 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
790 build_int_cst (type
, 0));
792 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
796 /* Expand power operator to optimal multiplications when a value is raised
797 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
798 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
799 Programming", 3rd Edition, 1998. */
801 /* This code is mostly duplicated from expand_powi in the backend.
802 We establish the "optimal power tree" lookup table with the defined size.
803 The items in the table are the exponents used to calculate the index
804 exponents. Any integer n less than the value can get an "addition chain",
805 with the first node being one. */
806 #define POWI_TABLE_SIZE 256
808 /* The table is from builtins.c. */
809 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
811 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
812 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
813 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
814 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
815 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
816 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
817 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
818 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
819 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
820 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
821 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
822 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
823 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
824 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
825 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
826 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
827 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
828 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
829 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
830 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
831 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
832 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
833 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
834 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
835 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
836 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
837 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
838 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
839 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
840 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
841 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
842 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
845 /* If n is larger than lookup table's max index, we use the "window
847 #define POWI_WINDOW_SIZE 3
849 /* Recursive function to expand the power operator. The temporary
850 values are put in tmpvar. The function returns tmpvar[1] ** n. */
852 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
859 if (n
< POWI_TABLE_SIZE
)
864 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
865 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
869 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
870 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
871 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
875 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
879 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
880 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
882 if (n
< POWI_TABLE_SIZE
)
889 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
890 return 1. Else return 0 and a call to runtime library functions
891 will have to be built. */
893 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
898 tree vartmp
[POWI_TABLE_SIZE
];
900 unsigned HOST_WIDE_INT n
;
903 /* If exponent is too large, we won't expand it anyway, so don't bother
904 with large integer values. */
905 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
908 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
909 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
910 of the asymmetric range of the integer type. */
911 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
913 type
= TREE_TYPE (lhs
);
914 sgn
= tree_int_cst_sgn (rhs
);
916 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
917 || optimize_size
) && (m
> 2 || m
< -1))
923 se
->expr
= gfc_build_const (type
, integer_one_node
);
927 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
928 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
930 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
931 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
932 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
933 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
936 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
939 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
940 boolean_type_node
, tmp
, cond
);
941 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
942 tmp
, build_int_cst (type
, 1),
943 build_int_cst (type
, 0));
947 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
948 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
949 build_int_cst (type
, -1),
950 build_int_cst (type
, 0));
951 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
952 cond
, build_int_cst (type
, 1), tmp
);
956 memset (vartmp
, 0, sizeof (vartmp
));
960 tmp
= gfc_build_const (type
, integer_one_node
);
961 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
965 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
971 /* Power op (**). Constant integer exponent has special handling. */
974 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
976 tree gfc_int4_type_node
;
979 int res_ikind_1
, res_ikind_2
;
984 gfc_init_se (&lse
, se
);
985 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
986 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
987 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
989 gfc_init_se (&rse
, se
);
990 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
991 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
993 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
994 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
995 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
998 gfc_int4_type_node
= gfc_get_int_type (4);
1000 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1001 library routine. But in the end, we have to convert the result back
1002 if this case applies -- with res_ikind_K, we keep track whether operand K
1003 falls into this case. */
1007 kind
= expr
->value
.op
.op1
->ts
.kind
;
1008 switch (expr
->value
.op
.op2
->ts
.type
)
1011 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1016 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1017 res_ikind_2
= ikind
;
1039 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
1041 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1068 switch (expr
->value
.op
.op1
->ts
.type
)
1071 if (kind
== 3) /* Case 16 was not handled properly above. */
1073 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1077 /* Use builtins for real ** int4. */
1083 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1087 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1091 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1095 /* Use the __builtin_powil() only if real(kind=16) is
1096 actually the C long double type. */
1097 if (!gfc_real16_is_float128
)
1098 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1106 /* If we don't have a good builtin for this, go for the
1107 library function. */
1109 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1113 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1122 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
1126 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
1134 se
->expr
= build_call_expr_loc (input_location
,
1135 fndecl
, 2, lse
.expr
, rse
.expr
);
1137 /* Convert the result back if it is of wrong integer kind. */
1138 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
1140 /* We want the maximum of both operand kinds as result. */
1141 if (res_ikind_1
< res_ikind_2
)
1142 res_ikind_1
= res_ikind_2
;
1143 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
1148 /* Generate code to allocate a string temporary. */
1151 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1156 if (gfc_can_put_var_on_stack (len
))
1158 /* Create a temporary variable to hold the result. */
1159 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1160 gfc_charlen_type_node
, len
,
1161 build_int_cst (gfc_charlen_type_node
, 1));
1162 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1164 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1165 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1167 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1169 var
= gfc_create_var (tmp
, "str");
1170 var
= gfc_build_addr_expr (type
, var
);
1174 /* Allocate a temporary to hold the result. */
1175 var
= gfc_create_var (type
, "pstr");
1176 tmp
= gfc_call_malloc (&se
->pre
, type
,
1177 fold_build2_loc (input_location
, MULT_EXPR
,
1178 TREE_TYPE (len
), len
,
1179 fold_convert (TREE_TYPE (len
),
1180 TYPE_SIZE (type
))));
1181 gfc_add_modify (&se
->pre
, var
, tmp
);
1183 /* Free the temporary afterwards. */
1184 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1185 gfc_add_expr_to_block (&se
->post
, tmp
);
1192 /* Handle a string concatenation operation. A temporary will be allocated to
1196 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1199 tree len
, type
, var
, tmp
, fndecl
;
1201 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1202 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1203 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1205 gfc_init_se (&lse
, se
);
1206 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1207 gfc_conv_string_parameter (&lse
);
1208 gfc_init_se (&rse
, se
);
1209 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1210 gfc_conv_string_parameter (&rse
);
1212 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1213 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1215 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1216 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1217 if (len
== NULL_TREE
)
1219 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
1220 TREE_TYPE (lse
.string_length
),
1221 lse
.string_length
, rse
.string_length
);
1224 type
= build_pointer_type (type
);
1226 var
= gfc_conv_string_tmp (se
, type
, len
);
1228 /* Do the actual concatenation. */
1229 if (expr
->ts
.kind
== 1)
1230 fndecl
= gfor_fndecl_concat_string
;
1231 else if (expr
->ts
.kind
== 4)
1232 fndecl
= gfor_fndecl_concat_string_char4
;
1236 tmp
= build_call_expr_loc (input_location
,
1237 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1238 rse
.string_length
, rse
.expr
);
1239 gfc_add_expr_to_block (&se
->pre
, tmp
);
1241 /* Add the cleanup for the operands. */
1242 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1243 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1246 se
->string_length
= len
;
1249 /* Translates an op expression. Common (binary) cases are handled by this
1250 function, others are passed on. Recursion is used in either case.
1251 We use the fact that (op1.ts == op2.ts) (except for the power
1253 Operators need no special handling for scalarized expressions as long as
1254 they call gfc_conv_simple_val to get their operands.
1255 Character strings get special handling. */
1258 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1260 enum tree_code code
;
1269 switch (expr
->value
.op
.op
)
1271 case INTRINSIC_PARENTHESES
:
1272 if ((expr
->ts
.type
== BT_REAL
1273 || expr
->ts
.type
== BT_COMPLEX
)
1274 && gfc_option
.flag_protect_parens
)
1276 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1277 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1282 case INTRINSIC_UPLUS
:
1283 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1286 case INTRINSIC_UMINUS
:
1287 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1291 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1294 case INTRINSIC_PLUS
:
1298 case INTRINSIC_MINUS
:
1302 case INTRINSIC_TIMES
:
1306 case INTRINSIC_DIVIDE
:
1307 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1308 an integer, we must round towards zero, so we use a
1310 if (expr
->ts
.type
== BT_INTEGER
)
1311 code
= TRUNC_DIV_EXPR
;
1316 case INTRINSIC_POWER
:
1317 gfc_conv_power_op (se
, expr
);
1320 case INTRINSIC_CONCAT
:
1321 gfc_conv_concat_op (se
, expr
);
1325 code
= TRUTH_ANDIF_EXPR
;
1330 code
= TRUTH_ORIF_EXPR
;
1334 /* EQV and NEQV only work on logicals, but since we represent them
1335 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1337 case INTRINSIC_EQ_OS
:
1345 case INTRINSIC_NE_OS
:
1346 case INTRINSIC_NEQV
:
1353 case INTRINSIC_GT_OS
:
1360 case INTRINSIC_GE_OS
:
1367 case INTRINSIC_LT_OS
:
1374 case INTRINSIC_LE_OS
:
1380 case INTRINSIC_USER
:
1381 case INTRINSIC_ASSIGN
:
1382 /* These should be converted into function calls by the frontend. */
1386 fatal_error ("Unknown intrinsic op");
1390 /* The only exception to this is **, which is handled separately anyway. */
1391 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1393 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1397 gfc_init_se (&lse
, se
);
1398 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1399 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1402 gfc_init_se (&rse
, se
);
1403 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1404 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1408 gfc_conv_string_parameter (&lse
);
1409 gfc_conv_string_parameter (&rse
);
1411 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1412 rse
.string_length
, rse
.expr
,
1413 expr
->value
.op
.op1
->ts
.kind
,
1415 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1416 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1419 type
= gfc_typenode_for_spec (&expr
->ts
);
1423 /* The result of logical ops is always boolean_type_node. */
1424 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
1425 lse
.expr
, rse
.expr
);
1426 se
->expr
= convert (type
, tmp
);
1429 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
1431 /* Add the post blocks. */
1432 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1433 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1436 /* If a string's length is one, we convert it to a single character. */
1439 gfc_string_to_single_character (tree len
, tree str
, int kind
)
1442 if (!INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
1443 || !POINTER_TYPE_P (TREE_TYPE (str
)))
1446 if (TREE_INT_CST_LOW (len
) == 1)
1448 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1449 return build_fold_indirect_ref_loc (input_location
, str
);
1453 && TREE_CODE (str
) == ADDR_EXPR
1454 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1455 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1456 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1457 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1458 && TREE_INT_CST_LOW (len
) > 1
1459 && TREE_INT_CST_LOW (len
)
1460 == (unsigned HOST_WIDE_INT
)
1461 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1463 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
1464 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
1465 if (TREE_CODE (ret
) == INTEGER_CST
)
1467 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1468 int i
, length
= TREE_STRING_LENGTH (string_cst
);
1469 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1471 for (i
= 1; i
< length
; i
++)
1484 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1487 if (sym
->backend_decl
)
1489 /* This becomes the nominal_type in
1490 function.c:assign_parm_find_data_types. */
1491 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1492 /* This becomes the passed_type in
1493 function.c:assign_parm_find_data_types. C promotes char to
1494 integer for argument passing. */
1495 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1497 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1502 /* If we have a constant character expression, make it into an
1504 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1509 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1510 (int)(*expr
)->value
.character
.string
[0]);
1511 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1513 /* The expr needs to be compatible with a C int. If the
1514 conversion fails, then the 2 causes an ICE. */
1515 ts
.type
= BT_INTEGER
;
1516 ts
.kind
= gfc_c_int_kind
;
1517 gfc_convert_type (*expr
, &ts
, 2);
1520 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1522 if ((*expr
)->ref
== NULL
)
1524 se
->expr
= gfc_string_to_single_character
1525 (build_int_cst (integer_type_node
, 1),
1526 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1528 ((*expr
)->symtree
->n
.sym
)),
1533 gfc_conv_variable (se
, *expr
);
1534 se
->expr
= gfc_string_to_single_character
1535 (build_int_cst (integer_type_node
, 1),
1536 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1544 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1545 if STR is a string literal, otherwise return -1. */
1548 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
1551 && TREE_CODE (str
) == ADDR_EXPR
1552 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1553 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1554 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1555 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1556 && TREE_INT_CST_LOW (len
) >= 1
1557 && TREE_INT_CST_LOW (len
)
1558 == (unsigned HOST_WIDE_INT
)
1559 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1561 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
1562 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
1563 if (TREE_CODE (folded
) == INTEGER_CST
)
1565 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1566 int length
= TREE_STRING_LENGTH (string_cst
);
1567 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1569 for (; length
> 0; length
--)
1570 if (ptr
[length
- 1] != ' ')
1579 /* Compare two strings. If they are all single characters, the result is the
1580 subtraction of them. Otherwise, we build a library call. */
1583 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
1584 enum tree_code code
)
1590 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1591 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1593 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
1594 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
1596 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1598 /* Deal with single character specially. */
1599 sc1
= fold_convert (integer_type_node
, sc1
);
1600 sc2
= fold_convert (integer_type_node
, sc2
);
1601 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
1605 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
1607 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
1609 /* If one string is a string literal with LEN_TRIM longer
1610 than the length of the second string, the strings
1612 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
1613 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
1614 return integer_one_node
;
1615 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
1616 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
1617 return integer_one_node
;
1620 /* Build a call for the comparison. */
1622 fndecl
= gfor_fndecl_compare_string
;
1624 fndecl
= gfor_fndecl_compare_string_char4
;
1628 return build_call_expr_loc (input_location
, fndecl
, 4,
1629 len1
, str1
, len2
, str2
);
1633 /* Return the backend_decl for a procedure pointer component. */
1636 get_proc_ptr_comp (gfc_expr
*e
)
1642 gfc_init_se (&comp_se
, NULL
);
1643 e2
= gfc_copy_expr (e
);
1644 /* We have to restore the expr type later so that gfc_free_expr frees
1645 the exact same thing that was allocated.
1646 TODO: This is ugly. */
1647 old_type
= e2
->expr_type
;
1648 e2
->expr_type
= EXPR_VARIABLE
;
1649 gfc_conv_expr (&comp_se
, e2
);
1650 e2
->expr_type
= old_type
;
1652 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1657 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1661 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1662 tmp
= get_proc_ptr_comp (expr
);
1663 else if (sym
->attr
.dummy
)
1665 tmp
= gfc_get_symbol_decl (sym
);
1666 if (sym
->attr
.proc_pointer
)
1667 tmp
= build_fold_indirect_ref_loc (input_location
,
1669 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1670 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1674 if (!sym
->backend_decl
)
1675 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1677 tmp
= sym
->backend_decl
;
1679 if (sym
->attr
.cray_pointee
)
1681 /* TODO - make the cray pointee a pointer to a procedure,
1682 assign the pointer to it and use it for the call. This
1684 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1685 gfc_get_symbol_decl (sym
->cp_pointer
));
1686 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1689 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1691 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1692 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1699 /* Initialize MAPPING. */
1702 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1704 mapping
->syms
= NULL
;
1705 mapping
->charlens
= NULL
;
1709 /* Free all memory held by MAPPING (but not MAPPING itself). */
1712 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1714 gfc_interface_sym_mapping
*sym
;
1715 gfc_interface_sym_mapping
*nextsym
;
1717 gfc_charlen
*nextcl
;
1719 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1721 nextsym
= sym
->next
;
1722 sym
->new_sym
->n
.sym
->formal
= NULL
;
1723 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1724 gfc_free_expr (sym
->expr
);
1725 gfc_free (sym
->new_sym
);
1728 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1731 gfc_free_expr (cl
->length
);
1737 /* Return a copy of gfc_charlen CL. Add the returned structure to
1738 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1740 static gfc_charlen
*
1741 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1744 gfc_charlen
*new_charlen
;
1746 new_charlen
= gfc_get_charlen ();
1747 new_charlen
->next
= mapping
->charlens
;
1748 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1750 mapping
->charlens
= new_charlen
;
1755 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1756 array variable that can be used as the actual argument for dummy
1757 argument SYM. Add any initialization code to BLOCK. PACKED is as
1758 for gfc_get_nodesc_array_type and DATA points to the first element
1759 in the passed array. */
1762 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1763 gfc_packed packed
, tree data
)
1768 type
= gfc_typenode_for_spec (&sym
->ts
);
1769 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
1770 !sym
->attr
.target
&& !sym
->attr
.pointer
1771 && !sym
->attr
.proc_pointer
);
1773 var
= gfc_create_var (type
, "ifm");
1774 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1780 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1781 and offset of descriptorless array type TYPE given that it has the same
1782 size as DESC. Add any set-up code to BLOCK. */
1785 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1792 offset
= gfc_index_zero_node
;
1793 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1795 dim
= gfc_rank_cst
[n
];
1796 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1797 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1799 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1800 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1801 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1802 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1804 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1806 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1807 gfc_array_index_type
,
1808 gfc_conv_descriptor_ubound_get (desc
, dim
),
1809 gfc_conv_descriptor_lbound_get (desc
, dim
));
1810 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1811 gfc_array_index_type
,
1812 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
1813 tmp
= gfc_evaluate_now (tmp
, block
);
1814 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1816 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1817 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1818 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1819 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1820 gfc_array_index_type
, offset
, tmp
);
1822 offset
= gfc_evaluate_now (offset
, block
);
1823 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1827 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1828 in SE. The caller may still use se->expr and se->string_length after
1829 calling this function. */
1832 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1833 gfc_symbol
* sym
, gfc_se
* se
,
1836 gfc_interface_sym_mapping
*sm
;
1840 gfc_symbol
*new_sym
;
1842 gfc_symtree
*new_symtree
;
1844 /* Create a new symbol to represent the actual argument. */
1845 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1846 new_sym
->ts
= sym
->ts
;
1847 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1848 new_sym
->attr
.referenced
= 1;
1849 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1850 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
1851 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
1852 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1853 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1854 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1855 new_sym
->attr
.function
= sym
->attr
.function
;
1857 /* Ensure that the interface is available and that
1858 descriptors are passed for array actual arguments. */
1859 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1861 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1862 new_sym
->attr
.always_explicit
1863 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1866 /* Create a fake symtree for it. */
1868 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1869 new_symtree
->n
.sym
= new_sym
;
1870 gcc_assert (new_symtree
== root
);
1872 /* Create a dummy->actual mapping. */
1873 sm
= XCNEW (gfc_interface_sym_mapping
);
1874 sm
->next
= mapping
->syms
;
1876 sm
->new_sym
= new_symtree
;
1877 sm
->expr
= gfc_copy_expr (expr
);
1880 /* Stabilize the argument's value. */
1881 if (!sym
->attr
.function
&& se
)
1882 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1884 if (sym
->ts
.type
== BT_CHARACTER
)
1886 /* Create a copy of the dummy argument's length. */
1887 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1888 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1890 /* If the length is specified as "*", record the length that
1891 the caller is passing. We should use the callee's length
1892 in all other cases. */
1893 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1895 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1896 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1903 /* Use the passed value as-is if the argument is a function. */
1904 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1907 /* If the argument is either a string or a pointer to a string,
1908 convert it to a boundless character type. */
1909 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1911 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1912 tmp
= build_pointer_type (tmp
);
1913 if (sym
->attr
.pointer
)
1914 value
= build_fold_indirect_ref_loc (input_location
,
1918 value
= fold_convert (tmp
, value
);
1921 /* If the argument is a scalar, a pointer to an array or an allocatable,
1923 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1924 value
= build_fold_indirect_ref_loc (input_location
,
1927 /* For character(*), use the actual argument's descriptor. */
1928 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1929 value
= build_fold_indirect_ref_loc (input_location
,
1932 /* If the argument is an array descriptor, use it to determine
1933 information about the actual argument's shape. */
1934 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1935 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1937 /* Get the actual argument's descriptor. */
1938 desc
= build_fold_indirect_ref_loc (input_location
,
1941 /* Create the replacement variable. */
1942 tmp
= gfc_conv_descriptor_data_get (desc
);
1943 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1946 /* Use DESC to work out the upper bounds, strides and offset. */
1947 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1950 /* Otherwise we have a packed array. */
1951 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1952 PACKED_FULL
, se
->expr
);
1954 new_sym
->backend_decl
= value
;
1958 /* Called once all dummy argument mappings have been added to MAPPING,
1959 but before the mapping is used to evaluate expressions. Pre-evaluate
1960 the length of each argument, adding any initialization code to PRE and
1961 any finalization code to POST. */
1964 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1965 stmtblock_t
* pre
, stmtblock_t
* post
)
1967 gfc_interface_sym_mapping
*sym
;
1971 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1972 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1973 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1975 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1976 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1977 gfc_init_se (&se
, NULL
);
1978 gfc_conv_expr (&se
, expr
);
1979 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1980 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1981 gfc_add_block_to_block (pre
, &se
.pre
);
1982 gfc_add_block_to_block (post
, &se
.post
);
1984 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1989 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1993 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1994 gfc_constructor_base base
)
1997 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1999 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
2002 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
2003 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
2004 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2010 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2014 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2019 for (; ref
; ref
= ref
->next
)
2023 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2025 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2026 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2027 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2029 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2036 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2037 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2043 /* Convert intrinsic function calls into result expressions. */
2046 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2054 arg1
= expr
->value
.function
.actual
->expr
;
2055 if (expr
->value
.function
.actual
->next
)
2056 arg2
= expr
->value
.function
.actual
->next
->expr
;
2060 sym
= arg1
->symtree
->n
.sym
;
2062 if (sym
->attr
.dummy
)
2067 switch (expr
->value
.function
.isym
->id
)
2070 /* TODO figure out why this condition is necessary. */
2071 if (sym
->attr
.function
2072 && (arg1
->ts
.u
.cl
->length
== NULL
2073 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2074 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2077 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2081 if (!sym
->as
|| sym
->as
->rank
== 0)
2084 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2086 dup
= mpz_get_si (arg2
->value
.integer
);
2091 dup
= sym
->as
->rank
;
2095 for (; d
< dup
; d
++)
2099 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2101 gfc_free_expr (new_expr
);
2105 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
2106 gfc_get_int_expr (gfc_default_integer_kind
,
2108 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2110 new_expr
= gfc_multiply (new_expr
, tmp
);
2116 case GFC_ISYM_LBOUND
:
2117 case GFC_ISYM_UBOUND
:
2118 /* TODO These implementations of lbound and ubound do not limit if
2119 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2121 if (!sym
->as
|| sym
->as
->rank
== 0)
2124 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2125 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2127 /* TODO: If the need arises, this could produce an array of
2131 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2133 if (sym
->as
->lower
[d
])
2134 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2138 if (sym
->as
->upper
[d
])
2139 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2147 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2151 gfc_replace_expr (expr
, new_expr
);
2157 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2158 gfc_interface_mapping
* mapping
)
2160 gfc_formal_arglist
*f
;
2161 gfc_actual_arglist
*actual
;
2163 actual
= expr
->value
.function
.actual
;
2164 f
= map_expr
->symtree
->n
.sym
->formal
;
2166 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2171 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2174 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2179 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2181 for (d
= 0; d
< as
->rank
; d
++)
2183 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2184 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2187 expr
->value
.function
.esym
->as
= as
;
2190 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2192 expr
->value
.function
.esym
->ts
.u
.cl
->length
2193 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2195 gfc_apply_interface_mapping_to_expr (mapping
,
2196 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2201 /* EXPR is a copy of an expression that appeared in the interface
2202 associated with MAPPING. Walk it recursively looking for references to
2203 dummy arguments that MAPPING maps to actual arguments. Replace each such
2204 reference with a reference to the associated actual argument. */
2207 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2210 gfc_interface_sym_mapping
*sym
;
2211 gfc_actual_arglist
*actual
;
2216 /* Copying an expression does not copy its length, so do that here. */
2217 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2219 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2220 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2223 /* Apply the mapping to any references. */
2224 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2226 /* ...and to the expression's symbol, if it has one. */
2227 /* TODO Find out why the condition on expr->symtree had to be moved into
2228 the loop rather than being outside it, as originally. */
2229 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2230 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2232 if (sym
->new_sym
->n
.sym
->backend_decl
)
2233 expr
->symtree
= sym
->new_sym
;
2235 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2238 /* ...and to subexpressions in expr->value. */
2239 switch (expr
->expr_type
)
2244 case EXPR_SUBSTRING
:
2248 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2249 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2253 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2254 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2256 if (expr
->value
.function
.esym
== NULL
2257 && expr
->value
.function
.isym
!= NULL
2258 && expr
->value
.function
.actual
->expr
->symtree
2259 && gfc_map_intrinsic_function (expr
, mapping
))
2262 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2263 if (sym
->old
== expr
->value
.function
.esym
)
2265 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2266 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2267 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2272 case EXPR_STRUCTURE
:
2273 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2286 /* Evaluate interface expression EXPR using MAPPING. Store the result
2290 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2291 gfc_se
* se
, gfc_expr
* expr
)
2293 expr
= gfc_copy_expr (expr
);
2294 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2295 gfc_conv_expr (se
, expr
);
2296 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2297 gfc_free_expr (expr
);
2301 /* Returns a reference to a temporary array into which a component of
2302 an actual argument derived type array is copied and then returned
2303 after the function call. */
2305 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2306 sym_intent intent
, bool formal_ptr
)
2324 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2326 gfc_init_se (&lse
, NULL
);
2327 gfc_init_se (&rse
, NULL
);
2329 /* Walk the argument expression. */
2330 rss
= gfc_walk_expr (expr
);
2332 gcc_assert (rss
!= gfc_ss_terminator
);
2334 /* Initialize the scalarizer. */
2335 gfc_init_loopinfo (&loop
);
2336 gfc_add_ss_to_loop (&loop
, rss
);
2338 /* Calculate the bounds of the scalarization. */
2339 gfc_conv_ss_startstride (&loop
);
2341 /* Build an ss for the temporary. */
2342 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2343 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2345 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2346 if (GFC_ARRAY_TYPE_P (base_type
)
2347 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2348 base_type
= gfc_get_element_type (base_type
);
2350 loop
.temp_ss
= gfc_get_ss ();;
2351 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2352 loop
.temp_ss
->data
.temp
.type
= base_type
;
2354 if (expr
->ts
.type
== BT_CHARACTER
)
2355 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2357 loop
.temp_ss
->string_length
= NULL
;
2359 parmse
->string_length
= loop
.temp_ss
->string_length
;
2360 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2361 loop
.temp_ss
->next
= gfc_ss_terminator
;
2363 /* Associate the SS with the loop. */
2364 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2366 /* Setup the scalarizing loops. */
2367 gfc_conv_loop_setup (&loop
, &expr
->where
);
2369 /* Pass the temporary descriptor back to the caller. */
2370 info
= &loop
.temp_ss
->data
.info
;
2371 parmse
->expr
= info
->descriptor
;
2373 /* Setup the gfc_se structures. */
2374 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2375 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2378 lse
.ss
= loop
.temp_ss
;
2379 gfc_mark_ss_chain_used (rss
, 1);
2380 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2382 /* Start the scalarized loop body. */
2383 gfc_start_scalarized_body (&loop
, &body
);
2385 /* Translate the expression. */
2386 gfc_conv_expr (&rse
, expr
);
2388 gfc_conv_tmp_array_ref (&lse
);
2390 if (intent
!= INTENT_OUT
)
2392 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
2393 gfc_add_expr_to_block (&body
, tmp
);
2394 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2395 gfc_trans_scalarizing_loops (&loop
, &body
);
2399 /* Make sure that the temporary declaration survives by merging
2400 all the loop declarations into the current context. */
2401 for (n
= 0; n
< loop
.dimen
; n
++)
2403 gfc_merge_block_scope (&body
);
2404 body
= loop
.code
[loop
.order
[n
]];
2406 gfc_merge_block_scope (&body
);
2409 /* Add the post block after the second loop, so that any
2410 freeing of allocated memory is done at the right time. */
2411 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2413 /**********Copy the temporary back again.*********/
2415 gfc_init_se (&lse
, NULL
);
2416 gfc_init_se (&rse
, NULL
);
2418 /* Walk the argument expression. */
2419 lss
= gfc_walk_expr (expr
);
2420 rse
.ss
= loop
.temp_ss
;
2423 /* Initialize the scalarizer. */
2424 gfc_init_loopinfo (&loop2
);
2425 gfc_add_ss_to_loop (&loop2
, lss
);
2427 /* Calculate the bounds of the scalarization. */
2428 gfc_conv_ss_startstride (&loop2
);
2430 /* Setup the scalarizing loops. */
2431 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2433 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2434 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2436 gfc_mark_ss_chain_used (lss
, 1);
2437 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2439 /* Declare the variable to hold the temporary offset and start the
2440 scalarized loop body. */
2441 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2442 gfc_start_scalarized_body (&loop2
, &body
);
2444 /* Build the offsets for the temporary from the loop variables. The
2445 temporary array has lbounds of zero and strides of one in all
2446 dimensions, so this is very simple. The offset is only computed
2447 outside the innermost loop, so the overall transfer could be
2448 optimized further. */
2449 info
= &rse
.ss
->data
.info
;
2450 dimen
= info
->dimen
;
2452 tmp_index
= gfc_index_zero_node
;
2453 for (n
= dimen
- 1; n
> 0; n
--)
2456 tmp
= rse
.loop
->loopvar
[n
];
2457 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2458 tmp
, rse
.loop
->from
[n
]);
2459 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2462 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
2463 gfc_array_index_type
,
2464 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2465 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
2466 gfc_array_index_type
,
2467 tmp_str
, gfc_index_one_node
);
2469 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
2470 gfc_array_index_type
, tmp
, tmp_str
);
2473 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2474 gfc_array_index_type
,
2475 tmp_index
, rse
.loop
->from
[0]);
2476 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2478 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2479 gfc_array_index_type
,
2480 rse
.loop
->loopvar
[0], offset
);
2482 /* Now use the offset for the reference. */
2483 tmp
= build_fold_indirect_ref_loc (input_location
,
2485 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2487 if (expr
->ts
.type
== BT_CHARACTER
)
2488 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2490 gfc_conv_expr (&lse
, expr
);
2492 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2494 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
2495 gfc_add_expr_to_block (&body
, tmp
);
2497 /* Generate the copying loops. */
2498 gfc_trans_scalarizing_loops (&loop2
, &body
);
2500 /* Wrap the whole thing up by adding the second loop to the post-block
2501 and following it by the post-block of the first loop. In this way,
2502 if the temporary needs freeing, it is done after use! */
2503 if (intent
!= INTENT_IN
)
2505 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2506 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2509 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2511 gfc_cleanup_loop (&loop
);
2512 gfc_cleanup_loop (&loop2
);
2514 /* Pass the string length to the argument expression. */
2515 if (expr
->ts
.type
== BT_CHARACTER
)
2516 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2518 /* Determine the offset for pointer formal arguments and set the
2522 size
= gfc_index_one_node
;
2523 offset
= gfc_index_zero_node
;
2524 for (n
= 0; n
< dimen
; n
++)
2526 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2528 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2529 gfc_array_index_type
, tmp
,
2530 gfc_index_one_node
);
2531 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2535 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2538 gfc_index_one_node
);
2539 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2540 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2541 gfc_array_index_type
,
2543 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2544 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2545 gfc_array_index_type
,
2546 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2547 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2548 gfc_array_index_type
,
2549 tmp
, gfc_index_one_node
);
2550 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2551 gfc_array_index_type
, size
, tmp
);
2554 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2558 /* We want either the address for the data or the address of the descriptor,
2559 depending on the mode of passing array arguments. */
2561 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2563 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2569 /* Generate the code for argument list functions. */
2572 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2574 /* Pass by value for g77 %VAL(arg), pass the address
2575 indirectly for %LOC, else by reference. Thus %REF
2576 is a "do-nothing" and %LOC is the same as an F95
2578 if (strncmp (name
, "%VAL", 4) == 0)
2579 gfc_conv_expr (se
, expr
);
2580 else if (strncmp (name
, "%LOC", 4) == 0)
2582 gfc_conv_expr_reference (se
, expr
);
2583 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2585 else if (strncmp (name
, "%REF", 4) == 0)
2586 gfc_conv_expr_reference (se
, expr
);
2588 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2592 /* Takes a derived type expression and returns the address of a temporary
2593 class object of the 'declared' type. */
2595 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
2596 gfc_typespec class_ts
)
2600 gfc_symbol
*declared
= class_ts
.u
.derived
;
2606 /* The derived type needs to be converted to a temporary
2608 tmp
= gfc_typenode_for_spec (&class_ts
);
2609 var
= gfc_create_var (tmp
, "class");
2612 cmp
= gfc_find_component (declared
, "_vptr", true, true);
2613 ctree
= fold_build3_loc (input_location
, COMPONENT_REF
,
2614 TREE_TYPE (cmp
->backend_decl
),
2615 var
, cmp
->backend_decl
, NULL_TREE
);
2617 /* Remember the vtab corresponds to the derived type
2618 not to the class declared type. */
2619 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
2621 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
2622 gfc_add_modify (&parmse
->pre
, ctree
,
2623 fold_convert (TREE_TYPE (ctree
), tmp
));
2625 /* Now set the data field. */
2626 cmp
= gfc_find_component (declared
, "_data", true, true);
2627 ctree
= fold_build3_loc (input_location
, COMPONENT_REF
,
2628 TREE_TYPE (cmp
->backend_decl
),
2629 var
, cmp
->backend_decl
, NULL_TREE
);
2630 ss
= gfc_walk_expr (e
);
2631 if (ss
== gfc_ss_terminator
)
2634 gfc_conv_expr_reference (parmse
, e
);
2635 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
2636 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
2641 gfc_conv_expr (parmse
, e
);
2642 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
2645 /* Pass the address of the class object. */
2646 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2650 /* The following routine generates code for the intrinsic
2651 procedures from the ISO_C_BINDING module:
2653 * C_FUNLOC (function)
2654 * C_F_POINTER (subroutine)
2655 * C_F_PROCPOINTER (subroutine)
2656 * C_ASSOCIATED (function)
2657 One exception which is not handled here is C_F_POINTER with non-scalar
2658 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2661 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2662 gfc_actual_arglist
* arg
)
2667 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2669 if (arg
->expr
->rank
== 0)
2670 gfc_conv_expr_reference (se
, arg
->expr
);
2674 /* This is really the actual arg because no formal arglist is
2675 created for C_LOC. */
2676 fsym
= arg
->expr
->symtree
->n
.sym
;
2678 /* We should want it to do g77 calling convention. */
2680 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2681 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2682 f
= f
|| !sym
->attr
.always_explicit
;
2684 argss
= gfc_walk_expr (arg
->expr
);
2685 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2689 /* TODO -- the following two lines shouldn't be necessary, but if
2690 they're removed, a bug is exposed later in the code path.
2691 This workaround was thus introduced, but will have to be
2692 removed; please see PR 35150 for details about the issue. */
2693 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2694 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2698 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2700 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2701 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2702 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2703 gfc_conv_expr_reference (se
, arg
->expr
);
2707 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2708 && arg
->next
->expr
->rank
== 0)
2709 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2711 /* Convert c_f_pointer if fptr is a scalar
2712 and convert c_f_procpointer. */
2716 gfc_init_se (&cptrse
, NULL
);
2717 gfc_conv_expr (&cptrse
, arg
->expr
);
2718 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2719 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2721 gfc_init_se (&fptrse
, NULL
);
2722 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2723 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2724 fptrse
.want_pointer
= 1;
2726 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2727 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2728 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2730 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2731 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2732 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2735 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2736 TREE_TYPE (fptrse
.expr
),
2738 fold_convert (TREE_TYPE (fptrse
.expr
),
2743 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2748 /* Build the addr_expr for the first argument. The argument is
2749 already an *address* so we don't need to set want_pointer in
2751 gfc_init_se (&arg1se
, NULL
);
2752 gfc_conv_expr (&arg1se
, arg
->expr
);
2753 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2754 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2756 /* See if we were given two arguments. */
2757 if (arg
->next
== NULL
)
2758 /* Only given one arg so generate a null and do a
2759 not-equal comparison against the first arg. */
2760 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2762 fold_convert (TREE_TYPE (arg1se
.expr
),
2763 null_pointer_node
));
2769 /* Given two arguments so build the arg2se from second arg. */
2770 gfc_init_se (&arg2se
, NULL
);
2771 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2772 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2773 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2775 /* Generate test to compare that the two args are equal. */
2776 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2777 arg1se
.expr
, arg2se
.expr
);
2778 /* Generate test to ensure that the first arg is not null. */
2779 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
2781 arg1se
.expr
, null_pointer_node
);
2783 /* Finally, the generated test must check that both arg1 is not
2784 NULL and that it is equal to the second arg. */
2785 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2787 not_null_expr
, eq_expr
);
2793 /* Nothing was done. */
2797 /* Generate code for a procedure call. Note can return se->post != NULL.
2798 If se->direct_byref is set then se->expr contains the return parameter.
2799 Return nonzero, if the call has alternate specifiers.
2800 'expr' is only needed for procedure pointer components. */
2803 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2804 gfc_actual_arglist
* args
, gfc_expr
* expr
,
2805 VEC(tree
,gc
) *append_args
)
2807 gfc_interface_mapping mapping
;
2808 VEC(tree
,gc
) *arglist
;
2809 VEC(tree
,gc
) *retargs
;
2820 VEC(tree
,gc
) *stringargs
;
2822 gfc_formal_arglist
*formal
;
2823 gfc_actual_arglist
*arg
;
2824 int has_alternate_specifier
= 0;
2825 bool need_interface_mapping
;
2832 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2833 gfc_component
*comp
= NULL
;
2843 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2844 && conv_isocbinding_procedure (se
, sym
, args
))
2847 gfc_is_proc_ptr_comp (expr
, &comp
);
2851 if (!sym
->attr
.elemental
)
2853 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2854 if (se
->ss
->useflags
)
2856 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2857 && sym
->result
->attr
.dimension
)
2858 || (comp
&& comp
->attr
.dimension
));
2859 gcc_assert (se
->loop
!= NULL
);
2861 /* Access the previously obtained result. */
2862 gfc_conv_tmp_array_ref (se
);
2866 info
= &se
->ss
->data
.info
;
2871 gfc_init_block (&post
);
2872 gfc_init_interface_mapping (&mapping
);
2875 formal
= sym
->formal
;
2876 need_interface_mapping
= sym
->attr
.dimension
||
2877 (sym
->ts
.type
== BT_CHARACTER
2878 && sym
->ts
.u
.cl
->length
2879 && sym
->ts
.u
.cl
->length
->expr_type
2884 formal
= comp
->formal
;
2885 need_interface_mapping
= comp
->attr
.dimension
||
2886 (comp
->ts
.type
== BT_CHARACTER
2887 && comp
->ts
.u
.cl
->length
2888 && comp
->ts
.u
.cl
->length
->expr_type
2892 /* Evaluate the arguments. */
2893 for (arg
= args
; arg
!= NULL
;
2894 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2897 fsym
= formal
? formal
->sym
: NULL
;
2898 parm_kind
= MISSING
;
2902 if (se
->ignore_optional
)
2904 /* Some intrinsics have already been resolved to the correct
2908 else if (arg
->label
)
2910 has_alternate_specifier
= 1;
2915 /* Pass a NULL pointer for an absent arg. */
2916 gfc_init_se (&parmse
, NULL
);
2917 parmse
.expr
= null_pointer_node
;
2918 if (arg
->missing_arg_type
== BT_CHARACTER
)
2919 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2922 else if (arg
->expr
->expr_type
== EXPR_NULL
&& fsym
&& !fsym
->attr
.pointer
)
2924 /* Pass a NULL pointer to denote an absent arg. */
2925 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
);
2926 gfc_init_se (&parmse
, NULL
);
2927 parmse
.expr
= null_pointer_node
;
2928 if (arg
->missing_arg_type
== BT_CHARACTER
)
2929 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2931 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2932 && e
->ts
.type
== BT_DERIVED
)
2934 /* The derived type needs to be converted to a temporary
2936 gfc_init_se (&parmse
, se
);
2937 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
2939 else if (se
->ss
&& se
->ss
->useflags
)
2941 /* An elemental function inside a scalarized loop. */
2942 gfc_init_se (&parmse
, se
);
2943 gfc_conv_expr_reference (&parmse
, e
);
2944 parm_kind
= ELEMENTAL
;
2948 /* A scalar or transformational function. */
2949 gfc_init_se (&parmse
, NULL
);
2950 argss
= gfc_walk_expr (e
);
2952 if (argss
== gfc_ss_terminator
)
2954 if (e
->expr_type
== EXPR_VARIABLE
2955 && e
->symtree
->n
.sym
->attr
.cray_pointee
2956 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2958 /* The Cray pointer needs to be converted to a pointer to
2959 a type given by the expression. */
2960 gfc_conv_expr (&parmse
, e
);
2961 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2962 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2963 parmse
.expr
= convert (type
, tmp
);
2965 else if (fsym
&& fsym
->attr
.value
)
2967 if (fsym
->ts
.type
== BT_CHARACTER
2968 && fsym
->ts
.is_c_interop
2969 && fsym
->ns
->proc_name
!= NULL
2970 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2973 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2974 if (parmse
.expr
== NULL
)
2975 gfc_conv_expr (&parmse
, e
);
2978 gfc_conv_expr (&parmse
, e
);
2980 else if (arg
->name
&& arg
->name
[0] == '%')
2981 /* Argument list functions %VAL, %LOC and %REF are signalled
2982 through arg->name. */
2983 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2984 else if ((e
->expr_type
== EXPR_FUNCTION
)
2985 && ((e
->value
.function
.esym
2986 && e
->value
.function
.esym
->result
->attr
.pointer
)
2987 || (!e
->value
.function
.esym
2988 && e
->symtree
->n
.sym
->attr
.pointer
))
2989 && fsym
&& fsym
->attr
.target
)
2991 gfc_conv_expr (&parmse
, e
);
2992 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2994 else if (e
->expr_type
== EXPR_FUNCTION
2995 && e
->symtree
->n
.sym
->result
2996 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2997 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2999 /* Functions returning procedure pointers. */
3000 gfc_conv_expr (&parmse
, e
);
3001 if (fsym
&& fsym
->attr
.proc_pointer
)
3002 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3006 gfc_conv_expr_reference (&parmse
, e
);
3008 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3009 allocated on entry, it must be deallocated. */
3010 if (fsym
&& fsym
->attr
.allocatable
3011 && fsym
->attr
.intent
== INTENT_OUT
)
3015 gfc_init_block (&block
);
3016 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
3018 gfc_add_expr_to_block (&block
, tmp
);
3019 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3020 void_type_node
, parmse
.expr
,
3022 gfc_add_expr_to_block (&block
, tmp
);
3024 if (fsym
->attr
.optional
3025 && e
->expr_type
== EXPR_VARIABLE
3026 && e
->symtree
->n
.sym
->attr
.optional
)
3028 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3030 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3031 gfc_finish_block (&block
),
3032 build_empty_stmt (input_location
));
3035 tmp
= gfc_finish_block (&block
);
3037 gfc_add_expr_to_block (&se
->pre
, tmp
);
3040 if (fsym
&& e
->expr_type
!= EXPR_NULL
3041 && ((fsym
->attr
.pointer
3042 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3043 || (fsym
->attr
.proc_pointer
3044 && !(e
->expr_type
== EXPR_VARIABLE
3045 && e
->symtree
->n
.sym
->attr
.dummy
))
3046 || (e
->expr_type
== EXPR_VARIABLE
3047 && gfc_is_proc_ptr_comp (e
, NULL
))
3048 || fsym
->attr
.allocatable
))
3050 /* Scalar pointer dummy args require an extra level of
3051 indirection. The null pointer already contains
3052 this level of indirection. */
3053 parm_kind
= SCALAR_POINTER
;
3054 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3060 /* If the procedure requires an explicit interface, the actual
3061 argument is passed according to the corresponding formal
3062 argument. If the corresponding formal argument is a POINTER,
3063 ALLOCATABLE or assumed shape, we do not use g77's calling
3064 convention, and pass the address of the array descriptor
3065 instead. Otherwise we use g77's calling convention. */
3068 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3069 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3071 f
= f
|| !comp
->attr
.always_explicit
;
3073 f
= f
|| !sym
->attr
.always_explicit
;
3075 /* If the argument is a function call that may not create
3076 a temporary for the result, we have to check that we
3077 can do it, i.e. that there is no alias between this
3078 argument and another one. */
3079 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
3084 intent
= fsym
->attr
.intent
;
3086 intent
= INTENT_UNKNOWN
;
3088 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
3090 parmse
.force_tmp
= 1;
3093 if (e
->expr_type
== EXPR_VARIABLE
3094 && is_subref_array (e
))
3095 /* The actual argument is a component reference to an
3096 array of derived types. In this case, the argument
3097 is converted to a temporary, which is passed and then
3098 written back after the procedure call. */
3099 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3100 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3101 fsym
&& fsym
->attr
.pointer
);
3103 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
3106 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3107 allocated on entry, it must be deallocated. */
3108 if (fsym
&& fsym
->attr
.allocatable
3109 && fsym
->attr
.intent
== INTENT_OUT
)
3111 tmp
= build_fold_indirect_ref_loc (input_location
,
3113 tmp
= gfc_trans_dealloc_allocated (tmp
);
3114 if (fsym
->attr
.optional
3115 && e
->expr_type
== EXPR_VARIABLE
3116 && e
->symtree
->n
.sym
->attr
.optional
)
3117 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3119 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3120 tmp
, build_empty_stmt (input_location
));
3121 gfc_add_expr_to_block (&se
->pre
, tmp
);
3126 /* The case with fsym->attr.optional is that of a user subroutine
3127 with an interface indicating an optional argument. When we call
3128 an intrinsic subroutine, however, fsym is NULL, but we might still
3129 have an optional argument, so we proceed to the substitution
3131 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3133 /* If an optional argument is itself an optional dummy argument,
3134 check its presence and substitute a null if absent. This is
3135 only needed when passing an array to an elemental procedure
3136 as then array elements are accessed - or no NULL pointer is
3137 allowed and a "1" or "0" should be passed if not present.
3138 When passing a non-array-descriptor full array to a
3139 non-array-descriptor dummy, no check is needed. For
3140 array-descriptor actual to array-descriptor dummy, see
3141 PR 41911 for why a check has to be inserted.
3142 fsym == NULL is checked as intrinsics required the descriptor
3143 but do not always set fsym. */
3144 if (e
->expr_type
== EXPR_VARIABLE
3145 && e
->symtree
->n
.sym
->attr
.optional
3146 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3147 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3151 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
3152 || fsym
->as
->type
== AS_DEFERRED
))))))
3153 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3154 e
->representation
.length
);
3159 /* Obtain the character length of an assumed character length
3160 length procedure from the typespec. */
3161 if (fsym
->ts
.type
== BT_CHARACTER
3162 && parmse
.string_length
== NULL_TREE
3163 && e
->ts
.type
== BT_PROCEDURE
3164 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3165 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3166 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3168 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3169 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3173 if (fsym
&& need_interface_mapping
&& e
)
3174 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3176 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3177 gfc_add_block_to_block (&post
, &parmse
.post
);
3179 /* Allocated allocatable components of derived types must be
3180 deallocated for non-variable scalars. Non-variable arrays are
3181 dealt with in trans-array.c(gfc_conv_array_parameter). */
3182 if (e
&& e
->ts
.type
== BT_DERIVED
3183 && e
->ts
.u
.derived
->attr
.alloc_comp
3184 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3185 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3188 tmp
= build_fold_indirect_ref_loc (input_location
,
3190 parm_rank
= e
->rank
;
3198 case (SCALAR_POINTER
):
3199 tmp
= build_fold_indirect_ref_loc (input_location
,
3204 if (e
->expr_type
== EXPR_OP
3205 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3206 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3209 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3210 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3211 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3214 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3216 gfc_add_expr_to_block (&se
->post
, tmp
);
3219 /* Add argument checking of passing an unallocated/NULL actual to
3220 a nonallocatable/nonpointer dummy. */
3222 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3224 symbol_attribute attr
;
3228 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
3229 attr
= gfc_expr_attr (e
);
3231 goto end_pointer_check
;
3235 /* If the actual argument is an optional pointer/allocatable and
3236 the formal argument takes an nonpointer optional value,
3237 it is invalid to pass a non-present argument on, even
3238 though there is no technical reason for this in gfortran.
3239 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3240 tree present
, null_ptr
, type
;
3242 if (attr
.allocatable
3243 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3244 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3245 "allocated or not present", e
->symtree
->n
.sym
->name
);
3246 else if (attr
.pointer
3247 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3248 asprintf (&msg
, "Pointer actual argument '%s' is not "
3249 "associated or not present",
3250 e
->symtree
->n
.sym
->name
);
3251 else if (attr
.proc_pointer
3252 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3253 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3254 "associated or not present",
3255 e
->symtree
->n
.sym
->name
);
3257 goto end_pointer_check
;
3259 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3260 type
= TREE_TYPE (present
);
3261 present
= fold_build2_loc (input_location
, EQ_EXPR
,
3262 boolean_type_node
, present
,
3264 null_pointer_node
));
3265 type
= TREE_TYPE (parmse
.expr
);
3266 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
3267 boolean_type_node
, parmse
.expr
,
3269 null_pointer_node
));
3270 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3271 boolean_type_node
, present
, null_ptr
);
3275 if (attr
.allocatable
3276 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3277 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3278 "allocated", e
->symtree
->n
.sym
->name
);
3279 else if (attr
.pointer
3280 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3281 asprintf (&msg
, "Pointer actual argument '%s' is not "
3282 "associated", e
->symtree
->n
.sym
->name
);
3283 else if (attr
.proc_pointer
3284 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3285 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3286 "associated", e
->symtree
->n
.sym
->name
);
3288 goto end_pointer_check
;
3291 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3292 boolean_type_node
, parmse
.expr
,
3293 fold_convert (TREE_TYPE (parmse
.expr
),
3294 null_pointer_node
));
3297 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3304 /* Character strings are passed as two parameters, a length and a
3305 pointer - except for Bind(c) which only passes the pointer. */
3306 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3307 VEC_safe_push (tree
, gc
, stringargs
, parmse
.string_length
);
3309 VEC_safe_push (tree
, gc
, arglist
, parmse
.expr
);
3311 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3318 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3319 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3320 else if (ts
.type
== BT_CHARACTER
)
3322 if (ts
.u
.cl
->length
== NULL
)
3324 /* Assumed character length results are not allowed by 5.1.1.5 of the
3325 standard and are trapped in resolve.c; except in the case of SPREAD
3326 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3327 we take the character length of the first argument for the result.
3328 For dummies, we have to look through the formal argument list for
3329 this function and use the character length found there.*/
3330 if (!sym
->attr
.dummy
)
3331 cl
.backend_decl
= VEC_index (tree
, stringargs
, 0);
3334 formal
= sym
->ns
->proc_name
->formal
;
3335 for (; formal
; formal
= formal
->next
)
3336 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3337 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3344 /* Calculate the length of the returned string. */
3345 gfc_init_se (&parmse
, NULL
);
3346 if (need_interface_mapping
)
3347 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3349 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3350 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3351 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3353 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3354 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3355 gfc_charlen_type_node
, tmp
,
3356 build_int_cst (gfc_charlen_type_node
, 0));
3357 cl
.backend_decl
= tmp
;
3360 /* Set up a charlen structure for it. */
3365 len
= cl
.backend_decl
;
3368 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3369 || (!comp
&& gfc_return_by_reference (sym
));
3372 if (se
->direct_byref
)
3374 /* Sometimes, too much indirection can be applied; e.g. for
3375 function_result = array_valued_recursive_function. */
3376 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3377 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3378 && GFC_DESCRIPTOR_TYPE_P
3379 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3380 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3383 /* If the lhs of an assignment x = f(..) is allocatable and
3384 f2003 is allowed, we must do the automatic reallocation.
3385 TODO - deal with instrinsics, without using a temporary. */
3386 if (gfc_option
.flag_realloc_lhs
3387 && se
->ss
&& se
->ss
->loop_chain
3388 && se
->ss
->loop_chain
->is_alloc_lhs
3389 && !expr
->value
.function
.isym
3390 && sym
->result
->as
!= NULL
)
3392 /* Evaluate the bounds of the result, if known. */
3393 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
3396 /* Perform the automatic reallocation. */
3397 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
3399 gfc_add_expr_to_block (&se
->pre
, tmp
);
3401 /* Pass the temporary as the first argument. */
3402 result
= info
->descriptor
;
3405 result
= build_fold_indirect_ref_loc (input_location
,
3407 VEC_safe_push (tree
, gc
, retargs
, se
->expr
);
3409 else if (comp
&& comp
->attr
.dimension
)
3411 gcc_assert (se
->loop
&& info
);
3413 /* Set the type of the array. */
3414 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3415 info
->dimen
= se
->loop
->dimen
;
3417 /* Evaluate the bounds of the result, if known. */
3418 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3420 /* If the lhs of an assignment x = f(..) is allocatable and
3421 f2003 is allowed, we must not generate the function call
3422 here but should just send back the results of the mapping.
3423 This is signalled by the function ss being flagged. */
3424 if (gfc_option
.flag_realloc_lhs
3425 && se
->ss
&& se
->ss
->is_alloc_lhs
)
3427 gfc_free_interface_mapping (&mapping
);
3428 return has_alternate_specifier
;
3431 /* Create a temporary to store the result. In case the function
3432 returns a pointer, the temporary will be a shallow copy and
3433 mustn't be deallocated. */
3434 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3435 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3436 NULL_TREE
, false, !comp
->attr
.pointer
,
3437 callee_alloc
, &se
->ss
->expr
->where
);
3439 /* Pass the temporary as the first argument. */
3440 result
= info
->descriptor
;
3441 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3442 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3444 else if (!comp
&& sym
->result
->attr
.dimension
)
3446 gcc_assert (se
->loop
&& info
);
3448 /* Set the type of the array. */
3449 tmp
= gfc_typenode_for_spec (&ts
);
3450 info
->dimen
= se
->loop
->dimen
;
3452 /* Evaluate the bounds of the result, if known. */
3453 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3455 /* If the lhs of an assignment x = f(..) is allocatable and
3456 f2003 is allowed, we must not generate the function call
3457 here but should just send back the results of the mapping.
3458 This is signalled by the function ss being flagged. */
3459 if (gfc_option
.flag_realloc_lhs
3460 && se
->ss
&& se
->ss
->is_alloc_lhs
)
3462 gfc_free_interface_mapping (&mapping
);
3463 return has_alternate_specifier
;
3466 /* Create a temporary to store the result. In case the function
3467 returns a pointer, the temporary will be a shallow copy and
3468 mustn't be deallocated. */
3469 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3470 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3471 NULL_TREE
, false, !sym
->attr
.pointer
,
3472 callee_alloc
, &se
->ss
->expr
->where
);
3474 /* Pass the temporary as the first argument. */
3475 result
= info
->descriptor
;
3476 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3477 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3479 else if (ts
.type
== BT_CHARACTER
)
3481 /* Pass the string length. */
3482 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3483 type
= build_pointer_type (type
);
3485 /* Return an address to a char[0:len-1]* temporary for
3486 character pointers. */
3487 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3488 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3490 var
= gfc_create_var (type
, "pstr");
3492 if ((!comp
&& sym
->attr
.allocatable
)
3493 || (comp
&& comp
->attr
.allocatable
))
3494 gfc_add_modify (&se
->pre
, var
,
3495 fold_convert (TREE_TYPE (var
),
3496 null_pointer_node
));
3498 /* Provide an address expression for the function arguments. */
3499 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3502 var
= gfc_conv_string_tmp (se
, type
, len
);
3504 VEC_safe_push (tree
, gc
, retargs
, var
);
3508 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3510 type
= gfc_get_complex_type (ts
.kind
);
3511 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3512 VEC_safe_push (tree
, gc
, retargs
, var
);
3515 /* Add the string length to the argument list. */
3516 if (ts
.type
== BT_CHARACTER
)
3517 VEC_safe_push (tree
, gc
, retargs
, len
);
3519 gfc_free_interface_mapping (&mapping
);
3521 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3522 arglen
= (VEC_length (tree
, arglist
)
3523 + VEC_length (tree
, stringargs
) + VEC_length (tree
, append_args
));
3524 VEC_reserve_exact (tree
, gc
, retargs
, arglen
);
3526 /* Add the return arguments. */
3527 VEC_splice (tree
, retargs
, arglist
);
3529 /* Add the hidden string length parameters to the arguments. */
3530 VEC_splice (tree
, retargs
, stringargs
);
3532 /* We may want to append extra arguments here. This is used e.g. for
3533 calls to libgfortran_matmul_??, which need extra information. */
3534 if (!VEC_empty (tree
, append_args
))
3535 VEC_splice (tree
, retargs
, append_args
);
3538 /* Generate the actual call. */
3539 conv_function_val (se
, sym
, expr
);
3541 /* If there are alternate return labels, function type should be
3542 integer. Can't modify the type in place though, since it can be shared
3543 with other functions. For dummy arguments, the typing is done to
3544 to this result, even if it has to be repeated for each call. */
3545 if (has_alternate_specifier
3546 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3548 if (!sym
->attr
.dummy
)
3550 TREE_TYPE (sym
->backend_decl
)
3551 = build_function_type (integer_type_node
,
3552 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3553 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3556 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3559 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3560 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
3562 /* If we have a pointer function, but we don't want a pointer, e.g.
3565 where f is pointer valued, we have to dereference the result. */
3566 if (!se
->want_pointer
&& !byref
3567 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3568 && !gfc_is_proc_ptr_comp (expr
, NULL
))
3569 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3572 /* f2c calling conventions require a scalar default real function to
3573 return a double precision result. Convert this back to default
3574 real. We only care about the cases that can happen in Fortran 77.
3576 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3577 && sym
->ts
.kind
== gfc_default_real_kind
3578 && !sym
->attr
.always_explicit
)
3579 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3581 /* A pure function may still have side-effects - it may modify its
3583 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3585 if (!sym
->attr
.pure
)
3586 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3591 /* Add the function call to the pre chain. There is no expression. */
3592 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3593 se
->expr
= NULL_TREE
;
3595 if (!se
->direct_byref
)
3597 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
3599 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3601 /* Check the data pointer hasn't been modified. This would
3602 happen in a function returning a pointer. */
3603 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3604 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
3607 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3610 se
->expr
= info
->descriptor
;
3611 /* Bundle in the string length. */
3612 se
->string_length
= len
;
3614 else if (ts
.type
== BT_CHARACTER
)
3616 /* Dereference for character pointer results. */
3617 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3618 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3619 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3623 se
->string_length
= len
;
3627 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3628 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3633 /* Follow the function call with the argument post block. */
3636 gfc_add_block_to_block (&se
->pre
, &post
);
3638 /* Transformational functions of derived types with allocatable
3639 components must have the result allocatable components copied. */
3640 arg
= expr
->value
.function
.actual
;
3641 if (result
&& arg
&& expr
->rank
3642 && expr
->value
.function
.isym
3643 && expr
->value
.function
.isym
->transformational
3644 && arg
->expr
->ts
.type
== BT_DERIVED
3645 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
3648 /* Copy the allocatable components. We have to use a
3649 temporary here to prevent source allocatable components
3650 from being corrupted. */
3651 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
3652 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
3653 result
, tmp2
, expr
->rank
);
3654 gfc_add_expr_to_block (&se
->pre
, tmp
);
3655 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
3657 gfc_add_expr_to_block (&se
->pre
, tmp
);
3659 /* Finally free the temporary's data field. */
3660 tmp
= gfc_conv_descriptor_data_get (tmp2
);
3661 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
3662 gfc_add_expr_to_block (&se
->pre
, tmp
);
3666 gfc_add_block_to_block (&se
->post
, &post
);
3668 return has_alternate_specifier
;
3672 /* Fill a character string with spaces. */
3675 fill_with_spaces (tree start
, tree type
, tree size
)
3677 stmtblock_t block
, loop
;
3678 tree i
, el
, exit_label
, cond
, tmp
;
3680 /* For a simple char type, we can call memset(). */
3681 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3682 return build_call_expr_loc (input_location
,
3683 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3684 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3685 lang_hooks
.to_target_charset (' ')),
3688 /* Otherwise, we use a loop:
3689 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3693 /* Initialize variables. */
3694 gfc_init_block (&block
);
3695 i
= gfc_create_var (sizetype
, "i");
3696 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3697 el
= gfc_create_var (build_pointer_type (type
), "el");
3698 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3699 exit_label
= gfc_build_label_decl (NULL_TREE
);
3700 TREE_USED (exit_label
) = 1;
3704 gfc_init_block (&loop
);
3706 /* Exit condition. */
3707 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
3708 build_zero_cst (sizetype
));
3709 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3710 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
3711 build_empty_stmt (input_location
));
3712 gfc_add_expr_to_block (&loop
, tmp
);
3715 gfc_add_modify (&loop
,
3716 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
3717 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
3719 /* Increment loop variables. */
3720 gfc_add_modify (&loop
, i
,
3721 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
3722 TYPE_SIZE_UNIT (type
)));
3723 gfc_add_modify (&loop
, el
,
3724 fold_build2_loc (input_location
, POINTER_PLUS_EXPR
,
3725 TREE_TYPE (el
), el
, TYPE_SIZE_UNIT (type
)));
3727 /* Making the loop... actually loop! */
3728 tmp
= gfc_finish_block (&loop
);
3729 tmp
= build1_v (LOOP_EXPR
, tmp
);
3730 gfc_add_expr_to_block (&block
, tmp
);
3732 /* The exit label. */
3733 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3734 gfc_add_expr_to_block (&block
, tmp
);
3737 return gfc_finish_block (&block
);
3741 /* Generate code to copy a string. */
3744 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3745 int dkind
, tree slength
, tree src
, int skind
)
3747 tree tmp
, dlen
, slen
;
3756 stmtblock_t tempblock
;
3758 gcc_assert (dkind
== skind
);
3760 if (slength
!= NULL_TREE
)
3762 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3763 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
3767 slen
= build_int_cst (size_type_node
, 1);
3771 if (dlength
!= NULL_TREE
)
3773 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3774 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
3778 dlen
= build_int_cst (size_type_node
, 1);
3782 /* Assign directly if the types are compatible. */
3783 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3784 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3786 gfc_add_modify (block
, dsc
, ssc
);
3790 /* Do nothing if the destination length is zero. */
3791 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
3792 build_int_cst (size_type_node
, 0));
3794 /* The following code was previously in _gfortran_copy_string:
3796 // The two strings may overlap so we use memmove.
3798 copy_string (GFC_INTEGER_4 destlen, char * dest,
3799 GFC_INTEGER_4 srclen, const char * src)
3801 if (srclen >= destlen)
3803 // This will truncate if too long.
3804 memmove (dest, src, destlen);
3808 memmove (dest, src, srclen);
3810 memset (&dest[srclen], ' ', destlen - srclen);
3814 We're now doing it here for better optimization, but the logic
3817 /* For non-default character kinds, we have to multiply the string
3818 length by the base type size. */
3819 chartype
= gfc_get_char_type (dkind
);
3820 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3821 fold_convert (size_type_node
, slen
),
3822 fold_convert (size_type_node
,
3823 TYPE_SIZE_UNIT (chartype
)));
3824 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3825 fold_convert (size_type_node
, dlen
),
3826 fold_convert (size_type_node
,
3827 TYPE_SIZE_UNIT (chartype
)));
3829 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3830 dest
= fold_convert (pvoid_type_node
, dest
);
3832 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3834 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3835 src
= fold_convert (pvoid_type_node
, src
);
3837 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3839 /* Truncate string if source is too long. */
3840 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
3842 tmp2
= build_call_expr_loc (input_location
,
3843 built_in_decls
[BUILT_IN_MEMMOVE
],
3844 3, dest
, src
, dlen
);
3846 /* Else copy and pad with spaces. */
3847 tmp3
= build_call_expr_loc (input_location
,
3848 built_in_decls
[BUILT_IN_MEMMOVE
],
3849 3, dest
, src
, slen
);
3851 tmp4
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
, TREE_TYPE (dest
),
3852 dest
, fold_convert (sizetype
, slen
));
3853 tmp4
= fill_with_spaces (tmp4
, chartype
,
3854 fold_build2_loc (input_location
, MINUS_EXPR
,
3855 TREE_TYPE(dlen
), dlen
, slen
));
3857 gfc_init_block (&tempblock
);
3858 gfc_add_expr_to_block (&tempblock
, tmp3
);
3859 gfc_add_expr_to_block (&tempblock
, tmp4
);
3860 tmp3
= gfc_finish_block (&tempblock
);
3862 /* The whole copy_string function is there. */
3863 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
3865 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
3866 build_empty_stmt (input_location
));
3867 gfc_add_expr_to_block (block
, tmp
);
3871 /* Translate a statement function.
3872 The value of a statement function reference is obtained by evaluating the
3873 expression using the values of the actual arguments for the values of the
3874 corresponding dummy arguments. */
3877 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3881 gfc_formal_arglist
*fargs
;
3882 gfc_actual_arglist
*args
;
3885 gfc_saved_var
*saved_vars
;
3891 sym
= expr
->symtree
->n
.sym
;
3892 args
= expr
->value
.function
.actual
;
3893 gfc_init_se (&lse
, NULL
);
3894 gfc_init_se (&rse
, NULL
);
3897 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3899 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3900 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3902 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3904 /* Each dummy shall be specified, explicitly or implicitly, to be
3906 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3909 if (fsym
->ts
.type
== BT_CHARACTER
)
3911 /* Copy string arguments. */
3914 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3915 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3917 /* Create a temporary to hold the value. */
3918 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
3919 fsym
->ts
.u
.cl
->backend_decl
3920 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
3922 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
3923 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3925 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3927 gfc_conv_expr (&rse
, args
->expr
);
3928 gfc_conv_string_parameter (&rse
);
3929 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3930 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3932 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
3933 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3934 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3935 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3939 /* For everything else, just evaluate the expression. */
3941 /* Create a temporary to hold the value. */
3942 type
= gfc_typenode_for_spec (&fsym
->ts
);
3943 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3945 gfc_conv_expr (&lse
, args
->expr
);
3947 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3948 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3949 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3955 /* Use the temporary variables in place of the real ones. */
3956 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3957 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3959 gfc_conv_expr (se
, sym
->value
);
3961 if (sym
->ts
.type
== BT_CHARACTER
)
3963 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3965 /* Force the expression to the correct length. */
3966 if (!INTEGER_CST_P (se
->string_length
)
3967 || tree_int_cst_lt (se
->string_length
,
3968 sym
->ts
.u
.cl
->backend_decl
))
3970 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
3971 tmp
= gfc_create_var (type
, sym
->name
);
3972 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3973 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
3974 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3978 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3981 /* Restore the original variables. */
3982 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3983 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3984 gfc_free (saved_vars
);
3988 /* Translate a function expression. */
3991 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3995 if (expr
->value
.function
.isym
)
3997 gfc_conv_intrinsic_function (se
, expr
);
4001 /* We distinguish statement functions from general functions to improve
4002 runtime performance. */
4003 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
4005 gfc_conv_statement_function (se
, expr
);
4009 /* expr.value.function.esym is the resolved (specific) function symbol for
4010 most functions. However this isn't set for dummy procedures. */
4011 sym
= expr
->value
.function
.esym
;
4013 sym
= expr
->symtree
->n
.sym
;
4015 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
, NULL
);
4019 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4022 is_zero_initializer_p (gfc_expr
* expr
)
4024 if (expr
->expr_type
!= EXPR_CONSTANT
)
4027 /* We ignore constants with prescribed memory representations for now. */
4028 if (expr
->representation
.string
)
4031 switch (expr
->ts
.type
)
4034 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4037 return mpfr_zero_p (expr
->value
.real
)
4038 && MPFR_SIGN (expr
->value
.real
) >= 0;
4041 return expr
->value
.logical
== 0;
4044 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
4045 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
4046 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
4047 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
4057 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
4059 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
4060 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
4062 gfc_conv_tmp_array_ref (se
);
4066 /* Build a static initializer. EXPR is the expression for the initial value.
4067 The other parameters describe the variable of the component being
4068 initialized. EXPR may be null. */
4071 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
4072 bool array
, bool pointer
, bool procptr
)
4076 if (!(expr
|| pointer
|| procptr
))
4079 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4080 (these are the only two iso_c_binding derived types that can be
4081 used as initialization expressions). If so, we need to modify
4082 the 'expr' to be that for a (void *). */
4083 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
4084 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
4086 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
4088 /* The derived symbol has already been converted to a (void *). Use
4090 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
4091 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
4093 gfc_init_se (&se
, NULL
);
4094 gfc_conv_constant (&se
, expr
);
4095 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4099 if (array
&& !procptr
)
4102 /* Arrays need special handling. */
4104 ctor
= gfc_build_null_descriptor (type
);
4105 /* Special case assigning an array to zero. */
4106 else if (is_zero_initializer_p (expr
))
4107 ctor
= build_constructor (type
, NULL
);
4109 ctor
= gfc_conv_array_initializer (type
, expr
);
4110 TREE_STATIC (ctor
) = 1;
4113 else if (pointer
|| procptr
)
4115 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
4116 return fold_convert (type
, null_pointer_node
);
4119 gfc_init_se (&se
, NULL
);
4120 se
.want_pointer
= 1;
4121 gfc_conv_expr (&se
, expr
);
4122 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4132 gfc_init_se (&se
, NULL
);
4133 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4134 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
4136 gfc_conv_structure (&se
, expr
, 1);
4137 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
4138 TREE_STATIC (se
.expr
) = 1;
4143 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
4144 TREE_STATIC (ctor
) = 1;
4149 gfc_init_se (&se
, NULL
);
4150 gfc_conv_constant (&se
, expr
);
4151 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4158 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4170 gfc_start_block (&block
);
4172 /* Initialize the scalarizer. */
4173 gfc_init_loopinfo (&loop
);
4175 gfc_init_se (&lse
, NULL
);
4176 gfc_init_se (&rse
, NULL
);
4179 rss
= gfc_walk_expr (expr
);
4180 if (rss
== gfc_ss_terminator
)
4182 /* The rhs is scalar. Add a ss for the expression. */
4183 rss
= gfc_get_ss ();
4184 rss
->next
= gfc_ss_terminator
;
4185 rss
->type
= GFC_SS_SCALAR
;
4189 /* Create a SS for the destination. */
4190 lss
= gfc_get_ss ();
4191 lss
->type
= GFC_SS_COMPONENT
;
4193 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
4194 lss
->next
= gfc_ss_terminator
;
4195 lss
->data
.info
.dimen
= cm
->as
->rank
;
4196 lss
->data
.info
.descriptor
= dest
;
4197 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
4198 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
4199 for (n
= 0; n
< cm
->as
->rank
; n
++)
4201 lss
->data
.info
.dim
[n
] = n
;
4202 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
4203 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
4205 mpz_init (lss
->shape
[n
]);
4206 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
4207 cm
->as
->lower
[n
]->value
.integer
);
4208 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
4211 /* Associate the SS with the loop. */
4212 gfc_add_ss_to_loop (&loop
, lss
);
4213 gfc_add_ss_to_loop (&loop
, rss
);
4215 /* Calculate the bounds of the scalarization. */
4216 gfc_conv_ss_startstride (&loop
);
4218 /* Setup the scalarizing loops. */
4219 gfc_conv_loop_setup (&loop
, &expr
->where
);
4221 /* Setup the gfc_se structures. */
4222 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4223 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4226 gfc_mark_ss_chain_used (rss
, 1);
4228 gfc_mark_ss_chain_used (lss
, 1);
4230 /* Start the scalarized loop body. */
4231 gfc_start_scalarized_body (&loop
, &body
);
4233 gfc_conv_tmp_array_ref (&lse
);
4234 if (cm
->ts
.type
== BT_CHARACTER
)
4235 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4237 gfc_conv_expr (&rse
, expr
);
4239 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
4240 gfc_add_expr_to_block (&body
, tmp
);
4242 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4244 /* Generate the copying loops. */
4245 gfc_trans_scalarizing_loops (&loop
, &body
);
4247 /* Wrap the whole thing up. */
4248 gfc_add_block_to_block (&block
, &loop
.pre
);
4249 gfc_add_block_to_block (&block
, &loop
.post
);
4251 for (n
= 0; n
< cm
->as
->rank
; n
++)
4252 mpz_clear (lss
->shape
[n
]);
4253 gfc_free (lss
->shape
);
4255 gfc_cleanup_loop (&loop
);
4257 return gfc_finish_block (&block
);
4262 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4273 gfc_expr
*arg
= NULL
;
4275 gfc_start_block (&block
);
4276 gfc_init_se (&se
, NULL
);
4278 /* Get the descriptor for the expressions. */
4279 rss
= gfc_walk_expr (expr
);
4280 se
.want_pointer
= 0;
4281 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4282 gfc_add_block_to_block (&block
, &se
.pre
);
4283 gfc_add_modify (&block
, dest
, se
.expr
);
4285 /* Deal with arrays of derived types with allocatable components. */
4286 if (cm
->ts
.type
== BT_DERIVED
4287 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4288 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4292 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4293 TREE_TYPE(cm
->backend_decl
),
4296 gfc_add_expr_to_block (&block
, tmp
);
4297 gfc_add_block_to_block (&block
, &se
.post
);
4299 if (expr
->expr_type
!= EXPR_VARIABLE
)
4300 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4303 /* We need to know if the argument of a conversion function is a
4304 variable, so that the correct lower bound can be used. */
4305 if (expr
->expr_type
== EXPR_FUNCTION
4306 && expr
->value
.function
.isym
4307 && expr
->value
.function
.isym
->conversion
4308 && expr
->value
.function
.actual
->expr
4309 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4310 arg
= expr
->value
.function
.actual
->expr
;
4312 /* Obtain the array spec of full array references. */
4314 as
= gfc_get_full_arrayspec_from_expr (arg
);
4316 as
= gfc_get_full_arrayspec_from_expr (expr
);
4318 /* Shift the lbound and ubound of temporaries to being unity,
4319 rather than zero, based. Always calculate the offset. */
4320 offset
= gfc_conv_descriptor_offset_get (dest
);
4321 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4322 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4324 for (n
= 0; n
< expr
->rank
; n
++)
4329 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4330 TODO It looks as if gfc_conv_expr_descriptor should return
4331 the correct bounds and that the following should not be
4332 necessary. This would simplify gfc_conv_intrinsic_bound
4334 if (as
&& as
->lower
[n
])
4337 gfc_init_se (&lbse
, NULL
);
4338 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4339 gfc_add_block_to_block (&block
, &lbse
.pre
);
4340 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4344 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4345 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4349 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4352 lbound
= gfc_index_one_node
;
4354 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4356 /* Shift the bounds and set the offset accordingly. */
4357 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4358 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4359 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4360 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4362 gfc_conv_descriptor_ubound_set (&block
, dest
,
4363 gfc_rank_cst
[n
], tmp
);
4364 gfc_conv_descriptor_lbound_set (&block
, dest
,
4365 gfc_rank_cst
[n
], lbound
);
4367 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4368 gfc_conv_descriptor_lbound_get (dest
,
4370 gfc_conv_descriptor_stride_get (dest
,
4372 gfc_add_modify (&block
, tmp2
, tmp
);
4373 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4375 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4380 /* If a conversion expression has a null data pointer
4381 argument, nullify the allocatable component. */
4385 if (arg
->symtree
->n
.sym
->attr
.allocatable
4386 || arg
->symtree
->n
.sym
->attr
.pointer
)
4388 non_null_expr
= gfc_finish_block (&block
);
4389 gfc_start_block (&block
);
4390 gfc_conv_descriptor_data_set (&block
, dest
,
4392 null_expr
= gfc_finish_block (&block
);
4393 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4394 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
4395 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
4396 return build3_v (COND_EXPR
, tmp
,
4397 null_expr
, non_null_expr
);
4401 return gfc_finish_block (&block
);
4405 /* Assign a single component of a derived type constructor. */
4408 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4416 gfc_start_block (&block
);
4418 if (cm
->attr
.pointer
)
4420 gfc_init_se (&se
, NULL
);
4421 /* Pointer component. */
4422 if (cm
->attr
.dimension
)
4424 /* Array pointer. */
4425 if (expr
->expr_type
== EXPR_NULL
)
4426 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4429 rss
= gfc_walk_expr (expr
);
4430 se
.direct_byref
= 1;
4432 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4433 gfc_add_block_to_block (&block
, &se
.pre
);
4434 gfc_add_block_to_block (&block
, &se
.post
);
4439 /* Scalar pointers. */
4440 se
.want_pointer
= 1;
4441 gfc_conv_expr (&se
, expr
);
4442 gfc_add_block_to_block (&block
, &se
.pre
);
4443 gfc_add_modify (&block
, dest
,
4444 fold_convert (TREE_TYPE (dest
), se
.expr
));
4445 gfc_add_block_to_block (&block
, &se
.post
);
4448 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4450 /* NULL initialization for CLASS components. */
4451 tmp
= gfc_trans_structure_assign (dest
,
4452 gfc_class_null_initializer (&cm
->ts
));
4453 gfc_add_expr_to_block (&block
, tmp
);
4455 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
4457 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4458 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4459 else if (cm
->attr
.allocatable
)
4461 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4462 gfc_add_expr_to_block (&block
, tmp
);
4466 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4467 gfc_add_expr_to_block (&block
, tmp
);
4470 else if (expr
->ts
.type
== BT_DERIVED
)
4472 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4474 gfc_init_se (&se
, NULL
);
4475 gfc_conv_expr (&se
, expr
);
4476 gfc_add_block_to_block (&block
, &se
.pre
);
4477 gfc_add_modify (&block
, dest
,
4478 fold_convert (TREE_TYPE (dest
), se
.expr
));
4479 gfc_add_block_to_block (&block
, &se
.post
);
4483 /* Nested constructors. */
4484 tmp
= gfc_trans_structure_assign (dest
, expr
);
4485 gfc_add_expr_to_block (&block
, tmp
);
4490 /* Scalar component. */
4491 gfc_init_se (&se
, NULL
);
4492 gfc_init_se (&lse
, NULL
);
4494 gfc_conv_expr (&se
, expr
);
4495 if (cm
->ts
.type
== BT_CHARACTER
)
4496 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4498 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
4499 gfc_add_expr_to_block (&block
, tmp
);
4501 return gfc_finish_block (&block
);
4504 /* Assign a derived type constructor to a variable. */
4507 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4515 gfc_start_block (&block
);
4516 cm
= expr
->ts
.u
.derived
->components
;
4518 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
4519 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
4520 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
4524 gcc_assert (cm
->backend_decl
== NULL
);
4525 gfc_init_se (&se
, NULL
);
4526 gfc_init_se (&lse
, NULL
);
4527 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
4529 gfc_add_modify (&block
, lse
.expr
,
4530 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
4532 return gfc_finish_block (&block
);
4535 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4536 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4538 /* Skip absent members in default initializers. */
4542 field
= cm
->backend_decl
;
4543 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
4544 dest
, field
, NULL_TREE
);
4545 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4546 gfc_add_expr_to_block (&block
, tmp
);
4548 return gfc_finish_block (&block
);
4551 /* Build an expression for a constructor. If init is nonzero then
4552 this is part of a static variable initializer. */
4555 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4562 VEC(constructor_elt
,gc
) *v
= NULL
;
4564 gcc_assert (se
->ss
== NULL
);
4565 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4566 type
= gfc_typenode_for_spec (&expr
->ts
);
4570 /* Create a temporary variable and fill it in. */
4571 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4572 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4573 gfc_add_expr_to_block (&se
->pre
, tmp
);
4577 cm
= expr
->ts
.u
.derived
->components
;
4579 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4580 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4582 /* Skip absent members in default initializers and allocatable
4583 components. Although the latter have a default initializer
4584 of EXPR_NULL,... by default, the static nullify is not needed
4585 since this is done every time we come into scope. */
4586 if (!c
->expr
|| cm
->attr
.allocatable
)
4589 if (strcmp (cm
->name
, "_size") == 0)
4591 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4592 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4594 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4595 && strcmp (cm
->name
, "_extends") == 0)
4599 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4600 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4601 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
4605 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4606 TREE_TYPE (cm
->backend_decl
),
4607 cm
->attr
.dimension
, cm
->attr
.pointer
,
4608 cm
->attr
.proc_pointer
);
4610 /* Append it to the constructor list. */
4611 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4614 se
->expr
= build_constructor (type
, v
);
4616 TREE_CONSTANT (se
->expr
) = 1;
4620 /* Translate a substring expression. */
4623 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4629 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4631 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4632 expr
->value
.character
.length
,
4633 expr
->value
.character
.string
);
4635 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4636 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4639 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4643 /* Entry point for expression translation. Evaluates a scalar quantity.
4644 EXPR is the expression to be translated, and SE is the state structure if
4645 called from within the scalarized. */
4648 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4650 if (se
->ss
&& se
->ss
->expr
== expr
4651 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4653 /* Substitute a scalar expression evaluated outside the scalarization
4655 se
->expr
= se
->ss
->data
.scalar
.expr
;
4656 if (se
->ss
->type
== GFC_SS_REFERENCE
)
4657 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
4658 se
->string_length
= se
->ss
->string_length
;
4659 gfc_advance_se_ss_chain (se
);
4663 /* We need to convert the expressions for the iso_c_binding derived types.
4664 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4665 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4666 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4667 updated to be an integer with a kind equal to the size of a (void *). */
4668 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4669 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4671 if (expr
->expr_type
== EXPR_VARIABLE
4672 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4673 || expr
->symtree
->n
.sym
->intmod_sym_id
4674 == ISOCBINDING_NULL_FUNPTR
))
4676 /* Set expr_type to EXPR_NULL, which will result in
4677 null_pointer_node being used below. */
4678 expr
->expr_type
= EXPR_NULL
;
4682 /* Update the type/kind of the expression to be what the new
4683 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4684 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4685 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4686 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4690 switch (expr
->expr_type
)
4693 gfc_conv_expr_op (se
, expr
);
4697 gfc_conv_function_expr (se
, expr
);
4701 gfc_conv_constant (se
, expr
);
4705 gfc_conv_variable (se
, expr
);
4709 se
->expr
= null_pointer_node
;
4712 case EXPR_SUBSTRING
:
4713 gfc_conv_substring_expr (se
, expr
);
4716 case EXPR_STRUCTURE
:
4717 gfc_conv_structure (se
, expr
, 0);
4721 gfc_conv_array_constructor_expr (se
, expr
);
4730 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4731 of an assignment. */
4733 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4735 gfc_conv_expr (se
, expr
);
4736 /* All numeric lvalues should have empty post chains. If not we need to
4737 figure out a way of rewriting an lvalue so that it has no post chain. */
4738 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4741 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4742 numeric expressions. Used for scalar values where inserting cleanup code
4745 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4749 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4750 gfc_conv_expr (se
, expr
);
4753 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4754 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4756 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4760 /* Helper to translate an expression and convert it to a particular type. */
4762 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4764 gfc_conv_expr_val (se
, expr
);
4765 se
->expr
= convert (type
, se
->expr
);
4769 /* Converts an expression so that it can be passed by reference. Scalar
4773 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4777 if (se
->ss
&& se
->ss
->expr
== expr
4778 && se
->ss
->type
== GFC_SS_REFERENCE
)
4780 /* Returns a reference to the scalar evaluated outside the loop
4782 gfc_conv_expr (se
, expr
);
4786 if (expr
->ts
.type
== BT_CHARACTER
)
4788 gfc_conv_expr (se
, expr
);
4789 gfc_conv_string_parameter (se
);
4793 if (expr
->expr_type
== EXPR_VARIABLE
)
4795 se
->want_pointer
= 1;
4796 gfc_conv_expr (se
, expr
);
4799 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4800 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4801 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4807 if (expr
->expr_type
== EXPR_FUNCTION
4808 && ((expr
->value
.function
.esym
4809 && expr
->value
.function
.esym
->result
->attr
.pointer
4810 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4811 || (!expr
->value
.function
.esym
4812 && expr
->symtree
->n
.sym
->attr
.pointer
4813 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4815 se
->want_pointer
= 1;
4816 gfc_conv_expr (se
, expr
);
4817 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4818 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4824 gfc_conv_expr (se
, expr
);
4826 /* Create a temporary var to hold the value. */
4827 if (TREE_CONSTANT (se
->expr
))
4829 tree tmp
= se
->expr
;
4830 STRIP_TYPE_NOPS (tmp
);
4831 var
= build_decl (input_location
,
4832 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4833 DECL_INITIAL (var
) = tmp
;
4834 TREE_STATIC (var
) = 1;
4839 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4840 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4842 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4844 /* Take the address of that value. */
4845 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4850 gfc_trans_pointer_assign (gfc_code
* code
)
4852 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4856 /* Generate code for a pointer assignment. */
4859 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4870 gfc_start_block (&block
);
4872 gfc_init_se (&lse
, NULL
);
4874 lss
= gfc_walk_expr (expr1
);
4875 rss
= gfc_walk_expr (expr2
);
4876 if (lss
== gfc_ss_terminator
)
4878 /* Scalar pointers. */
4879 lse
.want_pointer
= 1;
4880 gfc_conv_expr (&lse
, expr1
);
4881 gcc_assert (rss
== gfc_ss_terminator
);
4882 gfc_init_se (&rse
, NULL
);
4883 rse
.want_pointer
= 1;
4884 gfc_conv_expr (&rse
, expr2
);
4886 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4887 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4888 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4891 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4892 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4893 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4896 gfc_add_block_to_block (&block
, &lse
.pre
);
4897 gfc_add_block_to_block (&block
, &rse
.pre
);
4899 /* Check character lengths if character expression. The test is only
4900 really added if -fbounds-check is enabled. */
4901 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4902 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4903 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4905 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4906 gcc_assert (lse
.string_length
&& rse
.string_length
);
4907 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4908 lse
.string_length
, rse
.string_length
,
4912 gfc_add_modify (&block
, lse
.expr
,
4913 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4915 gfc_add_block_to_block (&block
, &rse
.post
);
4916 gfc_add_block_to_block (&block
, &lse
.post
);
4923 tree strlen_rhs
= NULL_TREE
;
4925 /* Array pointer. Find the last reference on the LHS and if it is an
4926 array section ref, we're dealing with bounds remapping. In this case,
4927 set it to AR_FULL so that gfc_conv_expr_descriptor does
4928 not see it and process the bounds remapping afterwards explicitely. */
4929 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
4930 if (!remap
->next
&& remap
->type
== REF_ARRAY
4931 && remap
->u
.ar
.type
== AR_SECTION
)
4933 remap
->u
.ar
.type
= AR_FULL
;
4936 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
4938 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4939 strlen_lhs
= lse
.string_length
;
4942 if (expr2
->expr_type
== EXPR_NULL
)
4944 /* Just set the data pointer to null. */
4945 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4947 else if (rank_remap
)
4949 /* If we are rank-remapping, just get the RHS's descriptor and
4950 process this later on. */
4951 gfc_init_se (&rse
, NULL
);
4952 rse
.direct_byref
= 1;
4953 rse
.byref_noassign
= 1;
4954 gfc_conv_expr_descriptor (&rse
, expr2
, rss
);
4955 strlen_rhs
= rse
.string_length
;
4957 else if (expr2
->expr_type
== EXPR_VARIABLE
)
4959 /* Assign directly to the LHS's descriptor. */
4960 lse
.direct_byref
= 1;
4961 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4962 strlen_rhs
= lse
.string_length
;
4964 /* If this is a subreference array pointer assignment, use the rhs
4965 descriptor element size for the lhs span. */
4966 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4968 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4969 gfc_init_se (&rse
, NULL
);
4970 rse
.descriptor_only
= 1;
4971 gfc_conv_expr (&rse
, expr2
);
4972 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4973 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4974 if (!INTEGER_CST_P (tmp
))
4975 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4976 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4981 /* Assign to a temporary descriptor and then copy that
4982 temporary to the pointer. */
4983 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4986 lse
.direct_byref
= 1;
4987 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4988 strlen_rhs
= lse
.string_length
;
4989 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4992 gfc_add_block_to_block (&block
, &lse
.pre
);
4994 gfc_add_block_to_block (&block
, &rse
.pre
);
4996 /* If we do bounds remapping, update LHS descriptor accordingly. */
5000 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
5004 /* Do rank remapping. We already have the RHS's descriptor
5005 converted in rse and now have to build the correct LHS
5006 descriptor for it. */
5010 tree lbound
, ubound
;
5013 dtype
= gfc_conv_descriptor_dtype (desc
);
5014 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
5015 gfc_add_modify (&block
, dtype
, tmp
);
5017 /* Copy data pointer. */
5018 data
= gfc_conv_descriptor_data_get (rse
.expr
);
5019 gfc_conv_descriptor_data_set (&block
, desc
, data
);
5021 /* Copy offset but adjust it such that it would correspond
5022 to a lbound of zero. */
5023 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
5024 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
5026 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5028 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
5030 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5031 gfc_array_index_type
, stride
, lbound
);
5032 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
5033 gfc_array_index_type
, offs
, tmp
);
5035 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5037 /* Set the bounds as declared for the LHS and calculate strides as
5038 well as another offset update accordingly. */
5039 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5041 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
5046 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
5048 /* Convert declared bounds. */
5049 gfc_init_se (&lower_se
, NULL
);
5050 gfc_init_se (&upper_se
, NULL
);
5051 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
5052 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
5054 gfc_add_block_to_block (&block
, &lower_se
.pre
);
5055 gfc_add_block_to_block (&block
, &upper_se
.pre
);
5057 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
5058 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
5060 lbound
= gfc_evaluate_now (lbound
, &block
);
5061 ubound
= gfc_evaluate_now (ubound
, &block
);
5063 gfc_add_block_to_block (&block
, &lower_se
.post
);
5064 gfc_add_block_to_block (&block
, &upper_se
.post
);
5066 /* Set bounds in descriptor. */
5067 gfc_conv_descriptor_lbound_set (&block
, desc
,
5068 gfc_rank_cst
[dim
], lbound
);
5069 gfc_conv_descriptor_ubound_set (&block
, desc
,
5070 gfc_rank_cst
[dim
], ubound
);
5073 stride
= gfc_evaluate_now (stride
, &block
);
5074 gfc_conv_descriptor_stride_set (&block
, desc
,
5075 gfc_rank_cst
[dim
], stride
);
5077 /* Update offset. */
5078 offs
= gfc_conv_descriptor_offset_get (desc
);
5079 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5080 gfc_array_index_type
, lbound
, stride
);
5081 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
5082 gfc_array_index_type
, offs
, tmp
);
5083 offs
= gfc_evaluate_now (offs
, &block
);
5084 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5086 /* Update stride. */
5087 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5088 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5089 gfc_array_index_type
, stride
, tmp
);
5094 /* Bounds remapping. Just shift the lower bounds. */
5096 gcc_assert (expr1
->rank
== expr2
->rank
);
5098 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
5102 gcc_assert (remap
->u
.ar
.start
[dim
]);
5103 gcc_assert (!remap
->u
.ar
.end
[dim
]);
5104 gfc_init_se (&lbound_se
, NULL
);
5105 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
5107 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
5108 gfc_conv_shift_descriptor_lbound (&block
, desc
,
5109 dim
, lbound_se
.expr
);
5110 gfc_add_block_to_block (&block
, &lbound_se
.post
);
5115 /* Check string lengths if applicable. The check is only really added
5116 to the output code if -fbounds-check is enabled. */
5117 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
5119 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5120 gcc_assert (strlen_lhs
&& strlen_rhs
);
5121 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5122 strlen_lhs
, strlen_rhs
, &block
);
5125 /* If rank remapping was done, check with -fcheck=bounds that
5126 the target is at least as large as the pointer. */
5127 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
5133 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
5134 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
5136 lsize
= gfc_evaluate_now (lsize
, &block
);
5137 rsize
= gfc_evaluate_now (rsize
, &block
);
5138 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
5141 msg
= _("Target of rank remapping is too small (%ld < %ld)");
5142 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
5146 gfc_add_block_to_block (&block
, &lse
.post
);
5148 gfc_add_block_to_block (&block
, &rse
.post
);
5151 return gfc_finish_block (&block
);
5155 /* Makes sure se is suitable for passing as a function string parameter. */
5156 /* TODO: Need to check all callers of this function. It may be abused. */
5159 gfc_conv_string_parameter (gfc_se
* se
)
5163 if (TREE_CODE (se
->expr
) == STRING_CST
)
5165 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
5166 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5170 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
5172 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
5174 type
= TREE_TYPE (se
->expr
);
5175 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5179 type
= gfc_get_character_type_len (gfc_default_character_kind
,
5181 type
= build_pointer_type (type
);
5182 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
5186 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
5187 gcc_assert (se
->string_length
5188 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
5192 /* Generate code for assignment of scalar variables. Includes character
5193 strings and derived types with allocatable components.
5194 If you know that the LHS has no allocations, set dealloc to false. */
5197 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
5198 bool l_is_temp
, bool r_is_var
, bool dealloc
)
5204 gfc_init_block (&block
);
5206 if (ts
.type
== BT_CHARACTER
)
5211 if (lse
->string_length
!= NULL_TREE
)
5213 gfc_conv_string_parameter (lse
);
5214 gfc_add_block_to_block (&block
, &lse
->pre
);
5215 llen
= lse
->string_length
;
5218 if (rse
->string_length
!= NULL_TREE
)
5220 gcc_assert (rse
->string_length
!= NULL_TREE
);
5221 gfc_conv_string_parameter (rse
);
5222 gfc_add_block_to_block (&block
, &rse
->pre
);
5223 rlen
= rse
->string_length
;
5226 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
5227 rse
->expr
, ts
.kind
);
5229 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
5233 /* Are the rhs and the lhs the same? */
5236 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5237 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
5238 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
5239 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
5242 /* Deallocate the lhs allocated components as long as it is not
5243 the same as the rhs. This must be done following the assignment
5244 to prevent deallocating data that could be used in the rhs
5246 if (!l_is_temp
&& dealloc
)
5248 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
5249 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
5251 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5253 gfc_add_expr_to_block (&lse
->post
, tmp
);
5256 gfc_add_block_to_block (&block
, &rse
->pre
);
5257 gfc_add_block_to_block (&block
, &lse
->pre
);
5259 gfc_add_modify (&block
, lse
->expr
,
5260 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5262 /* Do a deep copy if the rhs is a variable, if it is not the
5266 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
5267 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5269 gfc_add_expr_to_block (&block
, tmp
);
5272 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
5274 gfc_add_block_to_block (&block
, &lse
->pre
);
5275 gfc_add_block_to_block (&block
, &rse
->pre
);
5276 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
5277 TREE_TYPE (lse
->expr
), rse
->expr
);
5278 gfc_add_modify (&block
, lse
->expr
, tmp
);
5282 gfc_add_block_to_block (&block
, &lse
->pre
);
5283 gfc_add_block_to_block (&block
, &rse
->pre
);
5285 gfc_add_modify (&block
, lse
->expr
,
5286 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5289 gfc_add_block_to_block (&block
, &lse
->post
);
5290 gfc_add_block_to_block (&block
, &rse
->post
);
5292 return gfc_finish_block (&block
);
5296 /* There are quite a lot of restrictions on the optimisation in using an
5297 array function assign without a temporary. */
5300 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
5303 bool seen_array_ref
;
5305 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
5307 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5308 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
5311 /* Elemental functions are scalarized so that they don't need a
5312 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5313 they would need special treatment in gfc_trans_arrayfunc_assign. */
5314 if (expr2
->value
.function
.esym
!= NULL
5315 && expr2
->value
.function
.esym
->attr
.elemental
)
5318 /* Need a temporary if rhs is not FULL or a contiguous section. */
5319 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
5322 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5323 if (gfc_ref_needs_temporary_p (expr1
->ref
))
5326 /* Functions returning pointers need temporaries. */
5327 if (expr2
->symtree
->n
.sym
->attr
.pointer
5328 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
5331 /* Character array functions need temporaries unless the
5332 character lengths are the same. */
5333 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
5335 if (expr1
->ts
.u
.cl
->length
== NULL
5336 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5339 if (expr2
->ts
.u
.cl
->length
== NULL
5340 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5343 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
5344 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
5348 /* Check that no LHS component references appear during an array
5349 reference. This is needed because we do not have the means to
5350 span any arbitrary stride with an array descriptor. This check
5351 is not needed for the rhs because the function result has to be
5353 seen_array_ref
= false;
5354 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
5356 if (ref
->type
== REF_ARRAY
)
5357 seen_array_ref
= true;
5358 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
5362 /* Check for a dependency. */
5363 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
5364 expr2
->value
.function
.esym
,
5365 expr2
->value
.function
.actual
,
5369 /* If we have reached here with an intrinsic function, we do not
5370 need a temporary. */
5371 if (expr2
->value
.function
.isym
)
5374 /* If the LHS is a dummy, we need a temporary if it is not
5376 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
5379 /* A PURE function can unconditionally be called without a temporary. */
5380 if (expr2
->value
.function
.esym
!= NULL
5381 && expr2
->value
.function
.esym
->attr
.pure
)
5384 /* TODO a function that could correctly be declared PURE but is not
5385 could do with returning false as well. */
5387 if (!sym
->attr
.use_assoc
5388 && !sym
->attr
.in_common
5389 && !sym
->attr
.pointer
5390 && !sym
->attr
.target
5391 && expr2
->value
.function
.esym
)
5393 /* A temporary is not needed if the function is not contained and
5394 the variable is local or host associated and not a pointer or
5396 if (!expr2
->value
.function
.esym
->attr
.contained
)
5399 /* A temporary is not needed if the lhs has never been host
5400 associated and the procedure is contained. */
5401 else if (!sym
->attr
.host_assoc
)
5404 /* A temporary is not needed if the variable is local and not
5405 a pointer, a target or a result. */
5407 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
5411 /* Default to temporary use. */
5416 /* Provide the loop info so that the lhs descriptor can be built for
5417 reallocatable assignments from extrinsic function calls. */
5420 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
)
5423 /* Signal that the function call should not be made by
5424 gfc_conv_loop_setup. */
5425 se
->ss
->is_alloc_lhs
= 1;
5426 gfc_init_loopinfo (&loop
);
5427 gfc_add_ss_to_loop (&loop
, *ss
);
5428 gfc_add_ss_to_loop (&loop
, se
->ss
);
5429 gfc_conv_ss_startstride (&loop
);
5430 gfc_conv_loop_setup (&loop
, where
);
5431 gfc_copy_loopinfo_to_se (se
, &loop
);
5432 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5433 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5434 se
->ss
->is_alloc_lhs
= 0;
5439 realloc_lhs_bounds_for_intrinsic_call (gfc_se
*se
, int rank
)
5446 /* Use the allocation done by the library. */
5447 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5448 tmp
= gfc_conv_descriptor_data_get (desc
);
5449 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
5450 gfc_add_expr_to_block (&se
->pre
, tmp
);
5451 gfc_conv_descriptor_data_set (&se
->pre
, desc
, null_pointer_node
);
5452 /* Unallocated, the descriptor does not have a dtype. */
5453 tmp
= gfc_conv_descriptor_dtype (desc
);
5454 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
5456 offset
= gfc_index_zero_node
;
5457 tmp
= gfc_index_one_node
;
5458 /* Now reset the bounds from zero based to unity based. */
5459 for (n
= 0 ; n
< rank
; n
++)
5461 /* Accumulate the offset. */
5462 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5463 gfc_array_index_type
,
5465 /* Now do the bounds. */
5466 gfc_conv_descriptor_offset_set (&se
->post
, desc
, tmp
);
5467 tmp
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
5468 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5469 gfc_array_index_type
,
5470 tmp
, gfc_index_one_node
);
5471 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
5473 gfc_index_one_node
);
5474 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
5475 gfc_rank_cst
[n
], tmp
);
5477 /* The extent for the next contribution to offset. */
5478 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5479 gfc_array_index_type
,
5480 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
5481 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
5482 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5483 gfc_array_index_type
,
5484 tmp
, gfc_index_one_node
);
5486 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
5491 /* Try to translate array(:) = func (...), where func is a transformational
5492 array function, without using a temporary. Returns NULL if this isn't the
5496 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
5500 gfc_component
*comp
= NULL
;
5502 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
5505 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5507 gcc_assert (expr2
->value
.function
.isym
5508 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
5509 && comp
&& comp
->attr
.dimension
)
5510 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
5511 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
5513 ss
= gfc_walk_expr (expr1
);
5514 gcc_assert (ss
!= gfc_ss_terminator
);
5515 gfc_init_se (&se
, NULL
);
5516 gfc_start_block (&se
.pre
);
5517 se
.want_pointer
= 1;
5519 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
5521 if (expr1
->ts
.type
== BT_DERIVED
5522 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
5525 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
5527 gfc_add_expr_to_block (&se
.pre
, tmp
);
5530 se
.direct_byref
= 1;
5531 se
.ss
= gfc_walk_expr (expr2
);
5532 gcc_assert (se
.ss
!= gfc_ss_terminator
);
5534 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5535 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5536 Clearly, this cannot be done for an allocatable function result, since
5537 the shape of the result is unknown and, in any case, the function must
5538 correctly take care of the reallocation internally. For intrinsic
5539 calls, the array data is freed and the library takes care of allocation.
5540 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5542 if (gfc_option
.flag_realloc_lhs
5543 && gfc_is_reallocatable_lhs (expr1
)
5544 && !gfc_expr_attr (expr1
).codimension
5545 && !gfc_is_coindexed (expr1
)
5546 && !(expr2
->value
.function
.esym
5547 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
5549 if (!expr2
->value
.function
.isym
)
5551 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
);
5552 ss
->is_alloc_lhs
= 1;
5555 realloc_lhs_bounds_for_intrinsic_call (&se
, expr1
->rank
);
5558 gfc_conv_function_expr (&se
, expr2
);
5559 gfc_add_block_to_block (&se
.pre
, &se
.post
);
5561 return gfc_finish_block (&se
.pre
);
5565 /* Try to efficiently translate array(:) = 0. Return NULL if this
5569 gfc_trans_zero_assign (gfc_expr
* expr
)
5571 tree dest
, len
, type
;
5575 sym
= expr
->symtree
->n
.sym
;
5576 dest
= gfc_get_symbol_decl (sym
);
5578 type
= TREE_TYPE (dest
);
5579 if (POINTER_TYPE_P (type
))
5580 type
= TREE_TYPE (type
);
5581 if (!GFC_ARRAY_TYPE_P (type
))
5584 /* Determine the length of the array. */
5585 len
= GFC_TYPE_ARRAY_SIZE (type
);
5586 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5589 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5590 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5591 fold_convert (gfc_array_index_type
, tmp
));
5593 /* If we are zeroing a local array avoid taking its address by emitting
5595 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5596 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5597 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5599 /* Convert arguments to the correct types. */
5600 dest
= fold_convert (pvoid_type_node
, dest
);
5601 len
= fold_convert (size_type_node
, len
);
5603 /* Construct call to __builtin_memset. */
5604 tmp
= build_call_expr_loc (input_location
,
5605 built_in_decls
[BUILT_IN_MEMSET
],
5606 3, dest
, integer_zero_node
, len
);
5607 return fold_convert (void_type_node
, tmp
);
5611 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5612 that constructs the call to __builtin_memcpy. */
5615 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5619 /* Convert arguments to the correct types. */
5620 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5621 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5623 dst
= fold_convert (pvoid_type_node
, dst
);
5625 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5626 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5628 src
= fold_convert (pvoid_type_node
, src
);
5630 len
= fold_convert (size_type_node
, len
);
5632 /* Construct call to __builtin_memcpy. */
5633 tmp
= build_call_expr_loc (input_location
,
5634 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5635 return fold_convert (void_type_node
, tmp
);
5639 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5640 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5641 source/rhs, both are gfc_full_array_ref_p which have been checked for
5645 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5647 tree dst
, dlen
, dtype
;
5648 tree src
, slen
, stype
;
5651 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5652 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5654 dtype
= TREE_TYPE (dst
);
5655 if (POINTER_TYPE_P (dtype
))
5656 dtype
= TREE_TYPE (dtype
);
5657 stype
= TREE_TYPE (src
);
5658 if (POINTER_TYPE_P (stype
))
5659 stype
= TREE_TYPE (stype
);
5661 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5664 /* Determine the lengths of the arrays. */
5665 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5666 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5668 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5669 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5670 dlen
, fold_convert (gfc_array_index_type
, tmp
));
5672 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5673 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5675 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5676 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5677 slen
, fold_convert (gfc_array_index_type
, tmp
));
5679 /* Sanity check that they are the same. This should always be
5680 the case, as we should already have checked for conformance. */
5681 if (!tree_int_cst_equal (slen
, dlen
))
5684 return gfc_build_memcpy_call (dst
, src
, dlen
);
5688 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5689 this can't be done. EXPR1 is the destination/lhs for which
5690 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5693 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5695 unsigned HOST_WIDE_INT nelem
;
5701 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5705 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5706 dtype
= TREE_TYPE (dst
);
5707 if (POINTER_TYPE_P (dtype
))
5708 dtype
= TREE_TYPE (dtype
);
5709 if (!GFC_ARRAY_TYPE_P (dtype
))
5712 /* Determine the lengths of the array. */
5713 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5714 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5717 /* Confirm that the constructor is the same size. */
5718 if (compare_tree_int (len
, nelem
) != 0)
5721 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5722 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5723 fold_convert (gfc_array_index_type
, tmp
));
5725 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5726 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5728 stype
= TREE_TYPE (src
);
5729 if (POINTER_TYPE_P (stype
))
5730 stype
= TREE_TYPE (stype
);
5732 return gfc_build_memcpy_call (dst
, src
, len
);
5736 /* Tells whether the expression is to be treated as a variable reference. */
5739 expr_is_variable (gfc_expr
*expr
)
5743 if (expr
->expr_type
== EXPR_VARIABLE
)
5746 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
5749 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
5750 return expr_is_variable (arg
);
5757 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5758 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5759 init_flag indicates initialization expressions and dealloc that no
5760 deallocate prior assignment is needed (if in doubt, set true). */
5763 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5769 gfc_ss
*lss_section
;
5776 bool scalar_to_array
;
5780 /* Assignment of the form lhs = rhs. */
5781 gfc_start_block (&block
);
5783 gfc_init_se (&lse
, NULL
);
5784 gfc_init_se (&rse
, NULL
);
5787 lss
= gfc_walk_expr (expr1
);
5788 if (gfc_is_reallocatable_lhs (expr1
)
5789 && !(expr2
->expr_type
== EXPR_FUNCTION
5790 && expr2
->value
.function
.isym
!= NULL
))
5791 lss
->is_alloc_lhs
= 1;
5793 if (lss
!= gfc_ss_terminator
)
5795 /* Allow the scalarizer to workshare array assignments. */
5796 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5797 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5799 /* The assignment needs scalarization. */
5802 /* Find a non-scalar SS from the lhs. */
5803 while (lss_section
!= gfc_ss_terminator
5804 && lss_section
->type
!= GFC_SS_SECTION
)
5805 lss_section
= lss_section
->next
;
5807 gcc_assert (lss_section
!= gfc_ss_terminator
);
5809 /* Initialize the scalarizer. */
5810 gfc_init_loopinfo (&loop
);
5813 rss
= gfc_walk_expr (expr2
);
5814 if (rss
== gfc_ss_terminator
)
5816 /* The rhs is scalar. Add a ss for the expression. */
5817 rss
= gfc_get_ss ();
5818 rss
->next
= gfc_ss_terminator
;
5819 rss
->type
= GFC_SS_SCALAR
;
5822 /* Associate the SS with the loop. */
5823 gfc_add_ss_to_loop (&loop
, lss
);
5824 gfc_add_ss_to_loop (&loop
, rss
);
5826 /* Calculate the bounds of the scalarization. */
5827 gfc_conv_ss_startstride (&loop
);
5828 /* Enable loop reversal. */
5829 for (n
= 0; n
< loop
.dimen
; n
++)
5830 loop
.reverse
[n
] = GFC_REVERSE_NOT_SET
;
5831 /* Resolve any data dependencies in the statement. */
5832 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5833 /* Setup the scalarizing loops. */
5834 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5836 /* Setup the gfc_se structures. */
5837 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5838 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5841 gfc_mark_ss_chain_used (rss
, 1);
5842 if (loop
.temp_ss
== NULL
)
5845 gfc_mark_ss_chain_used (lss
, 1);
5849 lse
.ss
= loop
.temp_ss
;
5850 gfc_mark_ss_chain_used (lss
, 3);
5851 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5854 /* Start the scalarized loop body. */
5855 gfc_start_scalarized_body (&loop
, &body
);
5858 gfc_init_block (&body
);
5860 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5862 /* Translate the expression. */
5863 gfc_conv_expr (&rse
, expr2
);
5865 /* Stabilize a string length for temporaries. */
5866 if (expr2
->ts
.type
== BT_CHARACTER
)
5867 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5869 string_length
= NULL_TREE
;
5873 gfc_conv_tmp_array_ref (&lse
);
5874 if (expr2
->ts
.type
== BT_CHARACTER
)
5875 lse
.string_length
= string_length
;
5878 gfc_conv_expr (&lse
, expr1
);
5880 /* Assignments of scalar derived types with allocatable components
5881 to arrays must be done with a deep copy and the rhs temporary
5882 must have its components deallocated afterwards. */
5883 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5884 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5885 && !expr_is_variable (expr2
)
5886 && !gfc_is_constant_expr (expr2
)
5887 && expr1
->rank
&& !expr2
->rank
);
5888 if (scalar_to_array
&& dealloc
)
5890 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5891 gfc_add_expr_to_block (&loop
.post
, tmp
);
5894 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5895 l_is_temp
|| init_flag
,
5896 expr_is_variable (expr2
) || scalar_to_array
,
5898 gfc_add_expr_to_block (&body
, tmp
);
5900 if (lss
== gfc_ss_terminator
)
5902 /* Use the scalar assignment as is. */
5903 gfc_add_block_to_block (&block
, &body
);
5907 gcc_assert (lse
.ss
== gfc_ss_terminator
5908 && rse
.ss
== gfc_ss_terminator
);
5912 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5914 /* We need to copy the temporary to the actual lhs. */
5915 gfc_init_se (&lse
, NULL
);
5916 gfc_init_se (&rse
, NULL
);
5917 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5918 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5920 rse
.ss
= loop
.temp_ss
;
5923 gfc_conv_tmp_array_ref (&rse
);
5924 gfc_conv_expr (&lse
, expr1
);
5926 gcc_assert (lse
.ss
== gfc_ss_terminator
5927 && rse
.ss
== gfc_ss_terminator
);
5929 if (expr2
->ts
.type
== BT_CHARACTER
)
5930 rse
.string_length
= string_length
;
5932 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5933 false, false, dealloc
);
5934 gfc_add_expr_to_block (&body
, tmp
);
5937 /* Allocate or reallocate lhs of allocatable array. */
5938 if (gfc_option
.flag_realloc_lhs
5939 && gfc_is_reallocatable_lhs (expr1
)
5940 && !gfc_expr_attr (expr1
).codimension
5941 && !gfc_is_coindexed (expr1
))
5943 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
5944 if (tmp
!= NULL_TREE
)
5945 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
5948 /* Generate the copying loops. */
5949 gfc_trans_scalarizing_loops (&loop
, &body
);
5951 /* Wrap the whole thing up. */
5952 gfc_add_block_to_block (&block
, &loop
.pre
);
5953 gfc_add_block_to_block (&block
, &loop
.post
);
5955 gfc_cleanup_loop (&loop
);
5958 return gfc_finish_block (&block
);
5962 /* Check whether EXPR is a copyable array. */
5965 copyable_array_p (gfc_expr
* expr
)
5967 if (expr
->expr_type
!= EXPR_VARIABLE
)
5970 /* First check it's an array. */
5971 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5974 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5977 /* Next check that it's of a simple enough type. */
5978 switch (expr
->ts
.type
)
5990 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5999 /* Translate an assignment. */
6002 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
6007 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6009 gfc_error ("Assignment to deferred-length character variable at %L "
6010 "not implemented", &expr1
->where
);
6014 /* Special case a single function returning an array. */
6015 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
6017 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
6022 /* Special case assigning an array to zero. */
6023 if (copyable_array_p (expr1
)
6024 && is_zero_initializer_p (expr2
))
6026 tmp
= gfc_trans_zero_assign (expr1
);
6031 /* Special case copying one array to another. */
6032 if (copyable_array_p (expr1
)
6033 && copyable_array_p (expr2
)
6034 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
6035 && !gfc_check_dependency (expr1
, expr2
, 0))
6037 tmp
= gfc_trans_array_copy (expr1
, expr2
);
6042 /* Special case initializing an array from a constant array constructor. */
6043 if (copyable_array_p (expr1
)
6044 && expr2
->expr_type
== EXPR_ARRAY
6045 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
6047 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
6052 /* Fallback to the scalarizer to generate explicit loops. */
6053 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
6057 gfc_trans_init_assign (gfc_code
* code
)
6059 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
6063 gfc_trans_assign (gfc_code
* code
)
6065 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
6069 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6070 A MEMCPY is needed to copy the full data from the default initializer
6071 of the dynamic type. */
6074 gfc_trans_class_init_assign (gfc_code
*code
)
6078 gfc_se dst
,src
,memsz
;
6079 gfc_expr
*lhs
,*rhs
,*sz
;
6081 gfc_start_block (&block
);
6083 lhs
= gfc_copy_expr (code
->expr1
);
6084 gfc_add_data_component (lhs
);
6086 rhs
= gfc_copy_expr (code
->expr1
);
6087 gfc_add_vptr_component (rhs
);
6088 gfc_add_def_init_component (rhs
);
6090 sz
= gfc_copy_expr (code
->expr1
);
6091 gfc_add_vptr_component (sz
);
6092 gfc_add_size_component (sz
);
6094 gfc_init_se (&dst
, NULL
);
6095 gfc_init_se (&src
, NULL
);
6096 gfc_init_se (&memsz
, NULL
);
6097 gfc_conv_expr (&dst
, lhs
);
6098 gfc_conv_expr (&src
, rhs
);
6099 gfc_conv_expr (&memsz
, sz
);
6100 gfc_add_block_to_block (&block
, &src
.pre
);
6101 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
6102 gfc_add_expr_to_block (&block
, tmp
);
6104 return gfc_finish_block (&block
);
6108 /* Translate an assignment to a CLASS object
6109 (pointer or ordinary assignment). */
6112 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
6119 gfc_start_block (&block
);
6121 if (expr2
->ts
.type
!= BT_CLASS
)
6123 /* Insert an additional assignment which sets the '_vptr' field. */
6127 lhs
= gfc_copy_expr (expr1
);
6128 gfc_add_vptr_component (lhs
);
6130 if (expr2
->ts
.type
== BT_DERIVED
)
6131 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
6132 else if (expr2
->expr_type
== EXPR_NULL
)
6133 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
6136 rhs
= gfc_get_expr ();
6137 rhs
->expr_type
= EXPR_VARIABLE
;
6138 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
6142 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
6143 gfc_add_expr_to_block (&block
, tmp
);
6145 gfc_free_expr (lhs
);
6146 gfc_free_expr (rhs
);
6149 /* Do the actual CLASS assignment. */
6150 if (expr2
->ts
.type
== BT_CLASS
)
6153 gfc_add_data_component (expr1
);
6155 if (op
== EXEC_ASSIGN
)
6156 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
6157 else if (op
== EXEC_POINTER_ASSIGN
)
6158 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
6162 gfc_add_expr_to_block (&block
, tmp
);
6164 return gfc_finish_block (&block
);